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).
Related
I have this code
#!/usr/bin/perl
use warnings;
use strict;
my %map;
open my $MAP, '<', 'full_links' or die $!;
while (<$MAP>) {
my ($key, $value) = /comments\/(.*)\/(.*)\//;
$map{$key} = "$key/$value";
}
open my $IN, '<', 'html_links' or die $!;
open my $out, '>', "results" or die;
while (<$IN>) {
s/comments\/(.*)"/comments\/$map{$1}\/"/g;
print $out $_;
}
close $out;
that changes lines in html_links file
from title
to title
by looking at full_link file, that's filled with lines like this:
https://reddit.com/r/subreddit/comments/CODE/title_of_the_post/
But I feel like it looks a bit odd. Specifically the $map{$key} = "$key/$value"; part and it's further use in the replacement. I feels like doing just $map{$key} = $value should be sufficient, but I dont know how to utilize it to make the replacement that I need.
I'd do this with Mojo::DOM. Let it find all of the A tags then change what's in their HREF values:
#!perl
use v5.14;
use Mojo::DOM;
use Mojo::URL;
my $html = <<'HERE';
<html>
<body>
Some title
Leave alone
Other title
</body>
</html>
HERE
# Create the Document object model
my $dom = Mojo::DOM->new($html);
$dom
# find all the A tags in the HTML with CSS selectors
# The ^= matches just the HREFs that start with that text
->find( 'a[href^=https://reddit.com/]' )
->map( sub {
# take the slug from the text between the A opener and closer.
# replace whitespace (or whatever) with underscores
my $slug = lc($_->text) =~ s/\s+/_/gr;
# add the slug to the last part of the URL's path
my $url = Mojo::URL->new( $_->attr('href') );
push $url->path->parts->#*, $slug;
# give the HREF its new value
$_->attr('href', $url)
})
;
# The DOM now has the modified HTML
say $dom
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 am struck at this point since 1 day.
First am taking all file names .Then upload and collect all file handles.
Due to some reason, files are not uploading into /home/img folder correctly.
If uploaded, they are getting corrupted. Corrupted filesize shows as 0 bytes or 24 bytes.
Please provide assistance with upload part.
#!/usr/bin/perlml -Tw
use strict;
use CGI;
use CGI::Carp qw(fatalsToBrowser);
my $cgi = CGI->new;
my $upload_dir = "/home/img";
my #raw_filenames = $cgi->param('photos');
my $filename_characters = 'a-zA-Z0-9_.-';
my $ext = "";
my $raw_filenames = "";
my $raw_fh = "";
my $single_filename = "";
my $single_io_handle = "";
my #all_io_handle = "";
my #all_filenames = "";
print "Content-type: text/html\n\n";
#Getting the filenames ready
foreach $raw_filenames (#raw_filenames) {
( $single_filename, undef, $ext ) = fileparse( $raw_filenames, qr{\..*} );
push( #all_filenames, "$single_filename" );
}
#This prints the ready list of filenames
print "#all_filenames\n <br>";
#Getting the filehandles ready
my #raw_fh = $cgi->upload('photos');
foreach $raw_fh (#raw_fh) {
$single_io_handle = $raw_fh->handle;
push( #all_io_handle, "$single_io_handle" );
}
#This prints the ready list of filehandles
print "#all_io_handle\n <br>";
The following test of CGI->upload works with html input multiple attribute.
I attempt to view the file size of each uploaded file both by the temp file and by reading it from disk:
#!/usr/bin/env perl
use strict;
use warnings;
use CGI;
use CGI::Carp qw(fatalsToBrowser);
my $q = CGI->new();
my $msg = '';
if ( $q->request_method() eq 'POST' ) {
$msg .= '<table border=1 cellpadding=3 cellspacing=0><tr><th>File name</th><th>Temp size</th><th>Slurped size</th></tr>';
for my $file ( $q->upload('myfile') ) {
my $tempsize = -s $q->tmpFileName($file);
my $readsize = do {
my $fh = $file->handle();
binmode $fh;
local $/; # Slurp entire file
length <$fh>;
};
$msg .= '<tr><td>' . $q->escapeHTML($file) . "</td><td>$tempsize</td><td>$readsize</td></tr>";
}
$msg .= '</table>';
}
print $q->header;
print <<"END_HTML";
<html>
<head>
<title>Upload form using CGI</title>
</head>
<body>
<h1>Upload form using CGI</h1>
$msg
#{[ $q->start_form() ]}
<p><input type="file" name="myfile" accept="image/gif,image/jpeg,image/png" multiple required /></p>
<p><input type="submit" value="Upload"></p>
#{[ $q->end_form() ]}
</body>
</html>
END_HTML
Before Posting:
After Posting 3 images:
It's possible that you simple have an outdated version of CGI. Check the version
$ perl -MCGI -E 'say $CGI::VERSION'
4.04
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.
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().'-'.$$