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.
Related
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'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>
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().'-'.$$
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).