| #!/usr/bin/perl -w |
| |
| # START USER EDITS |
| |
| # absolute path to folder files will be uploaded to. |
| # WINDOWS users, your path would like something like : images\\uploads |
| # UNIX users, your path would like something like : /home/www/images/uploads |
| # do not end the path with any slashes and if you're on a UNIX serv, make sure |
| # you CHMOD each folder in the path to 777 |
| |
| $dir = "/.../upload"; |
| $logFile = "/.../questionnaireLog.txt"; |
| |
| # if you would like to be notified of uploads, enter your email address |
| # between the SINGLE quotes. leave this blank if you would not like to be notified |
| $notify = ''; |
| |
| # UNIX users, if you entered a value for $notify, you must also enter your |
| # server's sendmail path. It usually looks something like : /usr/sbin/sendmail |
| $send_mail_path = ""; |
| |
| # WINDOWS users, if you entered a value for $notify, you must also enter your |
| # server's SMTP path. It usually looks something like : mail.servername.com |
| $smtp_path = ""; |
| |
| # file types allowed, enter each type on a new line |
| # Enter the word "ALL" in uppercase, to accept all file types. |
| @types = qw~ |
| txt |
| ~; |
| |
| #################################################################### |
| # END USER EDITS |
| #################################################################### |
| |
| $OS = $^O; # operating system name |
| if($OS =~ /darwin/i) { $isUNIX = 1; } |
| elsif($OS =~ /win/i) { $isWIN = 1; } |
| else {$isUNIX = 1;} |
| |
| if($isWIN){ $S{S} = "\\\\"; } |
| else { $S{S} = "/";} # seperator used in paths |
| |
| unless (-d "$dir"){ |
| mkdir ("$dir", 0777); # unless the dir exists, make it ( and chmod it on UNIX ) |
| chmod(0777, "$dir"); |
| } |
| |
| |
| unless (-d "$dir"){ |
| # if there still is no dir, the path entered by the user is wrong and the upload will fail |
| # send back an error code |
| # unauthorized, uid not correct |
| exit; |
| } |
| |
| use CGI; # load the CGI.pm module |
| my $GET = new CGI; # create a new object |
| my @VAL = $GET->param; #get all form field names |
| |
| foreach(@VAL){ |
| $FORM{$_} = $GET->param($_); # put all fields and values in hash |
| } |
| |
| my @files; |
| foreach(keys %FORM){ |
| # check for the parameter name |
| # This must be MYLARa where is a a number |
| if($_ =~ /^MYLAR/){ |
| push(@files, $_); # place the field NAME in an array |
| } else { |
| &log( "Filenamed not named MYLARa: ".$_); |
| exit; |
| } |
| } |
| |
| |
| if(!$VAL[0]){ |
| # no file to upload so exit with an error |
| print "Content-type: text/plain", "\n"; |
| print "Status: 501 Not Implemented", "\n\n"; |
| print "Upload Failed - no file to upload","\n"; |
| &log("Upload Failed - no file to upload\n"); |
| exit; |
| } |
| |
| |
| my $failed; # results string = false |
| my $selected; # num of files selected by user |
| |
| #################################################################### |
| |
| #################################################################### |
| |
| foreach (@files){ |
| # upload each file, pass the form field NAME if it has a value |
| if($GET->param($_)){ |
| # if the form field contains a file name &psjs_upload subroutine |
| # the file's name and path are passed to the subroutine |
| $returned = &psjs_upload($_); |
| if($returned =~ /^Success/i){ |
| # if the $returned message begins with "Success" the upload was succssful |
| # remove the word "Success" and any spaces and we're left with the filename |
| $returned =~ s/^Success\s+//; |
| push(@success, $returned); |
| } else { |
| # else if the word "success" is not returned, the message is the error encountered. |
| # add the error to the $failed scalar |
| $failed .= $returned; |
| } |
| $selected++; # increment num of files selected for uploading by user |
| } |
| } |
| |
| if(!$selected){ |
| # no files were selected by user, so nothing is returned to either variable |
| $failed .= qq~No files were selected for uploading~; |
| } |
| |
| # if no error message is return ed, the upload was successful |
| |
| my ($fNames, $aa, $bb, @current, @currentfiles ); |
| |
| if($failed){ |
| |
| # file failed to upload return error |
| print "Content-type: text/plain", "\n"; |
| print "Status: 501 Not Implemented", "\n\n"; |
| print "Upload Failed","\n"; |
| |
| } else { |
| # upload was successful |
| # log the success and return success code |
| |
| # send email if valid email was entered |
| if(check_email($notify)){ |
| |
| # TODO send an appropriate message |
| |
| # enter the message you would like to receive |
| my $message = qq~ |
| The following files were uploaded to your server : |
| ~; |
| |
| foreach(@success){ |
| $message .= qq~ |
| $dir/$_ |
| ~; |
| } |
| |
| if($isUNIX){ |
| $CONFIG{mailprogram} = $send_mail_path; |
| # enter your e-mail name here if you like |
| # from e-mail, from name, to e-mail, to name, subject, body |
| &send_mail($notify, 'Demo Upload', $notify, 'Demo Upload', 'Upload Notification', $message); |
| |
| } else { |
| $CONFIG{smtppath} = $smtp_path; |
| &send_mail_NT($notify, 'Your Name', $notify, 'Your Name', 'Upload Notification', $message); |
| } |
| } |
| |
| # NEED TO LOG THE UPLOAD |
| foreach(@success){ |
| &log("NONE" . "\t" . "$dir/$_"); |
| } |
| |
| |
| print "Content-type: text/plain". "\n"; |
| print "Status: 200 OK", "\n\n"; |
| print "Upload Success","\n"; |
| } |
| |
| #################################################################### |
| |
| #################################################################### |
| |
| sub psjs_upload { |
| |
| my $filename = $GET->param($_[0]); |
| $filename =~ s/.*[\/\\](.*)/$1/; |
| my $upload_filehandle = $GET->upload($_[0]); |
| # if $file_type matchs one of the types specified, make the $type_ok var true |
| for($b = 0; $b < @types; $b++){ |
| if($filename =~ /^.*\.$types[$b]$/i){ |
| $type_ok++; |
| } |
| if($types[$b] eq "ALL"){ |
| $type_ok++; # if ALL keyword is found, increment $type_ok var. |
| } |
| } |
| |
| # if ok, check if overwrite is allowed |
| if($type_ok){ |
| if(open UPLOADFILE, ">$dir/$filename"){ |
| |
| binmode UPLOADFILE; |
| |
| while ( <$upload_filehandle> ) |
| { |
| print UPLOADFILE; |
| } |
| close UPLOADFILE; |
| }else { |
| return qq~Error opening file on the server~; |
| } |
| } else { |
| return qq~Bad file type~; |
| } |
| |
| # check if file has actually been uploaded, by checking the file has a size |
| if(-s "$dir/$filename"){ |
| return qq~Success $filename~; #success |
| } else { |
| # delete the file as it has no content |
| # user probably entered an incorrect path to file |
| return qq~Upload failed : No data in $filename. No size on server's copy of file. |
| Check the path entered.~; |
| } |
| } |
| |
| #################################################################### |
| |
| #################################################################### |
| |
| sub check_existence { |
| # $dir,$filename,$newnum are the args passed to this sub |
| my ($dir,$filename,$newnum) = @_; |
| |
| my (@file_type, $file_type, $exists, $bareName); |
| # declare some vars we will use later on in this sub always use paranthesis |
| # when declaring more than one var! Some novice programmers will tell you |
| # this is not necessary. Tell them to learn how to program. |
| |
| if(!$newnum){$newnum = "0";} # new num is empty in first call, so set it to 0 |
| |
| # read dir and put all files in an array (list) |
| opendir(DIR, "$dir"); |
| @existing_files = readdir(DIR); |
| closedir(DIR); |
| |
| # if the filename passed exists, set $exists to true or 1 |
| foreach(@existing_files){ |
| if($_ eq $filename){ |
| $exists = 1; |
| } |
| } |
| |
| # if it exists, we need to rename the file being uploaded and then recheck it to |
| # make sure the new name does not exist |
| if($exists){ |
| $newnum++; # increment new number (add 1) |
| |
| # get the extension |
| @file_type = split(/\./, $filename); # split the dots and add inbetweens to a list |
| # put the first element in the $barename var |
| $bareName = $file_type[0]; |
| # we can assume everything after the last . found is the extension |
| $file_type = $file_type[$#file_type]; |
| # $#file_type is the last element (note the pound or hash is used) |
| |
| # remove all numbers from the end of the $bareName |
| $bareName =~ s/\d+$//ig; |
| |
| # concatenate a new name using the barename + newnum + extension |
| $filename = $bareName . $newnum . '.' . $file_type; |
| |
| # reset $exists to 0 because the new file name is now being checked |
| $exists = 0; |
| |
| # recall this subroutine |
| &check_existence($dir,$filename,$newnum); |
| } else { |
| # the $filename, whether the first or one hundreth call, now does not exist |
| # so return the name to be used |
| return ($filename); |
| } |
| } |
| |
| #################################################################### |
| |
| #################################################################### |
| |
| sub send_mail { |
| my ($from_email, $from_name, $to_email, $to_name, $subject, $message ) = @_; |
| |
| if(open(MAIL, "|$CONFIG{mailprogram} -t")) { |
| print MAIL "From: $from_email ($from_name)\n"; |
| print MAIL "To: $to_email ($to_name)\n"; |
| print MAIL "Subject: $subject\n"; |
| print MAIL "$message\n\nSubmitter's IP Address : $ENV{REMOTE_ADDR}"; |
| close MAIL; |
| return(1); |
| } else { |
| return; |
| } |
| } |
| |
| #################################################################### |
| |
| #################################################################### |
| |
| sub send_mail_NT { |
| |
| my ($from_email, $from_name, $to_email, $to_name, $subject, $message ) = @_; |
| |
| my ($SMTP_SERVER, $WEB_SERVER, $status, $err_message); |
| use Socket; |
| $SMTP_SERVER = "$CONFIG{smtppath}"; |
| |
| # correct format for "\n" |
| local($CRLF) = "\015\012"; |
| local($SMTP_SERVER_PORT) = 25; |
| local($AF_INET) = ($] > 5 ? AF_INET : 2); |
| local($SOCK_STREAM) = ($] > 5 ? SOCK_STREAM : 1); |
| # local(@bad_addresses) = (); |
| $, = ', '; |
| $" = ', '; |
| |
| $WEB_SERVER = "$CONFIG{smtppath}\n"; |
| chop ($WEB_SERVER); |
| |
| local($local_address) = (gethostbyname($WEB_SERVER))[4]; |
| local($local_socket_address) = pack('S n a4 x8', $AF_INET, 0, $local_address); |
| |
| local($server_address) = (gethostbyname($SMTP_SERVER))[4]; |
| local($server_socket_address) = pack('S n a4 x8', $AF_INET, $SMTP_SERVER_PORT, $server_address); |
| |
| # Translate protocol name to corresponding number |
| local($protocol) = (getprotobyname('tcp'))[2]; |
| |
| # Make the socket filehandle |
| if (!socket(SMTP, $AF_INET, $SOCK_STREAM, $protocol)) { |
| return; |
| } |
| |
| # Give the socket an address |
| bind(SMTP, $local_socket_address); |
| |
| # Connect to the server |
| if (!(connect(SMTP, $server_socket_address))) { |
| return; |
| } |
| |
| # Set the socket to be line buffered |
| local($old_selected) = select(SMTP); |
| $| = 1; |
| select($old_selected); |
| |
| # Set regex to handle multiple line strings |
| $* = 1; |
| |
| # Read first response from server (wait for .75 seconds first) |
| select(undef, undef, undef, .75); |
| sysread(SMTP, $_, 1024); |
| #print "<P>1:$_"; |
| |
| print SMTP "HELO $WEB_SERVER$CRLF"; |
| sysread(SMTP, $_, 1024); |
| #print "<P>2:$_"; |
| |
| while (/(^|(\r?\n))[^0-9]*((\d\d\d).*)$/g) { $status = $4; $err_message = $3} |
| if ($status != 250) { |
| return; |
| } |
| |
| print SMTP "MAIL FROM:<$from_email>$CRLF"; |
| |
| sysread(SMTP, $_, 1024); |
| #print "<P>3:$_"; |
| if (!/[^0-9]*250/) { |
| return; |
| } |
| |
| # Tell the server where we're sending to |
| print SMTP "RCPT TO:<$to_email>$CRLF"; |
| sysread(SMTP, $_, 1024); |
| #print "<P>4:$_"; |
| /[^0-9]*(\d\d\d)/; |
| |
| # Give the server the message header |
| print SMTP "DATA$CRLF"; |
| sysread(SMTP, $_, 1024); |
| #print "<P>5:$_"; |
| if (!/[^0-9]*354/) { |
| return; |
| } |
| |
| $message =~ s/\n/$CRLF/ig; |
| |
| print SMTP qq~From: $from_email ($from_name)$CRLF~; |
| print SMTP qq~To: $to_email ($to_name)$CRLF~; |
| # if($cc){ |
| # print SMTP "CC: $cc ($cc_name)\n"; |
| # } |
| print SMTP qq~Subject: $subject$CRLF$CRLF~; |
| print SMTP qq~$message~; |
| |
| print SMTP "$CRLF.$CRLF"; |
| sysread(SMTP, $_, 1024); |
| #print "<P>6:$_"; |
| if (!/[^0-9]*250/) { |
| return; |
| } else { |
| return(1); |
| } |
| |
| if (!shutdown(SMTP, 2)) { |
| return; |
| } |
| } |
| |
| #################################################################### |
| |
| #################################################################### |
| |
| sub check_email { |
| my($fe_email) = $_[0]; |
| if($fe_email) { |
| if(($fe_email =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)|(\.$)/) || |
| ($fe_email !~ /^.+@\[?(\w|[-.])+\.[a-zA-Z]{2,3}|[0-9]{1,3}\]?$/)) { |
| return; |
| } else { return(1) } |
| } else { |
| return; |
| } |
| } |
| #################################################################### |
| |
| #################################################################### |
| |
| sub log { |
| open(LOG, "+<$logFile") || die "Can't open Log File: $!\n"; |
| |
| seek LOG, 0, 2; |
| print LOG $_[0] . "\t\t"; |
| |
| my ($sec,$min,$hour,$mday,$mon,$year, $wday,$yday,$isdst) = localtime time; |
| |
| # update the year so that it is correct since it perl |
| # has a 1900 yr offset |
| $year += 1900; |
| |
| # update the month since it is 0 based in perl |
| $mon += 1; |
| |
| printf LOG "%02d/%02d/%04d %02d:%02d:%02d\n", $mday, $mon, $year, $hour, $min, $sec; |
| |
| close LOG; |
| } |