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
Related
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.
Hi I'm trying to upload a file using CGI and although the CGI script runs, the file that is created is empty.
I have a html file which gets the file name and passes it to a cgi script:
<html>
<body>
<form enctype="multipart/form-data" action="cgi-bin/upload.pl" method="POST">
<input type="FILE" name="file">
<input type="submit">
</form>
</body>
</html>
The cgi script is as follows:
#!/usr/bin/perl -w
use strict;
use CGI::Carp qw(fatalsToBrowser warningsToBrowser);
use CGI;
print "Content-type: text/html\n\n";
my $cgi = new CGI;
my $dir = 'sub';
my $name = $cgi->param('file');
print "name: $name <br />\n";
open(LOCAL, ">$dir/$name") or die "error: failed to open $dir/$name\n";
my $file_handle = $cgi->upload('file');
die "file_handle not defined\n" unless(defined($file_handle));
while(<$file_handle>) {
print $_;
print LOCAL $_;
}
close($file_handle);
close(LOCAL);
print "done\n";
The cgi script runs OK, produces no warnings, manages to create a local file and correctly gets the remote file name. However, the script appears not to read any data from the file or write any data into the local file which is empty.
I'm definitely uploading a file that contains multiple lines of data but the output of the cgi script is as follows:
name: tmp.txt
done
Any help greatly appreciated...
You might want to try using the binmode command on the FH.
Here's a Perl script that I use as a starting point for a CGI form that uploads files (displays the form and does the upload):
#!/usr/bin/perl
use strict;
use warnings;
use POSIX;
use CGI::Pretty qw(:standard -any -no_xhtml -oldstyle_urls *center);
use CGI::Carp qw(fatalsToBrowser set_message);
use Upload;
# Constants
my $FILE_DIR_INTERNAL = 'Z:\webroot\tmp';
# Variables
my $ACTION = param('action') || "";
if (! $ACTION) { UploadForm() }
elsif ($ACTION eq "UploadFile") {
my $file = UploadFile($FILE_DIR_INTERNAL, 1);
print "File uploaded to $file\n<pre>";
open(F, "$file");
while(<F>) { print }
close(F);
}
And here's the Perl module used by that script:
package Upload;
use strict;
use warnings;
use POSIX;
use File::Copy;
use CGI::Pretty qw(:standard -any -no_xhtml -oldstyle_urls *center);
use CGI::Carp qw(fatalsToBrowser); # supposed to echo STDERR to browser, too
use Exporter;
our $VERSION = do{ q$Revision: 1.5 $ =~ /(\d+)\.(\d*)([^ ]*)/; sprintf "%d.%02d%s", $1, $2, $3; };
our #ISA = qw(Exporter);
our #EXPORT = qw(UploadForm UploadFile);
my $FILE_UPLOAD_PARAM = "fileUploaded";
# *************************************************************************
# FUNCTION: UploadForm
# ARGUMENTS:
# RETURNS:
# NOTES: This subroutine displays the upload form.
# *************************************************************************
sub UploadForm {
print start_center;
print p("Upload a file from your computer:");
# Normally, I use the "get" method for forms (params show up in URL),
# but "post" is required for uploading files!
# Using "post" also requires that we pass parameters thru the hidden()
# commands down below, instead of in the URL.
print start_multipart_form({-method=>"post", -action=>script_name});
print filefield($FILE_UPLOAD_PARAM,"",50) . "\n";
# Hidden parameters are "sticky", so modify the existing "action" param,
# before trying to insert a new hidden "action" param.
# If you don't, CGI.pm will re-use the current "action" param.
param("action", "UploadFile");
print hidden("action") . "\n";
print p(submit("", "Upload File"));
print end_form;
print end_center;
}
# *************************************************************************
# FUNCTION: UploadFile
# ARGUMENTS:
# RETURNS:
# NOTES: This subroutine handles data "posted" thru the form
# created in UploadForm().
# *************************************************************************
sub UploadFile {
my $dir = shift || die "ERROR! No arg passed to UploadFile().\n";
my $overwrite = shift || 0;
my $TEMP_FH;
# The upload() function returns the filename and a file handle. See CGI.pm.
$_= $TEMP_FH = upload($FILE_UPLOAD_PARAM);
# What do all the regexes do? I wrote them, but I forgot. I think they
# strip off any path information (common in IE!) to get just the filename.
s/\w://;
s/([^\/\\]+)$//;
$_ = $1;
s/\.\.+//g;
s/\s+//g;
my $filename = $_;
my $serverFullFilename = "$dir/$filename";
if (! $filename) {
DisplayErrorPage("Illegal filename: '$filename'");
}
if ((! $overwrite) && (-e $serverFullFilename)) {
die "Unable to upload file. File '$filename' already exists.";
}
open(SERVER_FH,">$serverFullFilename") || die "Error opening $filename for writing.";
binmode SERVER_FH;
# Copy the file from the temp dir to the final location.
while (<$TEMP_FH>) {
print SERVER_FH;
}
close(SERVER_FH);
close($TEMP_FH);
if ((stat $serverFullFilename)[7] <= 0) {
unlink $serverFullFilename;
die "Unable to upload file '$filename'. This is usually due to the user specifying an invalid or unreadable file on the user's computer.";
}
return $serverFullFilename;
}
return 1;
Forgive any inconsistencies, as I had to cut out some site-specific stuff, but if I trimmed it all correctly, that should work "out of the box"
I'm trying to use a perl script to pull content from static html files on a server. I'd like to pull the content of a specific div. I know the div by its class name ("getme").
I can get to the div using HTML::TreeBuilder->look_down. How can I remove the div tag and get to just the content within it?
Example HTML
<body>
<div class="getme">
<h2>Some Header</h2>
<div class="another"><p>More text</p></div>
<div class="yetanother">text text text</div>
</div>
<div class="second">...</div>
</body>
Perl so far
use strict;
use warnings;
use HTML::TreeBuilder;
use HTML::TagFilter;
my $unique_filename = '/path/to/saved/files/extracted_divs/' . get_timestamp();
my $guid_counter = 0;
my $field_sep = "|";
open FILEOUT, ">>", $unique_filename or die $!;
print FILEOUT "guid|published|url|title|body\n";
foreach my $file_name (#ARGV) {
my $tree = HTML::TreeBuilder->new;
my $filter = HTML::TagFilter->new(deny => { div => {class => ["getme"]} });
$tree->parse_file($file_name);
for my $subtree ($tree->look_down(_tag => "div", class => "getme")) {
#my $html = $filter->filter($subtree->as_HTML);
my $html = $subtree->as_HTML;
#steamline HTML
$html =~ s/(?<!\n)\z/\n/;
#echo file name to screen so we know something is happening
print $file_name . "\n";
#replace slashes with spaces
my $file_url = $file_name;
$file_name =~ s/\//-/g;
#remove ".html"
$file_name =~ s/.html//g;
#echo info to output file
print FILEOUT $guid_counter++ . $field_sep . time . $field_sep;
print FILEOUT $file_url . $field_sep . $file_name . $field_sep;
print FILEOUT $html;
}
$tree = $tree->delete;
}
close (FILEOUT);
The filter just removes the class attribute. Can a rule be made to remove the whole tag, or is there a better approach to this?
use Web::Query qw();
join '', Web::Query->new_from_html($html)->find('.getme > *')->html
returns the string
<h2>Some Header</h2><div class="another"><p>More text</div><div class="yetanother">text text text</div>
Using Perl CGI, I am trying to create a login page with db connection. I am using the IDE eclipse. While running it I am getting the error:
Server Error
while trying to obtain /sssss/login.cgi
Missing header from cgi output
Here is my code:
#!/usr/bin/perl
use strict;
use CGI qw(:standard);
use CGI::Pretty qw(:all);
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use DBI;
use DBD::mysql;
use DBI qw(:sql_types);
use DBD::ODBC;
use CGI qw/:standard/;
use CGI;
my $cgi = CGI->new();
my $user='root';
my $pass='123';
my $dsn = 'DBI:mysql:delve:server';
my $dbh = &sql_connect;
$dbh-> {'LongTruncOk'} = 1;
$dbh-> {'LongReadLen'} = 90000;
print "Content-type: text/html\n\n";
print "<html><h1>OTT Login</h1></html>\n";
print '<body bgcolor="gray">';
#start a form----------------
print '<form method=POST>';
print '<p>';
print 'Employee Name: <p><INPUT type="text" name="User" size=25 maxlength=25></p>';
print '</p>';
# Create a text box for Password:---------------
print '<p>';
print 'Password:<p><INPUT TYPE=PASSWORD NAME="mypassword" id = "Password" size = "15" maxlength = "15" tabindex = "1"/></p>';
print '</p>';
#Create submit & reset button:-------------------
#print '<p><input type=" button" name="submitit"value="submit"onclick="formvalidation(myform)"/></p>';
print '<form name="input" method="post">';
print '<p><input type="submit" value="Submit" /><INPUT TYPE="reset" name = "Reset" value = "Reset"></p>';
#Create Change Password & Reset Password link:------------
print '<p>Change Password</p>';
print '<p>Reset Password</p>';
print '</form>';
#logic for submit button functionality :-----------------
if (param('User') and param('mypassword'))
{
my $usr=ucfirst(lc(param('User')));
my $pwd=ucfirst(lc(param('mypassword')));
my $query="select username from login where username='$usr'";
my $data=$dbh->prepare($query) or die $dbh->errstr;
$data->execute() or die $data->errstr;
my ($x,$y);
my $query1="select password from login where password='$pwd'";
my $data1=$dbh->prepare($query1) or die $dbh->errstr;
$data1->execute() or die $data->errstr;
if ($x=$data->fetchrow())
{
if ($y=$data1->fetchrow())
{
print "Correct Password";
print $cgi->redirect("samp.html");
}
else
{
print "Incorrect Password";
}
}
else
{
print "Invalid username";
}
$dbh->disconnect || die "$DBI::errstr\n";
}
sub sql_connect
{
Reconnect:
my $dbh = DBI->connect($dsn, $user, $pass,{AutoCommit => 1}) or warn "$DBI::errstr\a\a\n";
if(defined $dbh)
{
print "Data base Connected successfully\n";
}
else
{
print "Please Check Ur Database\n"; ### To handle Database Failure
sleep(10);
goto Reconnect;
}
return $dbh;
}
1;
Your subroutine sql_connect generates output (print "...") before the correct HTTP Header is sent.
Either print your debug messages to a logfile or first print the HTTP header before generating other content.
When you are sending an HTTP response (e.g. printing things to the browser), your application has to send the response header, and not just the body. As you're sending HTML, the very first thing you print to STDOUT should be a header that contains at least this:
Content-type: text/html
The header is followed by a blank line.
So the first print in your script should be:
print 'Content-type: text/html',"\n\n";
(If you have more headers to generate, then print only one \n after each until the last one.)
Of course, if you use CGI or CGI::Simple modules instead, you'll make your life a lot easier. CGI has lots of edge cases and weird behavior that's already been dealt with in these modules.