Further top this question: PDF::FromHTML - Corrupt file and no output
The code in question is 'working' in that it produces a PDF document just fine, just NONE of the HTML anchors are being translated, and on larger documents the processing ceases at Page 11 of the PDF - with no error, it closes the document just fine!
Edit: To save looking at the Question Link:
# print "<p>".$textblob."</p>";
$textblob='<html><head></head><body>'.$textblob.'</body></html>';
# $textblob = decode('UTF-8', $textblob);
my $output;
if(defined($query->param('PDF'))){
my $pdf = PDF::FromHTML->new( encoding => 'utf-8' );
$pdf->load_file(\$textblob);
$pdf->convert(
# With PDF::API2, font names such as 'traditional' also works
Font => 'Arial',
LineHeight => 10,
Landscape => 0,
);
$pdf->write_file(\$output);
print $output;
}
$textblob when uncommented to print and commenting out the PDF section displays the full 400 reference adventure with links in html just fine...
Update:In desperation here is the entire script (it's not TOO long...)
#!/usr/bin/perl
use cPanelUserConfig;
use CGI::Carp qw(fatalsToBrowser);
use CGI;
use List::Util qw(shuffle);
use PDF::FromHTML;
require "authenticate.pl";
$query = new CGI;
if(defined($query->param('PDF'))){
print $query->header(-type=>'application/pdf');
}
else{
print $query->header(-charset=>'utf-8');
&html_header;
print "\n\n\n\n<!-- -------------------------- BEGIN: ff.net Script generated text ------------------------------------------- -->";
print "Randomise working? Let me know if you find a bug.<br />";
}
if(defined($query->param('doc'))){
$doc=$query->param('doc')."\nEOF";
%refhash = $doc =~ /^[\n\s\t\.\#]*(\d+)[\s\t\.\#\n]+(?!\n*^[\n\s\t\.\#]*\d+[\s\t\.\#\n]+)(.+?)(?=^[\s\t\.\#\n]*\d+[\s\t\.\#\n]+|EOF)/smcgi; # refhash{key}=content, where key==refnumber and content==well, ref content
&display_refhash(\%refhash);
}
elsif(defined($query->param('references'))){
my %anchors;
my $refhashref=&recreate_refhash($query->param('references'),\%anchors);
if(defined($query->param('Randomise'))){
$refhashref=&randomise($refhashref,\%anchors);
print "Your adventure looks like this: <br /><br />";
&display_refhash($refhashref);
}
elsif(defined($query->param('Save'))){
&save($refhashref);
}
elsif(defined($query->param('Auto-HTML Tag'))){
print "Your adventure looks like this: <br /><br />";
&display_refhash($refhashref);
}
elsif(defined($query->param('Auto-ABML Tag'))){
&autoABML($refhashref);
print "Your adventure looks like this: <br /><br />";
&display_refhash($refhashref);
}
elsif(defined($query->param('PDF'))){
&output_pdf($refhashref);
}
else{
print "undefined function call";
}
}
else{ # output form to input doc content
print "Please input your document text into the textarea below (copy and paste should do it):";
print '<form method="post" action="doc_to_refs.cgi" enctype="multipart/form-data" name="doc_to_refs_form">';
print $query->textarea(-name=>'doc',-rows=>20,-cols=>100, -style=>"font-family:arial;width:98%");
print $query->submit('Go!');
print '</form>';
}
&html_footer;
# print "<!-- -------------------------- END: ff.net Script generated text ------------------------------------------- -->";
sub recreate_refhash{
my %refhash;
my $references=shift;
my $anchors_ref=shift;
for(my $x=0;$x<$references;$x++){
my $referencekey="reference"."$x";
my $referencecontent="reftext"."$x";
my $anchorname="anchor"."$x";
my $deletename="delete"."$x";
if(!defined($query->param($deletename))){
$refhash{$query->param($referencekey)}=$query->param($referencecontent);
if(defined($query->param($anchorname))){
$$anchors_ref{$query->param($anchorname)}=$x;
}
}
}
return \%refhash;
}
sub randomise{
my $refhashref=shift;
my $anchor_ref=shift;
my %refhash=%$refhashref;
my %randomisedrefhash, %Xrefhash, #refstack, $ref;
my %anchors=%$anchor_ref;
# randomise the list
#refstack=shuffle sort {$a <=> $b} keys %refhash; # inflict an order on the pre-shuffle (therefore we can xref predicatably?) not sure this makes ANY sense i'm melting....
## transpose anchors back to their required location
for($x=0;$x<#refstack;$x++){
if(defined($anchors{$refstack[$x]})){
my $anchor=\$refstack[$anchors{$refstack[$x]}];
my $temp=$refstack[$x];
$refstack[$x]=$$anchor;
print "---Swapping $temp with ".$$anchor;
$$anchor=$temp;
if(defined($anchors{$refstack[$x]})){
if($refstack[$anchors{$refstack[$x]}] ne $$anchor){
$x--;
}
}
}
}
## randomise the refs and the content associations, and create the cross-ref hash
foreach $ref(sort {$a <=> $b} keys %refhash){
$key=shift #refstack;
$randomisedrefhash{$ref}=$refhash{$key};
$Xrefhash{$key}=$ref;
}
## now do the content link substitutions
foreach $ref(keys %randomisedrefhash){
$randomisedrefhash{$ref}=~s/(return\sto|go\sto|turn\sto)(\s+)(page|paragraph|reference|section)*(\s)*(\d+)/&substitute_xref($1,$2,$3,$4,$5,\%Xrefhash)/egi;
}
print "You asked for the following anchors:";
foreach $key(keys %anchors){
print $anchors{$key};
}
return \%randomisedrefhash;
}
sub substitute_xref{ ## not sure that this is necessary but the verboseness was easier to work out
my $pretext1=shift;
my $pretext2=shift;
my $pretext3=shift;
my $pretext4=shift;
my $link=shift;
my $Xrefhashref=shift;
my %Xrefhash=%$Xrefhashref;
my $newlink=$Xrefhash{$link};
return "$pretext1$pretext2$pretext3$pretext4$newlink";
}
sub save{
print "Will Save soon";
}
sub display_refhash{
my $refhashref=shift;
my %refhash=%$refhashref;
print '<form method="post" action="doc_to_refs.cgi" enctype="multipart/form-data" name="doc_to_refs_form">';
my $x=0;
my $ref,$textblob;
foreach $ref (sort {$a <=> $b} keys %refhash){
my $reference="reference"."$x";
my $reftext="reftext"."$x";
my $anchor="anchor"."$x";
my $delete="delete"."$x";
my $default=$refhash{$ref};
print "Reference is: ".$query->textfield(-name=>$reference,-value=>$ref, -override=>1)."<br />";
print $query->checkbox_group(-name=>$delete,-values=>$ref,-labels=>{$ref=>'Delete Me'})."<br />";
print $query->checkbox_group(-name=>$anchor,-values=>$ref, -labels=>{$ref=>'Anchor Me (Will NOT get Randomised)'})."<br />";
print "Content is: ".$query->textarea(-name=>$reftext, -default=>$default, -rows=>5, -override=>1, -cols=>100, -style=>"font-family:arial;width:98%")."<br />";
print "<br /><br />";
if((defined($query->param('Auto-HTML Tag'))) or (defined($query->param('PDF')))){
$ref=~s/(\d+)/\<a id\=\"$1\"\>$1\<\/a\>/gi;
$default=~s/(return\sto|go\sto|turn\sto)(\s+)(page|paragraph|reference|section)*(\s*)(\d+)/\<a href\=\"\#$5\"\>$1 $2 $3 $4 $5\<\/a\>/gi;
}
if(defined($query->param('Auto-ABML Tag'))){
# $ref=~s/(\d+)/\<a id\=\"$1\"\>$1\<\/a\>/gi;
$default=~s/(return\sto|go\sto|turn\sto)(\s+)(page|paragraph|reference|section)*(\s*)(\d+)/\<\;tt ref\=\"$5\"\>\;$1 $2 $3 $4 $5\<\;\/tt\>\;/gi;
}
$textblob.=$ref." ".$default."<br /><br />";
$x++;
}
print $query->hidden(-name=>'references',-value=>$x,override=>1);
# print $query->submit(-name=>'Save');
print $query->submit('Randomise');
print $query->submit('Auto-ABML Tag');
print $query->submit('Auto-HTML Tag');
print $query->submit('PDF');
print "</form><br /><br /><br />";
$textblob=~s/\n/\<br \/\>/gi;
print "<p>".$textblob."</p>";
}
sub output_pdf{
my $refhashref=shift;
my %refhash=%$refhashref;
my $x=0;
my $ref,$textblob;
foreach $ref (sort {$a <=> $b} keys %refhash){
my $reference="reference"."$x";
my $reftext="reftext"."$x";
my $anchor="anchor"."$x";
my $delete="delete"."$x";
my $default=$refhash{$ref};
if((defined($query->param('Auto-HTML Tag'))) or (defined($query->param('PDF')))){
$ref=~s/(\d+)/\<a id\=\"$1\"\>$1\<\/a\>/gi;
$default=~s/(return\sto|go\sto|turn\sto)(\s+)(page|paragraph|reference|section)*(\s*)(\d+)/\<a href\=\"\#$5\"\>$1 $2 $3 $4 $5\<\/a\>/gi;
}
if(defined($query->param('Auto-ABML Tag'))){
# $ref=~s/(\d+)/\<a id\=\"$1\"\>$1\<\/a\>/gi;
$default=~s/(return\sto|go\sto|turn\sto)(\s+)(page|paragraph|reference|section)*(\s*)(\d+)/\<\;tt ref\=\"$5\"\>\;$1 $2 $3 $4 $5\<\;\/tt\>\;/gi;
}
$textblob.=$ref." ".$default."<br /><br />";
$x++;
}
$textblob=~s/\n/\<br \/\>/gi;
# print "<p>".$textblob."</p>";
$textblob='<html><head></head><body>'.$textblob.'</body></html>';
my $output;
if(defined($query->param('PDF'))){
my $pdf = PDF::FromHTML->new( encoding => 'utf-8' );
$pdf->load_file(\$textblob);
$pdf->convert(
# With PDF::API2, font names such as 'traditional' also works
Font => 'Arial',
LineHeight => 10,
Landscape => 0,
);
$pdf->write_file(\$output);
print $output;
}
}
sub html_header{
}
sub html_footer{
}
If you want sample data let me know I'll upload it somewhere
"... and on larger documents the processing ceases at Page 11 of the PDF..."
This seems to be due to a bug in PDF::FromHTML::Template::Container::PageDef. Notice the line:
last if $::x++ > 10;
It means it will never create more than 11 pages. I have filed a bug report
Related
I have some data stored in an array of hashes, and I am trying to print the results onto the body of the email being sent. Results will print on the command line when the script is ran, however the body of the email will remain blank.
sub DailyInflow {
my #inflow = SQLTableHash("select count(FOO), count(BAR), BAZ from table1 where days in (0,1) group by BAZ", $reportdbh);
foreach my $inflow (#inflow) {
print $inflow->{"BAZ"} . ": " . $inflow->{"COUNT(FOO)"}."\n";
print "Total: " . $inflow->{"COUNT(BAR)"} . "\n";
}
}
################### Send E-mail with CSV Attachment ##################
print "Sending Email ... \n" if $ENV{DEBUG};
my $subject = "Snapshot $reportdate";
SendEmail({
FROM => 'user#email.com',
TO => $args{EMAIL},
SUBJECT => $subject,
BODY =>DailyInflow()
ATTACHFILES => [{
Type => 'BINARY',
Path => "$fullzipname",
Disposition => 'attachment',
Filename => "$zipname",
}],
});
Your DailyInflow() subroutine should look like this:
sub DailyInflow {
my #inflow = SQLTableHash("select count(FOO), count(BAR), BAZ from table1 where days in (0,1) group by BAZ", $reportdbh);
my $string;
foreach my $inflow (#inflow) {
$string .= $inflow->{"BAZ"} . ": " . $inflow->{"COUNT(FOO)"}."\n";
$string .= print "Total: " . $inflow->{"COUNT(BAR)"} . "\n";
}
return $string;
}
But you can simplify it by interpolating variables within double-quoted strings.
sub DailyInflow {
my #inflow = SQLTableHash("select count(FOO), count(BAR), BAZ from table1 where days in (0,1) group by BAZ", $reportdbh);
my $string;
foreach my $inflow (#inflow) {
$string .= "$inflow->{'BAZ}: $inflow->{'COUNT(FOO)'}\n";
$string .= "Total: $inflow->{'COUNT(BAR)'}\n";
}
return $string;
}
I'm trying to analyze a CGI file written in Perl. I know that a variable declared in file A that uses/requires file B is available in file B as long as it's global. But please take a look at this piece of code:
sub makeoper {
%attr = (
PrintError => 0,
RaiseError => 0
);
$dbh=DBI->connect($configs{db_source},$configs{db_user},$configs{db_passw},\%attr) or die "Can not connect to database: $DBI::errstr!\n";
if ($fetched{submit} eq 'start' and !$fetched{savefr} )
{$fetched{savefr}=&get_time_fromdb;
$fetched{saveto}='';
system "mv pool/*.txt pool/arc/";
}
#some more else ifs
$dbh->disconnect or die "Database connection not made: $DBI::errstr";
}
Where is this $fetched variable taken from? The $configs avriable, for instance, comes from a config file. I've searched all the files in the directory there's no $fetchedanywhere. Is it some kind of implicit variable when fetching data? If not, then where else should I look?
Just in case, I'm posting the whole code.
#!/usr/bin/perl -w
use DBI;
#$ENV { "ORACLE_HOME" } = "/d01/conf/oracle/product/924";
sub printPage(){
&parse_form || exit;
print "Content-type: text/html\n\n";
&makeoper;
#&makeoper;
print "<html><head></head>
<body>
<h3>$configs{servicename}</h3>
<form action='$ENV{REQUEST_URI}' method='post'>
<table align='center' width='96%' border='1'>
<tr>
<td width='50%' align='left' valign='top'>
Online-cutting <br><br>
<input type=hidden name='savefr' value='$fetched{savefr}'>$fetched{savefr}
-
<input type=hidden name='saveto' value='$fetched{saveto}'>$fetched{saveto}
<br>
<input type=submit name='submit' value='start'>
<input type=submit name='submit' value='cut'>
<input type=submit name='submit' value='stop'>
</td>
<td align='left' valign='top' bgcolor='\#eeeeee'>
Take history <br>
<small>
(times in format: YYYY-MM-DD HH:MI:SS<br>
or YYYY-MM-DD HH:MI<br>
or YYYY-MM-DD )<br>
example: 2004-08-22 17:13:04<br>
2004-08-22 17:13<br>
2004-08-22<br>
</small>
<input type=text size=20 name='histfr' value='$fetched{histfr}'>
-
<input type=text size=20 name='histto' value='$fetched{histto}'><br>
<input type=submit name='submit' value='history'>
</td>
</tr>
</table>
</form>
<br><br>
";
&print_filepool;
print "</body></html>";
exit;
}
sub makeoper {
# $error="pingvin";
%attr = (
PrintError => 0,
RaiseError => 0
);
$dbh=DBI->connect($configs{db_source},$configs{db_user},$configs{db_passw},\%attr) or die "Can not connect to database: $DBI::errstr!\n";
#print DBI->
#die "Cannot connect to DB!" if (!defined $dbh);
if ($fetched{submit} eq 'start' and !$fetched{savefr} )
{$fetched{savefr}=&get_time_fromdb;
$fetched{saveto}='';
system "mv pool/*.txt pool/arc/";
}
elsif ($fetched{submit} eq 'cut' and $fetched{savefr} )
{$fetched{saveto}=&get_time_fromdb;
&dumptofile($fetched{savefr},$fetched{saveto});
$fetched{savefr}=$fetched{saveto};
$fetched{saveto}='';
}
elsif ($fetched{submit} eq 'stop' and $fetched{savefr} )
{$fetched{saveto}=&get_time_fromdb;
&dumptofile($fetched{savefr},$fetched{saveto});
$fetched{savefr}='';
$fetched{saveto}='';
}
elsif ($fetched{submit} eq 'history')
{
system "mv pool/*.txt pool/arc/";
&normalize_times($fetched{histfr},$fetched{histto});
&humanize_times($fetched{histfr},$fetched{histto});
&dumptofile($fetched{histfr},$fetched{histto});
}
$dbh->disconnect or die "Database connection not made: $DBI::errstr";
}
sub get_time_fromdb {
$sth=$dbh->prepare("select to_char(sysdate,'YYYY-MM-DD HH24:MI:SS') from dual ");
$sth->execute();
$row=$sth->fetchrow_arrayref;
$sth->finish;
return $row->[0];
}
sub dumptofile { #pass savefr,saveto
my ($savefr,$saveto)=#_;
$sth=$dbh->prepare("SELECT * FROM $configs{dbtable}
WHERE (mess_dir='I' OR mess_dir='A' OR mess_dir='R') "
.($configs{nums_filter}
? " and b_num in $configs{nums_filter} "
: ''
)
." and in_date>to_date(?,'YYYY-MM-DD HH24:MI:SS')
and in_date<to_date(?,'YYYY-MM-DD HH24:MI:SS')
ORDER BY b_num, in_date
");
$sth->execute($savefr,$saveto);
$destnum = "";
if ($configs{nums_div})
{open OFI,">pool/$savefr - $saveto - mark.txt";
close OFI;
while ($row=$sth->fetchrow_arrayref)
{if ($row->[2] ne $destnum)
{$destnum=$row->[2];
open OFI,">pool/$savefr - $saveto - $destnum.txt";
}
$row->[3]=~s/[\r\n]/ /mg;
print OFI join("\t",#$row),"\n";
}
}
else
{open OFI,">pool/$savefr - $saveto.txt";
while ($row=$sth->fetchrow_arrayref)
{print OFI join("\t",#$row),"\n";}
}
close OFI;
$sth->finish;
}
sub print_filepool {
opendir IDI,'pool/';
foreach $afile (sort { $b cmp $a } readdir IDI)
{if ($afile=~/txt\Z/)
{print "<a target='_blank' href='$configs{pathtopool}/$afile'>";
print `wc -l \'pool/$afile\'`;
print "</a><br>\n";
};
};
closedir IDI;
print "<br><a target='_blank' href='list.cgi?arc'>ARC</a><br>\n";
}
sub parse_form { #sets %fetched=('name0'=>'content0',..)
if ($ENV{'CONTENT_LENGTH'}>$configs{'universal_maxinfosize_totake'}) {return 0;};
read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'});
if (length($buffer)<5) {$buffer=$ENV{QUERY_STRING};};
#pairs=split(/&/,$buffer);
foreach $pair (#pairs)
{local($name,$value)=split(/=/, $pair);
$name =~tr/+/ /;
$name =~s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~tr/+/ /;
$value =~s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~s/[<>\n\r|`]/ /mg;
if ($fetched{$name} eq '') {$fetched{$name}=$value;}
else {$fetched{$name}.="\a$value";};
}
return 1;
}
sub normalize_times { #pass fr_time, to_time
$_[0]=~s/\D+//sg;
$_[1]=~s/\D+//sg;
$_[0].='000000' if ($_[0]=~m/^\d{8}$/);
$_[1].='235959' if ($_[1]=~m/^\d{8}$/);
$_[0].='00' if ($_[0]=~m/^\d{12}$/);
$_[1].='59' if ($_[1]=~m/^\d{12}$/);
$_[1]='' if ($_[1]!~m/^\d{14}$/);
}
sub humanize_times { #pass fr_time, to_time
$_[0]=substr($_[0],0,4)."-".substr($_[0],4,2)."-".substr($_[0],6,2)
." ".substr($_[0],8,2).":".substr($_[0],10,2).":".substr($_[0],12,2);
$_[1]=substr($_[1],0,4)."-".substr($_[1],4,2)."-".substr($_[1],6,2)
." ".substr($_[1],8,2).":".substr($_[1],10,2).":".substr($_[1],12,2);
}
Perl is seeing that you are using a variable named %fetched so it just goes ahead and creates one for you. This is behavior that is a hold over from the early days of Perl.
You should use strict; at the top of your file, and then declare my %fetched; near the top, since it is being used as a global variable.
Compare:
perl -e '$foo{bar}=42; print $foo{bar} . "\n";'
42
perl -e 'use strict; $foo{bar}=42; print $foo{bar} . "\n";'
Global symbol "%foo" requires explicit package name at -e line 1.
Execution of -e aborted due to compilation errors.
perldoc strict
That's the problem you face when you don't use use strict; use warnings; in your program.
fetched is a hash which is probably containing your form data.
Also see: Autovivification in Perl
how can i cache errors in perl? Is there try/cache like in JS? I would like if any error occurs to go to the start of the script.
And if anyone has an idea of improvement for the script below let me know because this is my first one in perl. The script just has to loop forever and never stop. :)
#!/usr/bin/perl
use strict;
use warnings;
use LWP::UserAgent;
use JSON;
use HTTP::Request::Common qw(POST GET);
use Encode qw(encode);
use DBI;
use Time::Piece;
# Beware: we disable the SSL certificate check for this script.
$ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}=0;
# Debugging: off=0, medium=3, extensive=5
my $debuglevel=0;
my ($host,$username,$password)=('192.168.xxx.xxx','xxxx','xxxx');
# Define cms api key and nodeid.
my ($cmsapi,$cmsnode)=('xxxxxxxxx','1');
# Define all parameters to be logged each script's iteration.
# #parameterlist[x][$parameterid,$parameterlongtext,$parametershorttext,$data]
# which corresponds for FHEM's DbLog with:
# #parameterlist[x][$parameterid,$parameterlongtext,READING ,VALUE]
# $parameterlist[x][3] will be populated by the script, thus here undefined in each line (the last value is missing).
my #parameterlist=(
[3922,"Status TC","statusHeatPump"],
[3931,"Zunanja temperatura","outsideTemperature"],
[3924,"Status zalogovnika","statusBuffer"],
[3925,"Status bojlerja","statusBoiler"],
[3940,"Temperatura bojlerja","boilerTemperature"],
[3943,"Temperatura zalogovnika","bufferTemperature"],
[4331,"Temperatura nadstropja","floorTemperature"],
[3811,"Temperatura pritličja","groundTemperature"],
);
# We substitute the text for the burner's status with an integer, so plots are easier.
# Define which parameter holds the burner's status.
my $parameterstatusHeatPump=3922;
my #statusHeatPumpmatrix=(
["Off",0],
["Heating mode",50],
);
sub trim() {
my $str = $_[0];
$str =~ s/^\s+|\s+$//g;
return $str;
};
print "DEBUG: *** Script starting ***\n" if($debuglevel>0);
while (1) {
sleep 1;
my $ua=LWP::UserAgent->new;
my $request=HTTP::Request->new(GET=>'https://'.$host.'/api/auth/login.json?user='.$username.'&pwd='.$password);
my $response=$ua->request($request);
my $decoded=decode_json($response->decoded_content( charset => 'none'));
my $success=$decoded->{'Result'}{'Success'};
my $sessionid=$decoded->{'SessionId'};
print "DEBUG: ".$response->content."\n" if($debuglevel>4);
print "DEBUG: ".$success."\n" if($debuglevel>4);
my $i=0;
my $j=0;
my $parameterid;
my $dataValue;
my $rightnow;
my $data = "empty";
while (defined($parameterlist[$i][0])) {
$parameterid=$parameterlist[$i][0];
$request=HTTP::Request->new(GET=>'https://'.$host.'/api/menutree/read_datapoint.json?SessionId='.$sessionid.'&Id='.$parameterid);
$response=$ua->request($request);
$decoded=JSON->new->utf8->decode($response->decoded_content( charset => 'none'));
$success=$decoded->{'Result'}{'Success'};
$dataValue=encode('UTF-8', $decoded->{'Data'}{'Value'});
$parameterlist[$i][3]=&trim($dataValue);
if ($parameterlist[$i][0]==$parameterstatusHeatPump) {
$j=0;
while (defined($statusHeatPumpmatrix[$j][0])) {
if ($statusHeatPumpmatrix[$j][0] eq $parameterlist[$i][3]) {
$parameterlist[$i][3]=$statusHeatPumpmatrix[$j][1];
print "DEBUG: Substituting text of HeatPump\n" if($debuglevel>0);
};
$j++;
}
}
print "DEBUG: ".$response->content."\n" if($debuglevel>4);
print "DEBUG: ".$success."\n" if($debuglevel>4);
print "DEBUG: ".$parameterlist[$i][1]."=".$dataValue."\n" if($debuglevel>0);
$rightnow=localtime->strftime('%Y-%m-%d %H:%M:%S');
if ($data eq "empty"){
$data = $parameterlist[$i][2].':'.$parameterlist[$i][3];
}
else{
$data = $parameterlist[$i][2].':'.$parameterlist[$i][3].','.$data;
}
$i++;
}
print "JSON data = ".$data."\n" if($debuglevel>0);;
#Post data
my $req=HTTP::Request->new(POST=>'http://cms.org/input/post.json?apikey='.$cmsapi.'&node='.$cmsnode.'&json={'.$data.'}');
my $resp = $ua->request($req);
if ($resp->is_success) {
my $message = $resp->decoded_content;
print "Received reply: $message\n" if($debuglevel>0);
}
else {
print "HTTP POST error code: ", $resp->code, "\n" if($debuglevel>0);
print "HTTP POST error message: ", $resp->message, "\n" if($debuglevel>0);
}
}
print "DEBUG: *** Script ended ***\n\n" if($debuglevel>0);
I am answering the specific:
Is there try/cache like in JS?
Yes there is. Instead of
try {
possible evil code;
} catch (e) {
...
}
in perl you write
eval {
possible evil code;
};
if ($#) {
...
}
where $# is the message with which youre code died. BTW - don't vorget the ';' after the eval code.
HTH
Georg
In Perl you can use eval,
For Perl Script:
eval {
your code statement;
}
if($#){
print qq{Error: $#};
}
For CGI file use like below if you want to print the error:
eval {
your code statement || die "Error: $!";
}
if($#){
print qq{Error: $#};
}
I'm working on a dispatching script. It takes a string with a command, does some cooking to it, and then parses it. But I can't grab a hold into the referencing:
Use::strict;
Use:warnings;
my($contexto, $cmd, $target, $ultpos, #params);
my $do = "echo5 sample string that says stuff ";
$target = "";
$cmd = "";
$_ = "";
# I do some cumbersome string parsing to get the array with
# the exploded string and then call parsear(#command)
sub parsear {
my %operations = (
'echo' => \&echo,
'status' => \&status,
'echo5' => \&echo5,
);
my $op = $_[0];
if ($operations{$op}){
$operations{$op}->(#_);
print "it exists\n";
}
else{
print "incorrect command.\n";
}
}
sub status {
print "correct status.\n";
}
sub echo {
shift(#_);
print join(' ',#_) . "\n";
}
sub echo5 {
shift(#_);
print join(' ',#_) . "\n" x 5;
}
I don't really know what the problem is. If the sub does not exist, it never says "incorrect command", and if I call for example "echo5 hello" it should print out:
hello
hello
hello
hello
hello
But it does nothing.
And when I call echo, it works as expected. What is the explanation?
Note: I'm on the latest version of Strawberry Perl
use strict; # 'use' is a keyword
use warnings;
# All these variables are not needed
sub parsear { # Learn to indent correctly
my %operations = (
'echo' => \&echo,
'status' => \&status,
'echo5' => \&echo5,
);
my $op = shift; # take first element off #_
if ($operations{$op}) {
print "$op exists\n"; # Make your status message useful
$operations{$op}->(#_);
} else {
print "incorrect command: $op\n"; # And your error message
}
}
sub status {
print "correct status.\n";
}
sub echo {
# shift(#_); # This is no longer needed, and now echo can be used as a
# normal subroutine as well as a dispatch target
print join(' ',#_) . "\n";
}
sub echo5 {
# shift(#_); # This is no longer needed
print +(join(' ',#_) . "\n") x 5; # Parentheses are needed since x binds tightly
}
Then running:
parsear 'status';
parsear 'echo', 'hello';
parsear 'echo5', 'hello';
parsear 'an error';
results in:
status exists
correct status.
echo exists
hello
echo5 exists
hello
hello
hello
hello
hello
incorrect command: an error
I am not sure what "cumbersome string parsing" you are doing since you did not include it, but if you are parsing a string like
my $do = "echo5 sample string that says stuff ";
where the command is the first word, and the arguments are the rest, you can either split everything:
parsear split /\s+/, $do;
Or use a regex to cut the first word off:
my ($cmd, $arg) = $do =~ /^(\w+)\s*(.*)/;
parsear $cmd => $arg;
You don’t even need the variables:
parsear $do =~ /^(\w+)\s*(.*)/;
Finally, the echo5 subroutine is a bit more complicated than it needs to be. It could be written as:
sub echo5 {
print "#_\n" x 5; # "#_" means join($", #_) and $" defaults to ' '
}
The x command binds differently from how you were expecting; you probably wanted:
print ((join(' ', #_) . "\n") x 5);
Both extra sets of parentheses seemed to be necessary.
Hello everybody i hope everybody is doin well,
Actually i have a table in which i fetch the data from sqlite database,i have done the paging and filtering for the grid using perl,now i need to do the sorting.
The way in which i want to do is "MAKE THE TABLE HEADERS AS HYPERLINK AND WHENEVER I CLICK THEM THEN IT SHOULD SORT THE TABLE IN ASCENDING OR DESCENDING "ORDER BY" THE COLUMN WHICH I CLICK.
Please do let me know is it possible, if yes then please do guide me find the solution.
HERE'S My Code. Thank You.
#!C:\perl\bin\perl.exe
use CGI;
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
use strict;
use warnings;
use DBI;
use POSIX;
my $query = new CGI;
my $q = new CGI;
my $numofPages;
my $i;
my #overduedata;
my $pageN;
my #rows = ();
my $pageNum=$query->param('pageNum');
my $Id="";
my $Name="";
my #list;
my $var;
my $val;
my $filterexpression= " ";
print "Content-Type: text/html\n\n";
$query = $ENV{'QUERY_STRING'};
#list = split( /\&/, $query);
foreach (#list) {
($var, $val) = split(/=/);
$val =~ s/\'//g;
$val =~ s/\+/ /g;
$val =~ s/%(\w\w)/sprintf("%c", hex($1))/ge;
($var, ' = ', $val,);
}
print <<END_HTML;
<html>
<head><title></title>
</head>
<body>
<form action="Filtering.cgi" method="post">
<TABLE>
<TR>
<TD>
<input type="hidden" name="submit" value="Submit">
</TD>
</TR>
</TABLE
</form>
</body></html>
END_HTML
my $dbh = DBI->connect("dbi:SQLite:DEVICE.db","", "",
{
RaiseError => 1,
AutoCommit => 1
}
);
unless($pageNum) {
$pageNum=0;
}
my $offset;
unless($offset) {
$offset=11;
}
if ( $q->param("Filter") )
{
my $Id=$q->param('User_Id');
my $Name=$q->param('User_Name');
if ($Id ne "" )
{
$filterexpression= $filterexpression." UserId like '" .$Id. "%' and " ;
}
if ($Name ne "" )
{
$filterexpression= $filterexpression." UserName like '" .$Name. "%' and " ;
}
}
$filterexpression= $filterexpression. " UserId > 0" ;
my $exp;
my $query =$dbh->selectall_arrayref("SELECT * FROM UsersList " ." where ".
$filterexpression);
my $numOfRec=#$query ;
my $numofPages = ceil($numOfRec / $offset);
my $sql = "SELECT UserId,UserName,CardNo,GroupId,Role,VerifyType FROM UsersList " ."
where ". $filterexpression;
my $sth = $dbh->prepare($sql) or die("\n\nPREPARE ERROR:\n\n$DBI::errstr");
$sth->execute or die("\n\nQUERY ERROR:\n\n$DBI::errstr");
my $query=$dbh->selectall_arrayref('SELECT
UserId,UserName,CardNo,GroupId,Role,VerifyType FROM UsersList where '.
$filterexpression);
my $exp = #$query;
while (my ($UserId,$UserName,$CardNo,$GroupId,$Role,$VerifyType) = $sth-
>fetchrow_array())
{
push(#overduedata,{UserId=>$UserId,UserName=>$UserName,
CardNo=>$CardNo,GroupId=>$GroupId,Role=>$Role,VerifyType=>$VerifyType});
}
my $startDisplay = ($pageNum)*$offset;
my $endDisplay = ($pageNum + 1 ) * $offset;
$i = $startDisplay;
my $sql = "SELECT UserId,UserName,CardNo,GroupId,Role,VerifyType FROM UsersList" ;
my $sth = $dbh->prepare($sql) or die("\n\nPREPARE ERROR:\n\n$DBI::errstr");
$sth->execute or die("\n\nQUERY ERROR:\n\n$DBI::errstr");
print "<table class=\"tablestyle\">";
print "<tr border=1 style='background-color:#CDC9C9'>
<td class=\"tdstyle\" colspan=\"2\"></td>
<td>ADD</td>
<td><b>UserId</b></td>
<td><input type=\"text\" name=\"User_Id\" size=\"6\"></td>
<td><b>UserName</b></td>
<td><input type=\"text\" name=\"User_Name\" size=\"10\"></td>
<td><input type=\"submit\" name=\"Filter\" value=\"Filter\" ></td>
</tr>";
print "<tr class=\"trstyle1\"></tr>";
print "<tr class=\"trstyle2\">";
print "<th class=\"thstyle\"><A HREF=\"http://localhost/cgi-bin/Filtering.cgi?
Sortype=1\" class=\"hiddenlink\">$sth->{NAME}->[0]</A></th>";
print "<th colspan=\"2\" class=\"thstyle\">A HREF=\"http://localhost/cgi-
bin/Filtering.cgi?Sortype=2\" class=\"hiddenlink\">$sth->{NAME}->[1]</A></th>";
print "<th class=\"thstyle\"><A HREF=\"http://localhost/cgi-bin/Filtering.cgi?
Sortype=3\" class=\"hiddenlink\">$sth->{NAME}->[2]</A></th>";
print "<th class=\"thstyle\"><A HREF=\"http://localhost/cgi-bin/Filtering.cgi?
Sortype=4\" class=\"hiddenlink\">$sth->{NAME}->[3]</A></th>";
print "<th class=\"thstyle\"><A HREF=\"http://localhost/cgi-bin/Filtering.cgi?
Sortype=5\" class=\"hiddenlink\">$sth->{NAME}->[4]</A></th>";
print "<th class=\"thstyle\"><A HREF=\"http://localhost/cgi-bin/Filtering.cgi?
Sortype=6\" class=\"hiddenlink\">$sth->{NAME}->[5]</A></th>";
print "<th class=\"thstyle\"> EDIT</th>";
print "<th class=\"thstyle\"> DELETE</th>";
print "</tr>";
if($exp != 0)
{
while ($i < $endDisplay)
{
if($i == $exp){
last;}
print "<tr class=\"trstyle3\">
<td >" . $overduedata[$i]->{'UserId'} . "</td>
<td colspan=\"2\" >" . $overduedata[$i]->{'UserName'} . "</td>
<td>" . $overduedata[$i]->{'CardNo'} . "</td>
<td>" . $overduedata[$i]->{'GroupId'} . "</td>
<td>" . $overduedata[$i]->{'Role'} . "</td>
<td>" . $overduedata[$i]->{'VerifyType'} . "</td>
<td>EDIT</td>
<td>DELETE</td>
</tr>";
$i = $i + 1;
}
}
if ( $pageNum > 0 ) {
print q[<td>|<</td>];
$pageN = $pageNum - 1;
print qq[<td><</td>];
}
else
{
print q[<td><span class="currentpage">|<</span></td>];
print q[<td><span class="currentpage"><</span></td>];
}
if ( $pageNum < ( $numofPages - 1 ))
{
$pageN = $pageNum + 1;
print qq[<td>></td>];
$numofPages=$numofPages-1;
print qq[<td><a href="Filtering.cgi?
pageNum=$numofPages&Sortype=$val">>|</a></td>];
}
else {
print q[<td><span class="currentpage">></span></td>];
print q[<td><span class="currentpage">>|</span></td>];
}
print "</table>";
Client side table sorting is achieved with Javascript. There are dozens of libraries easily found by a simple Web search. Stuart Langridge's sorttable is very easy to implement.
This is not an answer to your question, but general advice. Therefore, I have made it community wiki.
Please stop writing CGI scripts for a while until you understand why your script has serious problems.
You have:
use CGI;
use CGI::Carp qw(warningsToBrowser fatalsToBrowser);
# ...
my $query = new CGI;
my $q = new CGI;
First, note that you need to initialize a CGI object only once. Avoid indirect method calls:
my $cgi = CGI->new;
I know the CGI.pm docs use $query but I find $cgi to be more meaningful.
That is a good step. Almost all CGI scripts should use well established libraries rather than homebrew code. However, after that good first step, you do:
print "Content-Type: text/html\n\n";
$query = $ENV{'QUERY_STRING'};
#list = split( /\&/, $query);
foreach (#list) {
($var, $val) = split(/=/);
$val =~ s/\'//g;
$val =~ s/\+/ /g;
$val =~ s/%(\w\w)/sprintf("%c", hex($1))/ge;
($var, ' = ', $val,);
}
There is no reason to engage in cargo-cult practices. Your CGI object already has the parameters passed to the script.
Also, you should declare your variables where they are first used as opposed to dumping all of them at the script.
Use CGI.pm's header to send the header. You have:
print <<END_HTML;
<html>
<head><title></title>
</head>
<body>
<form action="Filtering.cgi" method="post">
<TABLE>
<TR>
<TD>
<input type="hidden" name="submit" value="Submit">
</TD>
</TR>
</TABLE
</form>
</body></html>
END_HTML
which makes no sense as you have sent a complete HTML document before doing anything else in the script.
The rest of the code cannot change what you have already sent.
Put your HTML in a template. Personally, I like HTML::Template for the clean separation between code and content.
This way, you can write your Perl script to generate the content and include any client side functionality in the template separately.