#!/usr/bin/perl

############################################################################
### Copyright (C)  Tripodics.com
### Author:	Bruce A. Martin
### File Name:	upreplace.pl
### Purpose:	Replace a specified file
### Versions:
my $ver="8.2";
###	8.2	bam:2010/330	Fix error in $loadfile:  s/UPLOAD: *//
###	8.0	bam:2008/521	Revise (dirs, cgi-bin, etc.) and fix security
#			FORM METHOD=POST 
###	7.2	bam:2007/1/28		Allow new.
###	7.1	bam:2006/11/21		(Add file types (vb, etc.)
###	7	bam:2006/11/15		(was replace.pl)
###	0.2	bam:2004/11/12		Replace a specified file.  (based on fileup.pl)
###	0.1	bam:2004/10/23		Upload binary file(s) (into parent dir).
###	0.0				(based on modify.pl + upload.cgi)
#############################################################################


#### Boilerplate:
#
use strict;
use CGI qw/:standard/;
$| = 1;

print header;		# Begin HTML output.
print "<HTML>"; 


#### Useful strings. ####
my $Q =		'"'; 
my $NL =	"\n"; 
my $TAB=	"	";
my $NBSP=	"&nbsp;";
my $SP4=	"&nbsp;&nbsp;&nbsp;&nbsp;"; 
my $LT = '<';
my $GT = '>';
	#$LT="^";	#++++++ FOR DEBUGGING, MAKE TAGS VISIBLE!
my $TAG = $LT;
my $stamp=	$^T; 				# Timestamp.
&timestamp;

my $DEBUG="";


#### Get form parameters from URL.
#
my %in_para;
foreach (param()){
       	$in_para{$_} = join " ", param($_);
	# Multiple-values (checkbox) joined with blanks.
	print "<LI> $_ = $in_para{$_}" if $DEBUG >5;
if ($_ eq "DEBUG") { $DEBUG=$in_para{$_}; }
}


#FROM:	http://www.sitepoint.com/article/uploading-files-cgi-perl/2
my $query = new CGI;
my $filename = $query->param("UPFILE");
$filename =~ s/.*[\/\\](.*)/$1/;

my $upload_filehandle = $query->upload("UPFILE");
print "<LI>upload_filehandle = $upload_filehandle " if $DEBUG >5;

#--	my $filename=	$in_para{UPFILE};
#??	if ($filename =~ /^[^-A-Za-z0-9]*$/)	{$filename = "test.dat";}
#

my $loadfile = $in_para{SUBMIT};
$loadfile =~ s/UPLOAD: *//;
$loadfile =~ s/.*[\/\\](.*)/$1/;
if ( $loadfile ne "" && $loadfile ne $filename ) {
	print "<H1 ALIGN=CENTER> [$loadfile] != [$filename] </H1>";
	die;
}

my $specfile = $in_para{SPECIFIED};
if ( $loadfile ne "" && $loadfile ne $specfile ) {
	print "<H1 ALIGN=RIGHT> $loadfile != $specfile ... </H1>";
				print "Sorry, your file names must match!";
				print "<BR>The uploaded file was:  $loadfile ";
				print "<BR>The web server file is: $specfile ";
				print "<P> Go BACK to previous page, to try again.";
				print "<BR><I> (For new files, you must first create an empty file, with the correct name; then yoyu may REPLACE it.)</I> ";
	die;
}



######## PATHS & FILENAMES ########
my $pwd=	`pwd`;
my $ppwd=	`cd ..; pwd`;				# Parent directory.
my $sub=	`cd ..; basename \`pwd\` `;  chop $sub;

my $prepath = "../..";					#### Set prefix to path. ####

#my $dirname = $path . "./";
my $dirname = "";

my $DIRNAME = $in_para{DIRNAME};
#if ($DIRNAME =~ /^$/) { $DIRNAME="."; }	
$DIRNAME =~ s|/*/|/|g;					# No adjacent slashes.
#if ($DIRNAME) { $dirname = $path  . $DIRNAME . "/"; }
if ($DIRNAME) { $dirname = $DIRNAME . "/"; }
if ($DIRNAME =~ /^\//) { $DIRNAME=~ s/^\/*//g; }	
if ($DIRNAME =~ /^\/$/) { $DIRNAME=""; }	

$dirname=  $DIRNAME;
#????????????? $dirname ??????????????

my $dirslash="";
if ($dirname ne "") { $dirslash=  $dirname . "/"; }
my $subslash="";
if ($sub ne "") { $subslash=  $sub . "/"; }

my $NEW = $in_para{NEW};
my $new= 0;
if ($NEW eq "NEW") { $new= 1; }


my $ext= $filename;
$ext =~ s/^.*\.//;			# Extract the ext
if ($ext eq $filename) { $ext=  ""; }	# (No .ext)
my $root= $filename;
$root =~ s/\.[^.]*$//;			# Remove the ext.
$root =~ s/^.*[\/]//;			# Remove ll up to last slash.
my $fn=  $subslash . $dirslash . $filename;

my $saveold=	"$prepath/old/$stamp.$filename"; 





######## HTML ########

print "<HEAD><TITLE> Replace $root.$ext in WUSB.FM/$sub/$dirslash 7a</TITLE>\n";
#--	print "<BODY BGCOLOR=#99CCFF onLoad=$Q UPFILE.value='$root.$ext'; $Q >\n";
print "<BODY BGCOLOR=#99CCFF >\n";

print "<P ALIGN=RIGHT onClick=$Q;if (confirm('Close this window, now?')) {window.close();exit;};$Q> 
	<FONT COLOR=RED><U>Close this window?</U></FONT> </A>\n";
print "<H2 ALIGN=CENTER> Replace a specified file:  $NBSP <U>$fn</U> </H2>";



if ($filename =~ /^$/) { print "Empty filename:  $filename \n"; die; }

## Allowable characters only.
$filename =~ s|[^-A-Za-z0-9_/.]|_|g;	
#
## Security considerations.
$filename =~ s|[.][.][.]*||g;			# Disallow multiple dots.
$filename =~ s|^\.||g;				# Disallow leading dot.
$filename =~ s|^/||g;				# Disallow leading slash.
$filename =~ s|/\.||g;				# Disallow slash dot.
$filename =~ s|//*|/|g;				# Disallow multiple slashes.
$filename =~ s|~|+|g;				# Disallow tilde (~username).
#

#### Full name of server file.
my $rmtname=  "$prepath/$filename";

#print "<LI> -e $rmtname ";  if ( -e $rmtname) { print "TRUE <BR>"; } else  { print "FALSE <BR>"; }
#print "<LI> -d $rmtname ";  if ( -d $rmtname) { print "TRUE <BR>"; } else  { print "FALSE <BR>"; }
#print "<LI> -l $rmtname ";  if ( -l $rmtname) { print "TRUE <BR>"; } else  { print "FALSE <BR>"; }
#print "<LI> -T $rmtname ";  if ( -T $rmtname) { print "TRUE <BR>"; } else  { print "FALSE <BR>"; }
#print "<LI> -w $rmtname ";  if ( -w $rmtname) { print "TRUE <BR>"; } else  { print "FALSE <BR>"; }
#print "<LI> -x $rmtname ";  if ( -x $rmtname) { print "TRUE <BR>"; } else  { print "FALSE <BR>"; }

print "filename=$filename<BR>";


print "filename=$filename<BR>";

if ( -e $rmtname) {

	&filestats( $rmtname );

	if ( -d $rmtname) { print "$rmtname is a directory.\n";  }
	elsif ( -l $rmtname) { print "$rmtname is a symbolic-link.\n"; }
	#if ( -T $rmtname) { print "$rmtname is not a text file.\n";  }
	if ( ! -w $rmtname) { print "$rmtname cannot be written.\n"; die; }
}
else { 
	if ($new<1) { print "$sub/$filename does not exist!\n"; die; }
}

if ( -x $rmtname) { print "**** ATTEMPT TO UPLOAD EXECUTABLE FILE!!!!"; die; }


#### Global variables.
my $text="";



#### Main processing.  #### 
#

	#if ($filename =~ /^\s*$/) { $filename=""; }
	if ($filename =~ /^\s*$/) { $filename="."; }
	#### Check for file name.
	if ($filename =~ /^\s*\.*\s*$/) {			# Check for empty (or dots only)
print "<P> ERROR!!!!  Do not use this script for arbitrary files.  (Must specify file in form args.)"; die;
	}

print "+++";

	#### Check file name.
	#
	my $ext = $filename;
	$ext =~ s/^..*\.//;			#### Allow only certain ext types.
	if ( $ext =~ /^gif$/i 
	  or $ext =~ /^png$/i 
	  or $ext =~ /^jpe*g$/i 
	  	or $ext =~ /^html$/i 
	  	or $ext =~ /^shtml$/i 
	  	or $ext =~ /^htm$/i 
	  	or $ext =~ /^js$/i 
	  	or $ext =~ /^css$/i 
	  	or $ext =~ /^inc$/i 
	  	or $ext =~ /^txt$/i 
	  	or $ext =~ /^inc$/i 
	  	or $ext =~ /^java$/i 
	  	or $ext =~ /^vb$/i 
	  	or $ext =~ /^cpp$/i 
	){ 

print "";

		if ($upload_filehandle eq "") { 
			&makefileup( "" );
		} else {
			#### Upload it.
			#



			#### Check for $filename = $uploadname.
			if ( $loadfile ne $filename ) {
				print "<H1 ALIGN=CENTER> ($loadfile) != ($filename) </H1>";
				die;
			} else {
				#print "<LI> $loadfile $filename";
			}
			

			`chmod -x $prepath/$dirname/$filename`;
			&replacefile( "$prepath/$dirname/$filename", $upload_filehandle, $saveold );
		}

	} else {
		print "<H1 ALIGN=CENTER> Disallowed file type: &nbsp;&nbsp; $ext </H1>\n";
	}

	print "<HR><P ALIGN=RIGHT><FORM ACTION=${Q}update.pl$Q METHOD=POST ALIGN=RIGHT>";
	print "<INPUT TYPE=SUBMIT VALUE=$Q Close this window $Q ";
	print "	onClick=$Q;window.close();exit;$Q>"; 
	print "</FORM></P>";



############################################################################
######	Software developed & owned by Tripodics.   ########
####	Copyright 1996-2004 by Tripodics, All Rights Reserved.          ####
####	Tripodics Computing Service, POBox 456 Middle Island, NY 11953  ####
#+++	(Nonexclusive usage granted to WUSB, Stony Brook, NY.)          +++#
############################################################################

sub replacefile( $f, $upload_filehandle, $saveold )
{
	my $f = @_[0];
	my $upload_filehandle = @_[1];
	my $saveold = @_[2];
	print "<P>@@@@ &replacefile( $f, $upload_filehandle, $saveold ) " if $DEBUG > 0; 

	#### Save old file, with timestamp.
	if ($saveold ne "") {
		`cp $f ${Q}$saveold${Q}`;
	}

	open UPLOADFILE, ">$f";
	#
	my $many=0;
	while ( <$upload_filehandle> )
	{
		#print "<P>@@@@ &uploadbin:  $+"; 
  		print UPLOADFILE;
		$many++;
	}
	close UPLOADFILE;
	if ($many <= 0) { 
		print "<P>ERROR: &nbsp; Nothing was uploaded: &nbsp;"; 
		print "$pwd/$f <BR>\n";
	}
	else {
		print <<END_HTML;
<TABLE CELLPADDING=6 BORDER=4 BGCOLOR=WHITE><TR><TD>
<P>Your file has been replaced:
<BR CLEAR=ALL>
<img src="$f" ALT="$f" NAME="PHOTO" border="1" HSPACE="20" VSPACE="4" />
<BR CLEAR=ALL>$pwd/$f
</TABLE>
	<I>Old file saved in:   
	<A HREF=$Q$saveold$Q TARGET=OLD>
	$Q$saveold$Q</I>
	</A>
<SCRIPT>
<!--//
	if (confirm('Close this window, now?')) {window.close()}
//-->
</SCRIPT>
END_HTML
	}

}

sub makefileup( $d )
{
	my $d = @_[0];

	#### Form to replace a file.
	#

	print "<UL>";
	print "<form name=FORMUP method=${Q}post${Q} enctype=${Q}multipart/form-data${Q} action=${Q}upreplace.pl${Q}>\n";
	print "<TABLE BGCOLOR=#FF0000 BORDER=8><TR><TD> \n";
	print "<TABLE CELLPADDING=20 BORDER=0 CELLPADDING=2 BGCOLOR=#6699CC><TR><TD> \n";
	print "<U>Replace the specified file</U>:<BR><UL>\n";

	print "<INPUT TYPE=HIDDEN NAME=NEW VALUE=$Q$NEW$Q ";

	print "<INPUT TYPE=${Q}FILE${Q} NAME=${Q}UPFILE$Q VALUE=$Q??????$root.$ext$Q SIZE=40 \n";
	print " style=$Q font-size: 20; font-weight: bold; color: firebrick; background-color: yellow $Q";

	print "	onClick=${Q}SUBMIT.value='REPLACE with:  '+UPFILE.value;";
	#??	print "	onMouseover=${Q};alert( FORMUP.UPFILE.value );FORMUP.UPFILE.value='$filename' ";
	#--	print "		SUBMIT.value='UPLOAD '+UPFILE.value;";
#+++++++++ Check filename -- must be same!!
	print "		SUBMIT.focus()$Q;";
	print "	onChange=$Q";
	print "		if(UPFILE.value=='') {alert('Specify a file name!');SUBMIT.value='';UPFILE.focus();}";
	print "		else {SUBMIT.value='UPLOAD:   '+UPFILE.value;SUBMIT.focus();}$Q";
	print "	>\n"; 
	print "</UL>\n";

	print "<INPUT TYPE=HIDDEN NAME=DIRNAME VALUE=${Q}$dirname$Q >\n";
	print "<INPUT TYPE=HIDDEN NAME=FILENAME VALUE=${Q}$Q >\n";
	print "<INPUT TYPE=HIDDEN NAME=SPECIFIED VALUE=${Q}$filename$Q >\n";

	print "<TR><TD>";
	print "<BR CLEAR=ALL><P>\n";
	print "<INPUT TYPE=SUBMIT NAME=SUBMIT VALUE=${Q}$Q\n";
	print "	style=$Q font-size: 20; font-weight: bold; color: firebrick; background-color: orange $Q";
	#--	print "	onClick=${Q}UPFILE.value='$filename/'+UPFILE.value+'.'+EXT.value;";
	#--	print "		FILENAME.value='$filename/'+UPFILE.value;";
	print "	onClick=$Q;";
	#print "		UPFILE.value='$filename/'+UPFILE.value;";
	print "		if(UPFILE.value=='') {alert('Specify a file name!');SUBMIT.value='';UPFILE.focus();return false}";
	print "		else{return true;};$Q";
	print "	>\n";
#print "<SCRIPT>\n";
#print "<!--//\n";
	#print "alert( FORMUP.UPFILE.value );\n";
	#print "FORMUP.UPFILE.value='$filename';\n";
#print "//-->\n";
#print "</SCRIPT>\n";

	print "</TABLE>\n";
	print "</TABLE>\n"; 
	print "</FORM>\n";
	print "</UL>";

	print "<SCRIPT><!--\n";
	print "function showpix(i,j,k) {\n";
print "alert(k.name);";
	print "		i.src='file://'+UPFILE.value;";
	print "		j.src='/img/pixel.gif';";
	print "		k.SUBMIT.value='k.UPLOAD '+k.UPFILE.value;";
	#print "		k.SUBMIT.focus();";
	print "}//--></SCRIPT>\n";
}



########  The following subroutines are from the Tripodics Library. ########
#### Copyright 1996-2002 by Tripodics, All Rights Reserved.             ####
#### Tripodics Computing Service, POBox 456 Middle Island, NY 11953     ####
#+++   (Nonexclusive usage granted to WUSB, Stony Brook, NY.)     +++#
############################################################################


sub timestamp
{
	my ($sec, $min, $hour, $day, $month, $year, $wday, $yday, $dst) = gmtime();
	$stamp=  sprintf( "20%02d%02d%02dT%02d%02d%02d$%6d", 
		$year % 100, $month+1, $day, $hour, $min, $sec, $$ );
}

sub datetime( s )
{
	my $s = @_[0];
	my ($sec, $min, $hour, $day, $month, $year, $wday, $yday, $dst) = localtime($s);
	#print "< my ($sec, $min, $hour, $day, $month, $year, $wday, $yday, $dst) = $s;<BR>" ;
	#--	my $result=  sprintf( "20%02d-%02d-%02d %02d:%02d:%02d.$%6d", 
		#--	$year % 100, $month+1, $day, $hour, $min, $sec, $$ );
$sec %= 60;
	my $result=  sprintf( "20%02d/%02d/%02d %02d:%02d:%02d", 
		$year % 100, $month+1, $day, $hour, $min, $sec );
	return $result;
}

sub saydie( $msg )
{
	my $msg = @_[0];
	print $msg;
	die;
}

sub filestats( $rmtfile )
{
  my $rmtfile = @_[0];
  my $f;
  my $d;
  my $d0;
  my $name;
  foreach $name ( $rmtfile ) {
	#print "<P>@@@@ &filestats( $name ) "; 

	#$name =~ s/\.\.//g;			# Remove .. from name.
	$name =~ s/~/+/g;			# Replace tildes.  

	&saydie("HIDDEN FILE") if ( $name =~ /^\.[^.\/]/ );	## Hide the hidden files.  ("./" and "../" are OK)
	&saydie("LEADING SLASH") if ( $name =~ /^\// );			## No leading slash.
	&saydie("ONLY $/. ") if ( $name =~ /^[-.\$\/]*$/ );		## Not merely $/. etc.

	&saydie("executable") if ( -f $name && -x $f  );		## Hide executable files!
	&saydie("EXECUTABLE") if ( -f $name && -X $f  );		## Hide executable files!
	&saydie("PL") if ( $name =~ /\.pl/i );		## Hide the .pl files.
	#++++ Others to hide or skip??


	my $f = $name;
	my $ff=$f;
	#--	$ff =~ s/^\.\///g;
	#--	$ff =~ s/^[.\/~ 	]*//g;		# $ff has no leading dots, slashes, blanks


	print "<P><A HREF=$Q$ff$Q TARGET=NEW>";
	print "<FONT SIZE=+2 FACE=${Q}monospaced$Q COLOR=#990000>";
	print "$name";
	if ( ! -T $f ) {
		print "<IMG SRC=$Q$ff$Q BORDER=0 XWIDTH=96 HSPACE=6>";
	}
	print "</FONT></A>\n";


	#### Get file info . ####
	(my $dev, my $inc, my $mode, my $nlink, my $uid, my $gid, my $rdev, my $size, my $atime, my $mtime, my $ctime, my $blksize, my $blocks ) =  stat( $f );
	my $size = -s $f;
	my $modstamp = &datetime( $mtime );


	my $type=  $mode / 010000 % 0100;
	my $perm=  $mode & 07777;
	print "<FONT FACE=${Q}sans-serif$Q SIZE=-3> "; 
		if ($type == 4) {printf "d"; }
		elsif ($type == 010) {printf " ";}
		else { printf "%o", $type;}
		printf " %o", " $perm"; 
	print "</FONT> \n";
	print " | <FONT FACE=${Q}sans-serif$Q SIZE=-1> $size <SMALL>bytes</SMALL></FONT> \n";
	print " | <FONT FACE=${Q}sans-serif$Q SIZE=-1> $modstamp </FONT> \n";

	#print "<TD> $dev, $inc, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime, $ctime, $blksize, $blocks \n";

	print "<P>";

  }
}


##############################  End of bamlib.inc  #############################

