Please see the upload script below. It works, but what I want to do, is use the my FTP site for the Upload_dir, instead of the local directory of my website, which is hosted by my service provider.
Please suggest what I should do different to make this work! Thank you in advance
#!/usr/bin/perl
use CGI::Carp qw(fatalsToBrowser);
use CGI;
use File::Basename;
$CGI::POST_MAX = 1024 * 5000;
my $safe_filename_characters = "a-zA-Z0-9_.-";
my $upload_dir = "MyWebsite/upload";
my $query = new CGI;
my $filename = $query->param("photo");
my $email_address = $query->param("email_address");
if ( !$filename ) { print $query->header ( );
print "There was a problem uploading your photo (try a smaller file).";
exit; } my ( $name, $path, $extension ) = fileparse ( $filename, '\..*' );
$filename = $name . $extension;
$filename =~ tr/ /_/;
$filename =~ s/[^$safe_filename_characters]//g;
if ( $filename =~ /^([$safe_filename_characters]+)$/ ) { $filename = $1;
} else { die "Filename contains invalid characters";
} my $upload_filehandle = $query->upload("photo");
open ( UPLOADFILE, ">$upload_dir/$filename" ) or die "$!";
binmode UPLOADFILE;
print $query->header();
while ( <$upload_filehandle> )
{
print UPLOADFILE;
}
close UPLOADFILE;
print $query->header ( ); print qq~
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head> <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<title>
Thanks!
</title>
<style type="text/css"> img {border: none;}
</style>
</head>
<body>
<p>Thanks for uploading your photo!</p>
<p>Your email address: $email_address</p>
<p>Your photo:</p>
<p><img src="/upload/$filename" alt="Photo" /></p>
</body>
</html>
~;
I guess the simplest way is to upload to the local file like you are doing. Once the file is uploaded you should then add sime Net::FTP code to send the file from the webserver to your FTP server. Your service provider will need to allow outgoing FTP for this to work.
use Net::FTP;
...
close UPLOADFILE;
my $ftp = Net::FTP->new( $your_ftp ) || die "$#";
$ftp->login($ftp_user,$ftp_pswd) || die $ftp->message;
$ftp->cwd($ftp_dir) || die $ftp->message;
$ftp->binary();
$ftp->pasv(); # optional. May be required
$ftp->put("$upload_dir/$filename",$filename) || die $ftp->message;
undef $ftp;
...
By the way I usually use an auto generated local filename to ensure two users uploading at the same time with the same name don't cause issues. I usually use something like time().'-'.$$
Related
I realize this is an older script, but I would appreciate
any help getting it to work properly. Years ago it worked
fine, but lately it's been acting funny.
Excuse the formatting please....
When I run it in the browser, the french accented characters
do not show properly. But in the text file that it generates,
they show just fine. What is happening here?
Perl version is v5.20.2
My database is MySQL, utf8_unicode_ci
The table is also utf8_unicode_ci
in browser: Hélène Rollan and in file: Hélène Rollan
in browser: Coeur à l`écoute and in file: Coeur à l`écoute
#!/usr/bin/perl --
use utf8;
use CGI::Carp qw(fatalsToBrowser);
use CGI qw (:standard);
$q = new CGI;
use Encode;
use open ':encoding(utf8)';
binmode(STDOUT, ":unix:utf8");
$user = "manager";
require "config.cgi";
&Create_DB_Connection;
$time = time();
sub Create_DB_Connection{
use DBI;
$DSN = "DBI:mysql:$mysql_database:$mysql_hostname";
$dbh = DBI->connect($DSN, "$mysql_username", "$mysql_password", {mysql_enable_utf8 => 1}) || die return;
if ($dbh) { $connected = "YES"; }
return;
}
sub Do_SQL{
eval{
$sth = $dbh->prepare($SQL);
};
$dbh->do(qq{SET NAMES 'utf8';});
$sth->execute;
return ($sth);
}
&downline;
# Prepare and show tree of affiliates
sub downline {
($sec, $min, $hour, $day, $mon, $year, $dweek, $dyear, $daylight) = localtime(time());
$month = $mon;
$year = $year + 1900;
print $q->header;
print<<EOF;
<HTML><HEAD><TITLE>Network Summary</TITLE>
<meta http-equiv="Content-type" content="text/html;charset=utf-8" />
</HEAD>
<style type="text/css">
<!--
A:visited {text-decoration: none;}
A:hover {text-decoration: underline;}
A:link {text-decoration: none;}
A:active {text-decoration: none;}
.MEMBERS {font-size: 8pt; text-decoration: none; font-family: Verdana,verdana; color: FF0000;}
-->
</style>
<BODY BGCOLOR="FFFFFF" TEXT="000000" LINK="000080" VLINK="004080">
<center><font size=4 face=arial color=000000><b>Network Summary as of $month/$year</b><br>
<font face=verdana,arial size=1><a href=wmstats_en2.cgi>[return to main page]</a></font></center>
<p>
EOF
$featured_file = "/home/bruce/data/featured.txt";
$SQL="SELECT FIRST_NAME,LAST_NAME,SPONSOR_ID,CO_SPONSOR_ID,ID FROM main_members";
&Do_SQL;
while ($row = $sth->fetchrow_hashref){
$info{$row->{'ID'}} = [$row->{'FIRST_NAME'},$row->{'LAST_NAME'},$row->{'SPONSOR_ID'}];
push #{ $kids{$row->{'CO_SPONSOR_ID'}} }, $row->{'ID'};
}
$kid = "$user";
if (!$kids{$kid}) {
print<<EOF;
<center><b><font size=2 face=arial>There are currently no members in your downline</font></b><font size=4 face=arial color=000000><br><BR>
EOF
} else {
&crunch(1);
}
$o++;
sub crunch {
foreach $kid (#{ $kids{$kid} }) {
$newlevel++;
$payouts{$newlevel}++;
$levels{$newlevel}++;
$total_downline++;
while ($b < $newlevel) { $report .= " "; $b++; } $b=0;
$report .= "$newlevel: $kid - $info{$kid}[0] $info{$kid}[1] <br>";
# I added this to generate a text file
open (FILE, ">>$featured_file");
flock(FILE, 2);
print FILE "$newlevel: $kid - $info{$kid}[0] $info{$kid}[1] \n";
flock(FILE, 8);
close (FILE);
&crunch($newlevel);
$newlevel--;
delete($info{$kid});
}
}
print<<EOF;
<center><table><tr><td valign=top nowrap>
<font face=verdana size=2>
$report
</td><td valign=top>
<table cellpadding=0><tr>
<td align=right nowrap><font face=verdana,arial size=2><b>Total Downline:<p> </td><td><font face=verdana,arial size=2><b> $total_downline<p> </td></tr>
EOF
while (!$found_some) { $i++;
if ($levels{$i}) {
print<<EOF;
<tr><td align=right><font face=verdana,arial size=2><b>Level $i:</td><td><font face=verdana,arial size=2><b> $levels{$i}</td></tr>
EOF
} else { $found_some = 1; }
}
print<<EOF;
</td></tr></table>
<p><font face=verdana size=2><b>
</TD></TR></TABLE></TD></TR></TABLE>
EOF
}
After removing the irrelevant bits and fixing the problem, you get the following. (If you had removed the irrelevant bits from the Question itself, it would be easier to see the differences.)
# Specifies the file is encoded using UTF-8.
# This doesn't matter for this program.
use utf8;
# Set the encoding for STDIN, STDOUT and STDERR.
# Set the default encoding for file handles.
use open ':std', ':encoding(utf-8)';
use CGI qw( );
use DBI qw( );
use FindBin qw( $RealBin );
use Template qw( );
my $cgi = CGI->new();
my $dbh = DBI->connect(
"dbi:mysql:...",
"...",
"...",
{
RaiseError => 1,
PrintError => 0,
PrintWarn => 1,
# Decodes strings from the database.
# Specifying this now performs SET NAMES 'UTF8'
mysql_enable_utf8 => 1,
},
);
my $val = $dbh->selectrow_array('SELECT ...');
{
open(my $fh, '>', '...')
or die(...);
print($fh $val);
}
{
print $cgi->header('text/html; charset=UTF-8');
my %vars = (
val => $val,
);
my $tt = Template->new({
ENCODING => "UTF-8",
INCLUDE_PATH => "$RealBin/tmpl",
});
$tt->process('test.tmpl', \%vars)
or die($tt->error());
}
tmpl/test.tmpl:
<html>
<head>
<title>Test</title>
<meta http-equiv="Content-type" content="text/html; charset=UTF-8">
</head>
<body>
[% val | html %]
</body>
</html>
That is, of course, assuming the data in the database is correct. My request to have this verified has gone unanswered.
I have a simple web form in which I want the user to select a folder to upload (I only care about the contents of the folder). So my attempt to make this work is as followed:
#!/usr/bin/perl
use strict;
use warnings;
use CGI;
use Data::Dumper;
my $q = CGI->new();
print $q->header;
my $upload_folder = '/var/www/html/uploads';
my $name = $q->param('name');
my $email = $q->param('email');
my $comments = $q->param('comments');
my #files = $q->param('multi_files');
foreach my $upload(#files){
print "Upload this please -- $upload<br>";
my $upload_file = $q->upload($upload);
if ($upload_file){
open (OUTFILE,">$upload_folder/$upload") or die $!;;
binmode OUTFILE;
while (<$upload_file>) {
print OUTFILE;
}
}
else {
print "<b>Guess it's broken</b><br/>";
}
}
print "<p><b>Name</b> -- $name<br><b>Email</b> -- $email<br><b>Comments</b> -- $comments<br>";
print $q->end_html;
When I run the script all the parameters are correct, the files print out as expected but when I execute the upload query it returns blank. This is my first attempt at using CGI as I tend to use other languages to process forms.
Here is the code from the form just in case :
<html>
<head>
<title>Stupid Test Site</title>
<script src="//ajax.googleapis.com/ajax/libs/jquery/1.11.3/jquery.min.js" ></script>
</head>
<body>
<h1>This is a test</h1>
<form action="/cgi-enabled/test.pl" method="POST">
Your Name: <input type="text" name="name"><br>
Email Address: <input type="text" name="email"><br>
Select PO folder: <input name="multi_files" type="file" webkitdirectory multiple /><br/>
Comments:<br>
<textarea name="comments" rows="5" cols="60"></textarea><br>
<input type="submit" value="Send">
</form>
</body>
</html>
I've also posted this question on perlmonks.com as well.
The main issue with my code was it was missing the
enctype="multipart/form-data"
from the form. I made some changes as well. Here is my working code.
#!/usr/bin/perl
use strict;
use warnings;
use CGI;
use Data::Dumper;
use CGI::Carp qw( fatalsToBrowser );
use HTML::Entities qw/encode_entities/;
use File::Copy qw' copy ';
use File::Basename;
my $q = new CGI;
print $q->header;
my $upload_folder = '/var/www/html/uploads';
my $name = $q->param('name');
my $email = $q->param('email');
my $comments = $q->param('comments');
my #files = $q->param('multi_files');
my #io_handles=$q->upload('multi_files');
my %file_hash;
foreach my $item(#files){
next unless $item =~ /.+\/(M.+\.pdf)/;
foreach my $sub_item(#io_handles){
if($item eq $sub_item){
$file_hash{$item} = $sub_item;
}
}
}
chdir $upload_folder or die "Cannot chdir to upload destination directory: $!\n";
print '<ul>';
foreach my $key(keys %file_hash){
my $base = basename($file_hash{$key});#
my $tmpfilename = $q->tmpFileName($file_hash{$key});
my $destFile = File::Spec->catfile($upload_folder,$base);
copy( $tmpfilename, $destFile ) or die "Copy to ($destFile) failed: $!\n";
print '<li>Sucessfully uploaded --- <b>', CGI->escapeHTML(basename($key)), '</b></li>';
}
print '</ul>';
print "<p><b>Name</b> -- $name<br><b>Email</b> -- $email<br><b>Comments</b> -- $comments<br>";
print $q->end_html;
Thanks for the help. (I posted this answer on perlmonks.com as well)
I have a Perl script I wrote, saved it as index.cgi, and it reads in a table of shortlinks and their expansion from a TSV:
redirects.tsv:
$ head redirects.tsv
about http://tobilehman.com/about
gapminder http://www.gapminder.org/
speed http://speedof.me/
delete http://justdelete.me/
terms http://tosdr.org/
re https://www.debuggex.com/
1 http://www.diffen.com/difference/Diffen_vs_Wikipedia
2 http://arstechnica.com/information-technology/2013/10/google-fiber-now-explicitly-permits-home-servers/
3 https://www.senate.gov/legislative/LIS/roll_call_lists/roll_call_vote_cfm.cfm?congress=113
ifs http://tobilehman.com/blog/2013/10/19/revisiting-spaces-in-file-names/
index.cgi:
#!/usr/bin/perl
print "Content-type: text/html\n\n";
my $current_time = time();
my $file = "redirects.tsv";
open my $lines, $file or die "Could not open redirects.tsv";
my $redirect_html = "";
while ( my $line = <$lines> ) {
$line =~ /^([0-9a-z_-]+)\t(.*)/;
#$redirect_html = "$redirect_html\n<li><a href='$1'>tblh.mn/$1</a> ($2)</li>";
my $link = "http://tblh.mn/$1";
$redirect_html
= "$redirect_html<tr><td><a href='$link'>$link</td><td>→</td><td style='padding-left:15px'>$2</td></tr>\n";
}
print <<HTML;
<html>
<head>
<link href="/favicon.png" rel="icon">
<title>tblh.mn → tobilehman.com</title>
</head>
<body>
<h1>Current Time: $current_time</h1>
<h1>Short Links</h1>
<table>
$redirect_html
</table>
</body>
</html>
HTML
exit;
Right now, the links are being printed as in Last-In-Last-Out, but I'd like them to be printed as Last-In-First-Out.
I tried solving this by using reverse(<$lines>) and <reverse($lines)>, neither of which worked. I am not very familiar with Perl, so forgive me if this is a noob problem.
As has already been pointed out, you can use reverse to reverse an array, or File::ReadBackwards to do what its name implies.
Additionally, I would like to encourage you to do some basic error checking in your script:
Always include use strict; and use warnings; in EVERY script.
Include use autodie any time you're doing file processing.
Make sure that your regular expression matched before using the capture variables.
And stylistically:
Use the concatenation operator to build a string $string .= "more string";
Use alternative delimiters like qq{ } whenever you want to include double quotes in a string.
Including these changes with a couple other small fixes:
#!/usr/bin/perl
use strict;
use warnings;
use autodie;
print "Content-type: text/html\n\n";
my $current_time = time();
my $file = "redirects.tsv";
open my $fh, '<', $file;
my $redirect_html = "";
for ( reverse <$fh> ) {
chomp;
if ( my ( $shortlink, $full ) = /^([0-9a-z_-]+)\t(.*)/ ) {
my $link = "http://tblh.mn/$shortlink";
$redirect_html
.= qq{<tr><td><a href="$link">$link</td><td>→</td><td style="padding-left:15px">$full</td></tr>\n};
#$redirect_html .= "\n<li><a href='$1'>tblh.mn/$1</a> ($2)</li>";
}
}
print <<"HTML";
<html>
<head>
<link href="/favicon.png" rel="icon">
<title>tblh.mn → tobilehman.com</title>
</head>
<body>
<h1>Current Time: $current_time</h1>
<h1>Short Links</h1>
<table>
$redirect_html
</table>
</body>
</html>
HTML
exit;
for my $line (reverse(<$lines>)) {
...
}
Alternatively, File::ReadBackwards.
I have a html as the following:
<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head>
<title></title>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
</head>
<body bgcolor="white">
<h1>foo.c</h1>
<form method="post" action=""
enctype="application/x-www-form-urlencoded">
Compare this file to the similar file:
<select name="file2">
<option value="...">...</option>
</select>
<input type="hidden" name="file1" value="foo.c" /><br>
Show the results in this format:
</form>
<hr>
<p>
<pre>
some code
</pre>
I need to get value of input name = 'file' and the contents of HTML pre tag. I don't know on perl language, by googling I wrote this small program(that I believe isn't "elegant"):
#!/usr/bin/perl
package MyParser;
use base qw(HTML::Parser);
#Store the file name and contents obtaind from HTML Tags
my($filename, $file_contents);
#This value is set at start() calls
#and use in text() routine..
my($g_tagname, $g_attr);
#Process tag itself and its attributes
sub start {
my ($self, $tagname, $attr, $attrseq, $origtext) = #_;
$g_tagname = $tagname;
$g_attr = $attr;
}
#Process HTML tag body
sub text {
my ($self, $text) = #_;
#Gets the filename
if($g_tagname eq "input" and $g_attr->{'name'} eq "file1") {
$filename = $attr->{'value'};
}
#Gets the filecontents
if($g_tagname eq "pre") {
$file_contents = $text;
}
}
package main;
#read $filename file contents and returns
#note: it works only for text/plain files.
sub read_file {
my($filename) = #_;
open FILE, $filename or die $!;
my ($buf, $data, $n);
while((read FILE, $data, 256) != 0) {
$buf .= $data;
}
return ($buf);
}
my $curr_filename = $ARGV[0];
my $curr_file_contents = read_file($curr_filename);
my $parser = MyParser->new;
$parser->parse($curr_file_contents);
print "filename: ",$filename,"file contents: ",$file_contents;
Then I call ./foo.pl html.html But I'm getting empty values from $filename and $file_contents variables.
How to fix this?
Like always, there's more than one way to do it. Here's how to use the DOM Parser of Mojolicious for this task:
#!/usr/bin/env perl
use strict;
use warnings;
use Mojo::DOM;
# slurp all lines at once into the DOM parser
my $dom = Mojo::DOM->new(do { local $/; <> });
print $dom->at('input[name=file1]')->attr('value');
print $dom->at('pre')->text;
Output:
foo.c
some code
Using xpath and HTML::TreeBuilder::XPath Perl module ( very few lines ):
#!/usr/bin/env perl
use strict; use warnings;
use HTML::TreeBuilder::XPath;
my $tree = HTML::TreeBuilder::XPath->new_from_content( <> );
print $tree->findvalue( '//input[#name="file1"]/#value' );
print $tree->findvalue( '//pre/text()' );
USAGE
./script.pl file.html
OUTPUT
foo.c
some code
NOTES
in the past, I was using HTML::TreeBuilder module to do some web-scraping. Now, I can't go back to complexity. HTML::TreeBuilder::XPath do all the magic with the useful Xpath expressions.
you can use new_from_file method to open a file or a filehandle instead of new_from_content, see perldoc HTML::TreeBuilder ( HTML::TreeBuilder::XPath inherit methods from HTML::TreeBuilder)
using <> in this way is allowed here because HTML::TreeBuilder::new_from_content() specifically allows reading multiple lines in that way. Most constructors will not allow this usage. You should provide a scalar instead or use another method.
You don't generally want to use plain HTML::Parser unless you're writing your own parsing module or doing something generally tricky. In this case, HTML::TreeBuilder, which is a subclass of HTML::Parser, is the easiest to use.
Also, note that HTML::Parser has a parse_file method (and HTML::TreeBuilder makes it even easier with a new_from_file method, so you don't have to do all of this read_file business (and besides, there are better ways to do it than the one you picked, including File::Slurp and the old do { local $/; <$handle> } trick.
use HTML::TreeBuilder;
my $filename = $ARGV[0];
my $tree = HTML::TreeBuilder->new_from_file($filename);
my $filename = $tree->look_down(
_tag => 'input',
type => 'hidden',
name => 'file1'
)->attr('value');
my $file_contents = $tree->look_down(_tag => 'pre')->as_trimmed_text;
print "filename: ",$filename,"file contents: ",$file_contents;
For information on look_down, attr, and as_trimmed_text, see the HTML::Element docs; HTML::TreeBuilder both is a, and works with, elements.
How would I write a Perl CGI script that receives a file via a HTTP post and saves that to the file system?
Use the CGI module.
my $fh = $query->upload('upload_field');
while(<$fh>) {
print SAVE_FILE $_;
}
Just a note: however you will write it, don't save it in a place accessible from your web-server.
And now to the point: below is a script which I was using for some time for photo-uploading. It might need some tweaking, but should show you the way.
As the image isnt uploaded to web-accesible directory, we then have separate process checking it, resizing, putting a watermark and placing it where it can be accessed.
#!/usr/bin/perl -wT
use strict;
use CGI;
use CGI::Carp qw ( fatalsToBrowser );
use File::Basename;
$CGI::POST_MAX = 1024 * 5000;
my $safe_filename_characters = "a-zA-Z0-9_.-";
my $upload_dir = "/home/www/upload";
my $query = new CGI;
my $filename = $query->param("photo");
my $email_address = $query->param("email_address");
if ( !$filename )
{
print $query->header ( );
print "There was a problem uploading your photo (try a smaller file).";
exit;
}
my ( $name, $path, $extension ) = fileparse ( $filename, '\..*' );
$filename = $name . $extension;
$filename =~ tr/ /_/;
$filename =~ s/[^$safe_filename_characters]//g;
if ( $filename =~ /^([$safe_filename_characters]+)$/ )
{
$filename = $1;
}
else
{
die "Filename contains invalid characters";
}
my $upload_filehandle = $query->upload("photo");
open ( UPLOADFILE, ">$upload_dir/$filename" ) or die "$!";
binmode UPLOADFILE;
while ( <$upload_filehandle> )
{
print UPLOADFILE;
}
close UPLOADFILE;
print $query->header ( );
print <<END_HTML;
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<title>Thanks!</title>
</head>
<body>
<p>Thanks for uploading your photo!</p>
</body>
</html>
END_HTML
See the CGI.pm documentation for file uploads.
I'd start by using CGI and reading CREATING A FILE UPLOAD FIELD, and using open to create a file and print to write to it. (and then close to close it).