Search This Blog

2006-12-28

simple file upload with perl

#!C:\Perl\bin\perl.exe
######################################################
# upload a file with netscape 2.0+ or IE 4.0+
# Muhammad A Muquit
# When: Long time ago
# Changelog:
# James Bee" <JamesBee@home.com> reported that from Windows filename
# such as c:\foo\fille.x saves as c:\foo\file.x, Fixed, Jul-22-1999
# Sep-30-2000, muquit@muquit.com
# changed the separator in count.db to | from :
# As in NT : can be a part of a file path, e.g. c:/foo/foo.txt
# Commented out the user verivication
######################################################
#
# $Revision: 5 $
# $Author: Muquit $
# $Date: 3/28/04 9:38p $

use strict;
use CGI;
# if you want to restrict upload a file size (in bytes), uncomment the
# next line and change the number

$CGI::POST_MAX=50000;

$|=1;

my $version="V1.4";

## vvvvvvvvvvvvvvvvvvv MODIFY vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv

# the text database of the user. The text database contains the |
# separated items, namely login|encrypted password|upload path
# example: muquit|fhy687kq1hger|/usr/local/web/upload/muquit
# if no path is specified, the file must be located in the cgi-bin directory.

my $g_upload_db="upload.db";

# overwrite the existing file or not. Default is to overwrite
# chanage the value to 0 if you do not want to overwrite an existing file.
my $g_overwrite=1;

# if you want to restrict upload to files with certain extentions, change
# the value of $g_restrict_by_ext=1 and ALSO modify the @g_allowed_ext if you
# want to add other allowable extensions.
my $g_restrict_by_ext=1;
# case insensitive, so file with Jpeg JPEG GIF gif etc will be allowed
my @g_allowed_ext=("jpeg","jpg","gif","png" , "txt");

## ^^^^^^^^^^^^^^^^^^^ MODIFY ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^



#-------------- globals---------- STARTS ------------------
my $query=new CGI;
my $g_debug=0;


my $g_title="File upload";
my $g_upload_path='./deployment/perAgent/';

#-------------- globals---------- ENDS ------------------


print $query->header;

# Java Script for form validation
#
my $JSCRIPT=<<EJS;

var returnVal=true;
var DEBUG=0;

//===========================================================================
// Purpose: check if field is blank or NULL
// Params:
// field (IN)
// errorMsg (IN - MODIFIED)
// fieldTitle (IN)
// Returns:
// errorMsg - error message
// Globals:
// sets global variable (returnVal) to FALSE if field is blank or NULL
// Comments:
// JavaScript code adapted from netscape software registration form.
// ma_muquit\@fccc.edu, May-09-1997
//===========================================================================

function ValidateAllFields(obj)
{
returnVal = true;
errorMsg = "The required field(s):\\n";

// make sure all the fields have values
if (isSomeFieldsEmpty(obj) == true)
{
// DISPLAY ERROR MSG
displayErrorMsg();
returnVal = false;
}

if (returnVal == true)
document.forms[0].submit();
else
return (false);
}

//===========================================================================
function displayErrorMsg()
{
errorMsg += "\\nhas not been completed.";
alert(errorMsg);
}

//===========================================================================
function isSomeFieldsEmpty(obj)
{
var
returnVal3=false;



// check if login is null
if (obj.userid.value == "" || obj.userid.value == null)
{
errorMsg += " " + "Userid" + "\\n";
returnVal3=true;
}

// check if Password is null

if (obj.password.value == "" || obj.password.value == null)
{
errorMsg += " " + "Password" + "\\n";
returnVal3=true;
}

// check if upload_file is null
if (obj.upload_file.value == "" || obj.upload_file.value == null)
{
errorMsg += " " + "Upload filename" + "\\n";
returnVal3=true;
}

return (returnVal3);
}

EJS
;

# print the HTML HEADER
&printHTMLHeader;

if ($query->path_info eq "/author" or $query->path_info eq "/about")
{
&printForm();
&printAuthorInfo();
return;
}

if ($query->param)
{
&doWork();
}
else
{
&printForm();
}

##-----
# printForm() - print the HTML form
##-----
sub printForm
{

print "<center>\n";
print "<table border=0 bgcolor=\"#c0c0c0\" cellpadding=5 cellspacing=0>\n";

print $query->start_multipart_form,"\n";

#------------- userid
print "<tr>\n";
# print "<td align=\"right\">\n";
# print "Userid:\n";
# print "</td>\n";

print "<td>\n";
# print $query->textfield(-name=>'userid',
# -size=>20);
print "</td>\n";
print "</tr>\n";

#------------- password
print "<tr>\n";
# print "<td align=\"right\">\n";
# print "Password:\n";
# print "</td>\n";

# print "<td>\n";
# print $query->password_field(-name=>'password',
# -size=>20);
# print "</td>\n";
# print "</tr>\n";

#------------- upload
print "<tr>\n";
print "<td align=\"right\">\n";
print "Upload file:\n";
print "</td>\n";

print "<td>\n";
print $query->filefield(-name=>'upload_file',
-size=>30,
-maxlength=>120);
print "</td>\n";
print "</tr>\n";



#------------- submit
print "<tr>\n";
print "<td colspan=2 align=\"center\">\n";
print "<hr noshade size=1>\n";
print $query->submit(-label=>'Upload',
-value=>'Upload',
-onClick=>"return ValidateAllFields(this.form)"),"\n";
print "</td>\n";
print "</tr>\n";



print $query->endform,"\n";

print "</table>\n";
print "</center>\n";
}



##------
# printHTMLHeader()
##------
sub printHTMLHeader
{
print $query->start_html(
-title=>"$g_title",
# -script=>$JSCRIPT,
-bgcolor=>"#ffffff",
-link=>"#ffff00",
-vlink=>"#00ffff",
-alink=>"#ffff00",
-text=>"#000000");
}

##-------
#Purpose : to upload the actual file
##-------
sub doWork
{
##################
my $em='';
##################


# import the paramets into a series of variables in 'q' namespace
$query->import_names('q');
# check if the necessary fields are empty or not
# $em .= "<br>You must specify your Userid!<br>" if !$q::userid;
# $em .= "You must specify your Password!<br>" if !$q::password;
$em .= "You must select a file to upload!<br>" if !$q::upload_file;

&printForm();
if ($em)
{
&printError($em);
return;
}

# if (&validateUser() == 0)
# {
# &printError("Will not upload! Could not validate Userid: $q::userid");
# return;
# }

# if you want to restrict upload to files with certain extention
if ($g_restrict_by_ext == 1)
{
my $file=$q::upload_file;
my @ta=split('\.',$file);
my $sz=scalar(@ta);
if ($sz > 1)
{
my $ext=$ta[$sz-1];
if (! grep(/$ext/i,@g_allowed_ext))
{
&printError("You are not allowed to upload this file");
return;
}

}
else
{
&printError("You are not allowed to upload this file");
return;
}
}

# now upload file
&uploadFile();

if ($g_debug == 1)
{
my @all=$query->param;
my $name;
foreach $name (@all)
{
print "$name ->", $query->param($name),"<br>\n";
}
}
}

##------
# printError() - print error message
##------
sub printError
{
my $em=shift;
print<<EOF;
<center>
<hr noshade size=1 width="80%">
<table border=0 bgcolor="#000000" cellpadding=0 cellspacing=0>
<tr>
<td>
<table border=0 width="100%" cellpadding=5 cellspacing=1>
<tr>
<td bgcolor="#ffefd5" width="100%">

<font color="#ff0000"><b>Error -</b></font>
$em</td>
</tr>
</table>
</td>
</tr>

</table>
</center>
EOF
;
}

##--
# validate login name
# returns 1, if validated successfully
# 0 if validation fails due to password or non existence of login
# name in text database
##--
sub validateUser
{
my $rc=0;
my ($u,$p);
my $userid=$query->param('userid');
my $plain_pass=$query->param('password');

# open the text database
unless(open(PFD,$g_upload_db))
{
my $msg=<<EOF;
Could not open user database: $g_upload_db
<br>
Reason: $!
<br>
Make sure that your web server has read permission to read it.
EOF
;
&printError("$msg");
return;
}

# first check if user exist
$g_upload_path='';
my $line='';
while (<PFD>)
{
$line=$_;
chomp($line);
# get rid of CR
$line =~ s/\r$//g;
($u,$p,$g_upload_path)=split('\|',$line);
if ($userid eq $u)
{
$rc=1;
last;
}
}
close(PFD);

if (crypt($plain_pass,$p) ne $p)
{
$rc=0;
}

return ($rc);
}


sub uploadFile
{
my $bytes_read=0;
my $size='';
my $buff='';
my $start_time;
my $time_took;
my $filepath='';
my $filename='';
my $write_file='';

$filepath=$query->param('upload_file');

# James Bee" <JamesBee@home.com> reported that from Windows filename
# such as c:\foo\fille.x saves as c:\foo\file.x, so we've to get the
# filename out of it
# look at the last word, hold 1 or more chars before the end of the line
# that doesn't include / or \, so it will take care of unix path as well
# if it happens, muquit, Jul-22-1999
if ($filepath =~ /([^\/\\]+)$/)
{
$filename="$1";
}
else
{
$filename="$filepath";
}
# if there's any space in the filename, get rid of them
$filename =~ s/\s+//g;

$write_file="$g_upload_path" . "/" . "$filename";

&print_debug("Filename=$filename");
&print_debug("Writefile= $write_file");

if ($g_overwrite == 0)
{
if (-e $write_file)
{
&printError("File $filename exists, will not overwrite!");
return;
}
}

if (!open(WFD,">$write_file"))
{
my $msg=<<EOF;
Could not create file: <code>$write_file</code>
<br>
It could be:
<ol>
<li>The upload directory: <code>\"$g_upload_path\"</code> does not have write permission for the
web server.
<li>The upload.db file has Control character at the end of line
</ol>
EOF
;

&printError("$msg");
return;
}

$start_time=time();
while ($bytes_read=read($filepath,$buff,2096))
{
$size += $bytes_read;
binmode WFD;
print WFD $buff;
}

&print_debug("size= $size");

close(WFD);

if ((stat $write_file)[7] <= 0)
{
unlink($write_file);
&printError("Could not upload file: $filename");
return;
}
else
{
$time_took=time()-$start_time;
print<<EOF;
<center>
<hr noshade size=1 width="90%">
<table border=0 bgcolor="#c0c0c0" cellpadding=0 cellspacing=0>
<tr>
<td>
<table border=0 width="100%" cellpadding=10 cellspacing=2>
<tr align="center">
<td bgcolor="#000099" width="100%">
<font color="#ffffff">
File
<font color="#00ffff"><b>$filename</b></font> of size
<font color="#00ffff"><b>$size</b></font> bytes is
uploaded successfully!
</font>
</td>
</tr>
</table>
</td>
</tr>

</table>
</center>
EOF
;
}
}

sub printAuthorInfo
{
my $url="http://www.muquit.com/muquit/";
my $upl_url="http://muquit.com/muquit/software/upload_pl/upload_pl.html";
print<<EOF;
<center>
<hr noshade size=1 width="90%">
<table border=0 bgcolor="#c0c0c0" cellpadding=0 cellspacing=0>
<tr>
<td>
<table border=0 width="100%" cellpadding=10 cellspacing=2>
<tr align="center">
<td bgcolor="#000099" width="100%">
<font color="#ffffff">
<a href="$upl_url">
upload.pl</a> $version by
<a href="$url">Muhammad A Muquit</A>
</font>
</td>
</tr>
</table>
</td>
</tr>

</table>
</center>
EOF
;
}

sub print_debug
{
my $msg=shift;
if ($g_debug)
{
print "<code>(debug) $msg</code><br>\n";
}
}

Labels

perl (41) Cheat Sheet (25) how-to (24) windows (14) sql server 2008 (13) linux (12) oracle (12) sql (12) Unix (11) cmd windows batch (10) mssql (10) cmd (9) script (9) textpad (9) netezza (8) sql server 2005 (8) cygwin (7) meta data mssql (7) metadata (7) bash (6) code generation (6) Informatica (5) cheatsheet (5) energy (5) tsql (5) utilities (5) excel (4) future (4) generic (4) html (4) perl modules (4) programs (4) settings (4) sh (4) shortcuts (4) поуки (4) принципи (4) Focus Fusion (3) Solaris (3) cool programs (3) development (3) economy (3) example (3) freeware (3) fusion (3) git cheat sheet (3) logging (3) morphus (3) mssql 2005 (3) nuclear (3) nz (3) parse (3) python (3) sftp (3) sofware development (3) source (3) sqlplus (3) table (3) vim (3) .Net (2) C# (2) China (2) GUI (2) Google (2) GoogleCL (2) Solaris Unix (2) ascii (2) awk (2) batch (2) cas (2) chrome extensions (2) code2html (2) columns (2) configuration (2) conversion (2) duplicates (2) excel shortcuts (2) export (2) file (2) free programs (2) informatica sql repository (2) linux cheat sheet (2) mssql 2008 (2) mysql (2) next big future (2) nsis (2) nz netezza cheat sheet (2) nzsql (2) ora (2) prediction (2) publish (2) release management (2) report (2) security (2) single-click (2) sqlserver 2005 (2) sqlserver 2008 (2) src (2) ssh (2) template (2) tools (2) vba (2) video (2) xlt (2) xml (2) youtube videos (2) *nix (1) .vimrc (1) .virmrc vim settings configs (1) BSD license (1) Bulgaria (1) Dallas (1) Database role (1) Dense plasma focus (1) Deployment (1) ERP (1) ExcelToHtml (1) GD (1) GDP (1) HP-UX (1) Hosting (1) INC (1) IT general (1) ITIL management bullshit-management (1) IZarc (1) Java Web Start (1) JavaScript anchor html jquery (1) Khan Academy (1) LINUX UNIX BASH AND CYGWIN TIPS AND TRICKS (1) Linux Unix rpm cpio build install configure (1) Linux git source build .configure make (1) ListBox (1) MIT HYDROGEN VIRUS (1) OO (1) Obama (1) PowerShell (1) Run-time (1) SDL (1) SIWA (1) SOX (1) Scala (1) Services (1) Stacks (1) SubSonic (1) TED (1) abstractions (1) ansible hosts linux bash (1) ansible linux deployment how-to (1) ansible yum pip python (1) apache (1) apache 2.2 (1) application life cycle (1) architecture (1) archive (1) arguments (1) avatar (1) aws cheat sheet cli (1) aws cli (1) aws cli amazon cheat sheet (1) aws elb (1) backup (1) bash Linux open-ssh ssh ssh_server ssh_client public-private key authentication (1) bash perl search and replace (1) bash stub (1) bin (1) biofuels (1) biology (1) books (1) browser (1) bubblesort (1) bugs (1) build (1) byte (1) cas_sql_dev (1) chennai (1) chrome (1) class (1) claut (1) cmdow (1) code generation sqlserver (1) command (1) command line (1) conf (1) confluence (1) console (1) convert (1) cool programs windows free freeware (1) copy-paste (1) csv (1) ctags (1) current local time (1) cygwin X11 port-forwarding mintty xclock Linux Unix X (1) cygwin bash how-to tips_n_tricks (1) cygwin conf how-to (1) data (1) data types (1) db2 cheat sheet (1) db2 starter ibm bash Linux (1) debt (1) diagram (1) dictionaries (1) digital (1) disk (1) disk space (1) documentation (1) dos (1) dubai (1) e-cars (1) electric cars (1) electricity (1) emulate (1) errors (1) exponents (1) export workflow (1) extract (1) fast export (1) fexp (1) file extension (1) file permissions (1) findtag (1) firewall (1) for loop (1) freaky (1) functions (1) fusion research (1) german (1) git gitlab issues handling system (1) google cli (1) google code (1) google command line interface (1) gpg (1) ha (1) head (1) helsinki (1) history (1) hop or flop (1) host-independant (1) how-to Windows cmd time date datetime (1) ibm db2 cognos installation example db deployment provisioning (1) ideas (1) image (1) informatica oracle sql (1) informatica repo sql workflows sessions file source dir (1) informatica source files etl (1) install (1) isg-pub issue-tracker architecture (1) it management best practices (1) java (1) jump to (1) keyboard shortcuts (1) ksh (1) level (1) linkedin (1) linux bash ansible hosts (1) linux bash commands (1) linux bash how-to shell expansion (1) linux bash shell grep xargs (1) linux bash tips and t ricks (1) linux bash unix cygwin cheatsheet (1) linux bash user accounts password (1) linux bash xargs space (1) linux cheat-sheet (1) linux cheatsheet cheat-sheet revised how-to (1) linux how-to non-root vim (1) linux ssh hosts parallel subshell bash oneliner (1) london (1) make (1) me (1) metacolumn (1) metadata functions (1) metaphonre (1) method (1) model (1) movie (1) multithreaded (1) mysql cheat sheet (1) mysql how-to table datatypes (1) n900 (1) nano (1) neteza (1) netezza bash linux nps (1) netezza nps (1) netezza nps nzsql (1) netezza nz Linux bash (1) netezza nz bash linux (1) netezza nz nzsql sql (1) netezza nzsql database db sizes (1) non-password (1) nord pol (1) nps backup nzsql schema (1) number formatting (1) nz db size (1) nz table count rows (1) nzsql date timestamp compare bigint to_date to_char now (1) on-lier (1) one-liners (1) one-to-many (1) oneliners (1) open (1) open source (1) openrowset (1) openssl (1) oracle PL/SQL (1) oracle Perl perl (1) oracle installation usability (1) oracle number formatting format-model ora-sql oracle (1) oracle templates create table (1) oracle trigger generic autoincrement (1) oracle vbox virtual box cheat sheet (1) oracle virtual box cheat sheet (1) outlook (1) parser (1) password (1) paths (1) perl @INC compile-time run-time (1) perl disk usage administration Linux Unix (1) perl modules configuration management (1) permissions (1) php (1) picasa (1) platform (1) postgreSQL how-to (1) powerShell cmd cygwin mintty.exe terminal (1) ppm (1) predictions (1) prices (1) principles (1) productivity (1) project (1) prompt (1) proxy account (1) public private key (1) publishing (1) putty (1) qt (1) read file (1) registry (1) relationship (1) repository (1) rm (1) scp (1) scripts (1) scsi (1) search and replace (1) sed (1) sendEmail (1) sh stub (1) shortcuts Windows sql developer Oracle (1) sidebar (1) silicon (1) smtp (1) software procurement (1) sofware (1) sort (1) sql script (1) sql_dev (1) sqlcmd (1) sqlite (1) sqlite3 (1) sshd (1) sshd cygwin (1) stackoverflow (1) stored procedure (1) stub (1) stupidity (1) subroutines (1) svn (1) sysinternals (1) tail (1) tar (1) temp table (1) templates (1) teradata (1) terminal (1) test (1) testing (1) theory (1) thorium (1) time (1) tip (1) title (1) tmux .tmux.conf configuration (1) tmux efficiency bash (1) tool (1) ui code prototyping tips and tricks (1) umask Linux Unix bash file permissions chmod (1) url (1) urls (1) user (1) utility (1) utils (1) vb (1) vbox virtual box cheat sheet (1) vim perl regex bash search for string (1) vim recursively hacks (1) vim starter (1) vim-cheat-sheet vim cheat-sheet (1) vimeo (1) visual stuio (1) warsaw (1) wiki (1) wikipedia (1) window (1) windows 7 (1) windows 8 (1) windows programs (1) windows reinstall (1) windows utility batch perl space Windows::Clipboard (1) wisdoms (1) workflow (1) worth-reading (1) wrapper (1) xp_cmdshell (1) xslt (1) youtube (1)

Blog Archive

Translate with Google Translate

My Blog List

VideoBar

This content is not yet available over encrypted connections.