use Image::Magick with perl on Ubuntu - perl

Image::Magick module is installed.
I do see the perldoc if I type:
perldoc Image::Magick
While trying to use it with a Dancer2 application I don't get any results.
A simple test script does compile but except my hello I don't get to see any results or warnings? What am I doing wrong?
#!/usr/bin/perl
use strict;
use warnings;
use Image::Magick;
print "hello!\n";
my $image = Image::Magick->new;
$image->Set(size=>'100x100');
$image->ReadImage('xc:white');
$image->Set('pixel[49,49]'=>'red');
$image->Write("cool.jpeg");
Below I provide the relevant parts of the code for the Dancer2 app. On my local (OS X) system everything works fine. On the server the Image::Magick part is not functioning.
As per request the way I use Image::Magick with Dancer2..
package myDancer;
use Dancer2;
use Dancer2::Plugin::Database;
use Dancer2::Plugin::Auth::Extensible;
use Data::Dumper;
use Image::Size;
use Image::Magick;
use File::Basename;
use File::Spec;
use FindBin;
use File::Copy qw(move);
# --below relevant code--
# UPLOAD-----------
get '/upload' => require_login sub {
template 'upload', {}, { layout => 'cms' };
};
post '/upload' => require_login sub {
my $data = request->upload('file');
return 'Error' if not defined $data;
my $upload_dir = path( config->{appdir}, "public/images/uploads" );
debug( "Line 79: ", $upload_dir );
# full path with file-name
# $data->basename is the name provided with uploaded file
my $path = path( $upload_dir, $data->basename );
if ( -e $path ) {
return "$path already exists";
}
$data->link_to($path);
redirect '/fm/uploaded';
};
#---------------------------------------------------------------------
#
# What have we uploaded?
#
#vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
get '/fm/uploaded' => require_login sub {
my $upload_dir = path( config->{appdir}, "public/images/uploads/*.jpeg" );
debug( "Line: 102 - Full path used for uploaded: ",
$upload_dir );
my #images = glob($upload_dir);
my #glob_uploaded;
for my $record (#images) {
my ( $w, $h ) = imgsize($record);
push(
#glob_uploaded,
{
photo_name => basename($record),
width => $w,
height => $h,
}
);
}
my $message = <<'MESSAGE';
Just a message
MESSAGE
template 'fm/uploads',
{ forklifts => \#glob_uploaded, message => $message },
{ layout => "cms" };
};
get '/fm/new-image/:photo_name' => require_login sub {
# my $curdir = File::Spec->rel2abs('.');
my $upload_dir = path( config->{appdir}, "public/images/uploads" );
debug( "Line 137: ", $upload_dir );
#---------------------------------------------------------------------
#
# What is the latest id?
# And add 1 to this id.
#
#vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
my $sql = <<'SQL';
select seq from sqlite_sequence where name = ?
SQL
my $sth = database->prepare($sql);
$sth->execute('images');
my $current = $sth->fetchall_arrayref();
my $current_plus_one = $current->[0][0] + 1;
my $new_name = &TimeStamp . "-" . $current_plus_one . ".jpeg";
debug( "line: 154 - new_name: ", $new_name );
#^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
#---------------------------------------------------------------------
my $photo_name = route_parameters->get('photo_name');
debug( "line 159 - photo_name ", $photo_name );
my $pathFoto =
path( config->{appdir}, "public/images/uploads/$photo_name" );
# my $pathFoto = "$upload_dir . $photo_name";
debug( "line 164: pathFoto", $pathFoto );
if ( -e $pathFoto ) {
print "File exists.\n"; # Debug
template 'fm/new-image', { photo => $new_name, sh_note => $photo_name },
{ layout => 'cms' };
}
else {
print "File doesn't exist.\n"; # Debug
redirect '/fm/forklift'; # TODO
}
};
#---------------------------------------------------------------------
#
# Adding the new image to the database together with meta-data
#
#vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
post '/fm/new-image' => require_login sub {
my $new_name = body_parameters->get('photo_name')
or die "missing content parameter";
my $caption = body_parameters->get('caption');
my $location = body_parameters->get('location');
my $short_note = body_parameters->get('sh_note');
my $note = body_parameters->get('note');
database->quick_insert(
'images',
{
photo_name => $new_name,
caption => $caption,
note => $note,
sh_note => $short_note,
location => $location,
}
);
my $curdir = path( config->{appdir}, "public/images/" );
debug( "line: 205 - check path: ", $curdir );
my $old_image_location_lg =
path( config->{appdir}, "public/images/uploads/$short_note" );
debug( "line: 209 - check path: ", $old_image_location_lg );
my $magick = new Image::Magick;
$magick->Read($old_image_location_lg);
$magick->Write( path( config->{appdir}, "public/images/lg/$new_name" ) );
$magick->Resize( gravity => 'Center' );
$magick->Scale( geometry => '3%x3%' );
$magick->Write( path( config->{appdir}, "public/images/tn/$new_name" ) );
unlink $old_image_location_lg;
redirect '/fm/recent-images';
};
####################################################### TIMESTAMP #######
# perldoc -q time
# perldoc -f localtime
sub TimeStamp {
my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
( 0, 0, 0, 0, 0, 0, 0, 0, 0 );
( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) =
localtime(time);
$year += 1900;
$mon += 1;
$sec = sprintf( "%02d", $sec );
$min = sprintf( "%02d", $min );
$hour = sprintf( "%02d", $hour );
$mon = sprintf( "%02d", $mon );
$mday = sprintf( "%02d", $mday );
my $timestamp =
"$year" . "-" . "$mon" . "-" . "$mday" . "-" . "$hour" . "-" . "$min";
return $timestamp;
}
####################################################### TIMESTAMP #######
true;

I tested your code and in the directory where my perl file is, it generated a new jpeg file.
I can suggest checking if your file and directory have the needed permissions for writing new files.
P.S. I am using FreeBSD 13

Related

Generate Excel output using Win32::OLE in Perl

I am a beginner in Perl and have tried playing around with Perl much to understand its ways and working! I have a basic knowledge of arays, hashes and related topics. I have to develop a script for a topic and i am quite unsure how to go about it. I desperately need help and am very grateful to anyone who can explain the 'how to do' part!
I have a code with 3 parts in it which does the same thing thrice for 3 different lets say components. Basic idea is, it takes all the components marked 'A' from an excel file, iterates through the excel file, adds up its corresponding RAM and ROM values and prints out the output without duplicate entries. The 2nd and 3rd part are the same but for components 'B' and 'C'. So far i am able to print out the output of all 3 parts in a text file. But now i want all three outputs in an excel workbook as 3 separate worksheets!
I am not particularly sure how to go about it. Any ideas are really welcome!!!
PS: Please forgive me if i have not typed the code right in the forum! This is my first post!!
Here is how my code looks so far:
# This Test script was created to try out the possible methods to extract all the Names from the
# excel report without duplicate entries and find their corresponding RAM/ROM size sum
# -excel D:\Abc\Test.xlsx -out D:\Abc\Output
sub usage($)
{
return shift(#_) . <<"END_USAGE";
Usage: $0 -excel Specify the file path.
-out outputdirectory Specify output directiory
END_USAGE
}
use Getopt::Long;
use Win32::OLE;
use List::Util qw(sum);
use Data::Dumper qw(Dumper);
my $output_path = ();
my $excel_path = ();
my $no_rows = ();
my $lastCol = ();
GetOptions("excel=s" => \$excel_path,
"out=s" => \$output_path,
"h|help" => \$help,
);
#help message
die usage("") if ($help);
system(cls);
print "\n*******************************************************************\n";
print "Component Overview \n";
print "*******************************************************************\n";
print "Please wait, Processing may take couple of minutes... \n";
##File handler for the script file.
$log_path = $output_path."\\log.txt";
$output_file_path = $output_path."\\TestExcel.xlsx";
open LogFile,">",$log_path or die "Cannot create the log file:$log_path !!!";
print LogFile "Start time :".localtime()."\n";
# Start Excel and make it visible
my $xlApp = Win32::OLE->GetActiveObject('Excel.Application') || Win32::OLE->new('Excel.Application', 'Quit');
$xlApp->{Visible} = 0;
#Opening the work book
my $workBook = $xlApp->Workbooks->Open($excel_path);
#print "X: " . $workBook . " - " . $excel_path . "\n";
my $excelSheet = $workBook->Worksheets("Report");
$excelSheet->Activate();
print "Reading the file...\n";
&ReadExcel();
print LogFile "Completed time :".localtime()."\n";
print "\nCompleted.Please close this window...\n" ;
print "*******************************************************************\n";
# Sub routine to parse the cosipa file
sub ReadExcel()
{
my $row_index;
#Findings the number of valid rows
$no_rows = $excelSheet->UsedRange->Rows->{'Count'};
$lastCol = $excelSheet->UsedRange->Columns->{'Count'};
$row_index = findRowindex();
my #comp_array = ();
# Name => ResourceType => size
my $resultData = {};
for(my $index=($row_index+1);$index<=$no_rows;$index++)
{
my $X = $excelSheet->Cells($index,6)->Value();
my $Y = $excelSheet->Cells($index,7)->Value();
my $name = $excelSheet->Cells($index,9)->Value();
my $resourceType = $excelSheet->Cells($index,3)->Value();
my $size = $excelSheet->Cells($index,2)->Value();
#Name Overview
my $currNameTypeMap;
if ( ! exists $resultNameData->{ $name } ) # ->: arrow operator is used to dereference reference to arrays or hashes.
{
$resultNameData->{ $name } = {};
}
$currNameTypeMap = $resultNameData->{ $name };
$currNameTypeMap->{ $resourceType } += $size;
# Y Overview
my $currYTypeMap;
if ( ! exists $resultYData->{ $Y } ) # ->: arrow operator is used to dereference reference to arrays or hashes.
{
$resultYData->{ $cluster } = {};
}
$currYTypeMap = $resultYData->{ $Y };
$currYTypeMap->{ $resourceType } += $size;
# X Overview
my $currXTypeMap;
if ( ! exists $resultXData->{ $X } ) # ->: arrow operator is used to dereference reference to arrays or hashes.
{
$resultXData->{ $X } = {};
}
$currXTypeMap = $resultXData->{ $X };
$currXTypeMap->{ $resourceType } += $size;
}
my #uniqNameArr = sort keys %$resultNameData;
my #uniqYArr = sort keys %$resultYData;
my #uniqXArr = sort keys %$resultXData;
for my $currName ( #uniqNameArr )
{
print $currName . "\n". " RAM: " . $resultNameData->{ $currName }-> { "RAM" } . ", ROM: " . $resultNameData->{ $currName }-> { "ROM" } . "\n";
#print Dumper %$resultData;
}
print "----------------------------------------------------------------------- \n";
for my $currY ( #uniqYArr )
{
print $currY. "\n". " RAM: " . $resultYData->{ $currY }-> { "RAM" } . ", ROM: " . $resultYData->{ $currY }-> { "ROM" } . "\n";
}
print "------------------------------------------------------------------------ \n";
for my $currX ( #uniqXArr )
{
print $currX . "\n". " RAM: " . $resultXData->{ $currX }-> { "RAM" } . ", ROM: " . $resultXData->{ $currX }-> { "ROM" } . "\n";
}
}
#Sub routine to find the starting row index
sub findRowindex()
{
my $ret = ();
for(my $index=1;$index<$no_rows;$index++)
{
if(defined($excelSheet->Cells($index,1)))
{
my $cel_value = $excelSheet->Cells($index,1)->Value();
if($cel_value =~ m/^Name$/i)
{
$ret = $index;
last;
}
}
}
return $ret;
}
#Trim function
sub trim {
(my $s = $_[0]) =~ s/^\s+|\s+$//g;
return $s;
}
A workaround: You could use Excel::Writer::XLSX to create Excel files, it is working fine and quite robust. Here is how you could convert a tab separated file to Excel.
Reading excel: Spreadsheet::XLSX
use Text::Iconv;
my $converter = Text::Iconv -> new ("utf-8", "windows-1251");
use Spreadsheet::XLSX;
my $excel = Spreadsheet::XLSX -> new ('test.xlsx', $converter);
foreach my $sheet (#{$excel -> {Worksheet}}) {
printf("Sheet: %s\n", $sheet->{Name});
$sheet -> {MaxRow} ||= $sheet -> {MinRow};
foreach my $row ($sheet -> {MinRow} .. $sheet -> {MaxRow}) {
$sheet -> {MaxCol} ||= $sheet -> {MinCol};
foreach my $col ($sheet -> {MinCol} .. $sheet -> {MaxCol}) {
my $cell = $sheet -> {Cells} [$row] [$col];
if ($cell) {
printf("( %s , %s ) => %s\n", $row, $col, $cell -> {Val});
}
}
}
}
Writing excel: Excel::Writer::XLSX
my $workbook = Excel::Writer::XLSX->new( $xls_filename );
my $worksheet = $workbook->add_worksheet('data');
# Create a format for the headings
my $header_format = $workbook->add_format();
$header_format->set_bold();
$header_format->set_size( 18 );
$header_format->set_color( 'black' );
$header_format->set_align( 'center' );
my $row=0;
while (my $line = <$fh>){
chomp($line);
my #cols = split(/\t/,$line);
for(my $col=0;$col<#cols;$col++){
if ($row == 0 ){
$worksheet->write_string( $row, $col, $cols[$col],$header_format );
} else {
$worksheet->write_string( $row, $col, $cols[$col] );
}
}
$row++;
}
close($fh);
I hope this helps you.
Regards,

Validation of textbox values in wxPerl crashes perl interpreter

I'm using:
Windows 7
Strawberry Perl
using current version of wxPerl (from CPAN)
The perl code that creates the layout has been generated by wxGlade.
This code results in the error "Perl Interpretor has stopped working":
use Wx 0.15 qw[:allclasses];
use strict;
# begin wxGlade: dependencies
# end wxGlade
# begin wxGlade: extracode
# end wxGlade
package MyFrame;
use Wx;
use Wx qw[:everything];
use Wx::Event qw( EVT_BUTTON EVT_CLOSE );
use Wx::Perl::TextValidator;
use base qw(Wx::Frame Class::Accessor::Fast);
use strict;
use Wx::Locale gettext => '_T';
__PACKAGE__->mk_ro_accessors( qw(numeric string) );
sub new {
my( $self, $parent, $id, $title, $pos, $size, $style, $name ) = #_;
$parent = undef unless defined $parent;
$id = -1 unless defined $id;
$title = "" unless defined $title;
$pos = wxDefaultPosition unless defined $pos;
$size = wxDefaultSize unless defined $size;
$name = "" unless defined $name;
# begin wxGlade: MyFrame::new
$style = wxDEFAULT_FRAME_STYLE
unless defined $style;
my $numval = Wx::Perl::TextValidator->new( '\d' );
$self = $self->SUPER::new( $parent, $id, $title, $pos, $size, $style, $name );
$self->{text_ctrl_1} = Wx::TextCtrl->new($self, wxID_ANY, "", wxDefaultPosition, wxDefaultSize, );
$self->{button_1} = Wx::Button->new($self, wxID_ANY, _T("Get"));
$self->{label_1} = Wx::StaticText->new($self, wxID_ANY, _T("From:"), wxDefaultPosition, wxDefaultSize, );
$self->{text_ctrl_2} = $self->{numeric} = Wx::TextCtrl->new($self, wxID_ANY, "", wxDefaultPosition, wxDefaultSize, );
$self->{label_2} = Wx::StaticText->new($self, wxID_ANY, _T("To: "), wxDefaultPosition, wxDefaultSize, );
$self->{text_ctrl_3} = $self->{numeric} = Wx::TextCtrl->new($self, wxID_ANY, "", wxDefaultPosition, wxDefaultSize, );
$self->{radio_box_1} = Wx::RadioBox->new($self, wxID_ANY, _T("Vote?"), wxDefaultPosition, wxDefaultSize, [_T("Yes"), _T("No")], 2, wxRA_SPECIFY_ROWS);
$self->{text_ctrl_4} = Wx::TextCtrl->new($self, wxID_ANY, "", wxDefaultPosition, wxDefaultSize, wxTE_MULTILINE);
$self->__set_properties();
$self->__do_layout();
# end wxGlade
$self->{text_ctrl_2}->SetValidator ( $numval ); #<- this is where the program crashes
$self->{text_ctrl_3}->SetValidator ( $numval ); #<- this WORKS actually
EVT_BUTTON(
$self,
$self->{button_1},
\&GetURL
);
EVT_CLOSE(
$self,
\&OnClose
);
return $self;
}
I had no errors prior to trying the number validation on those two textctrl's. What I'm trying to do is accept only digits in my fields.
I'm using wxperl_demo as my documentation.
The fact that the second SetValidator is working is curious to me, what could be the problem?
Apparently, you can't use the same variable twice as an argument to SetValidator. Using another one solved this.

How to print the profile details individual lines

#!/usr/bin/perl -w
use WWW::LinkedIn;
use CGI; # load CGI routines
use CGI::Session;
$q = CGI->new; # create new CGI object
print $q->header, # create the HTTP header
$q->start_html('hello world'), # start the HTML
$q->h1('hello world'), # level 1 header
$q->end_html; # end the HTML
my $consumer_key = 'xxxxxxx';
my $consumer_secret = 'xxxxxxxxx';
my $li = WWW::LinkedIn->new(
consumer_key => $consumer_key,
consumer_secret => $consumer_secret,
);
if ( length( $ENV{'QUERY_STRING'} ) > 0 ) {
$buffer = $ENV{'QUERY_STRING'};
#pairs = split( /&/, $buffer );
foreach $pair (#pairs) {
( $name, $value ) = split( /=/, $pair );
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$in{$name} = $value;
}
$sid = $q->cookie('CGISESSID') || $q->param('CGISESSID') || undef;
$session = new CGI::Session( undef, $sid, { Directory => '/tmp' } );
my $access_token = $li->get_access_token(
verifier => $in{'oauth_verifier'},
request_token => $session->param("request_token"),
request_token_secret => $session->param("request_token_secret"),
);
undef($session);
my $profile_xml = $li->request(
request_url =>
'http://api.linkedin.com/v1/people/~:(id,first-name,last-name,positions,industry,distance)',
access_token => $access_token->{token},
access_token_secret => $access_token->{secret},
);
print $profile_xml;
}
The output is printing in single line. I want to print that is separate line.
OUTPUT
aAVGFD34 jj DD 456456 2003 6 true ara systems Technology and Services Technology and Services 0
How can i get the each column value from the profile_xml variable?
id avsdff
first name jj
lastname dd
Simply use Data::Dumper and XML::Simple.
use Data::Dumper;
use XML::Simple; #you may want to install a specific package from your distribution
{...}
my $hash_ref = SimpeXML::XMLin($profile_xml);
print Dumper($hash_ref);
I do not know if you would like more beautifully output.
try just to make simple print out from your hash reference
foreach $key (keys %{$profile_xml}) {
print "$key $profile_xml->{$key}\n";
}
Here i am going the show the way to parse the data and print in the individual lines.
my $parser = XML::Parser->new( Style => 'Tree' );
my $tree = $parser->parse( $profile_xml );
#print Dumper( $tree ); you can use this see the data displayed in the tree formatted
my $UID = $tree->[1]->[4]->[2],"\n";
print "User ID:$UID";
print"</br>";
my $FirstName = $tree->[1]->[8]->[2],"\n";
print "First Name:$FirstName";
print"</br>";
For sample i have showed for UID and FirstName. And this is working fine.

Perl HTTP server

I'm new at Perl, and I have a question regarding HTTP servers and client APIs.
I want to write an HTTP server which accepts requests from HTTP clients. The problem is that I do not know how to do it because I'm a Java developer, and it's a little bit difficult for me. Please can you give me some tutorials and example for HTTP::Daemon module for Perl?
I spent a lot of time trying to make a "simple" usable web server by many users simultaneously. The documentation for HTTP::Daemon and other online resources isn't helping me.
Here is a working (Ubuntu 12.10 with default Perl package v5.14.2) example preforked web server with different content type pages and error pages:
#!/usr/bin/perl
use strict;
use warnings;
use CGI qw/ :standard /;
use Data::Dumper;
use HTTP::Daemon;
use HTTP::Response;
use HTTP::Status;
use POSIX qw/ WNOHANG /;
use constant HOSTNAME => qx{hostname};
my %O = (
'listen-host' => '127.0.0.1',
'listen-port' => 8080,
'listen-clients' => 30,
'listen-max-req-per-child' => 100,
);
my $d = HTTP::Daemon->new(
LocalAddr => $O{'listen-host'},
LocalPort => $O{'listen-port'},
Reuse => 1,
) or die "Can't start http listener at $O{'listen-host'}:$O{'listen-port'}";
print "Started HTTP listener at " . $d->url . "\n";
my %chld;
if ($O{'listen-clients'}) {
$SIG{CHLD} = sub {
# checkout finished children
while ((my $kid = waitpid(-1, WNOHANG)) > 0) {
delete $chld{$kid};
}
};
}
while (1) {
if ($O{'listen-clients'}) {
# prefork all at once
for (scalar(keys %chld) .. $O{'listen-clients'} - 1 ) {
my $pid = fork;
if (!defined $pid) { # error
die "Can't fork for http child $_: $!";
}
if ($pid) { # parent
$chld{$pid} = 1;
}
else { # child
$_ = 'DEFAULT' for #SIG{qw/ INT TERM CHLD /};
http_child($d);
exit;
}
}
sleep 1;
}
else {
http_child($d);
}
}
sub http_child {
my $d = shift;
my $i;
my $css = <<CSS;
form { display: inline; }
CSS
while (++$i < $O{'listen-max-req-per-child'}) {
my $c = $d->accept or last;
my $r = $c->get_request(1) or last;
$c->autoflush(1);
print sprintf("[%s] %s %s\n", $c->peerhost, $r->method, $r->uri->as_string);
my %FORM = $r->uri->query_form();
if ($r->uri->path eq '/') {
_http_response($c, { content_type => 'text/html' },
start_html(
-title => HOSTNAME,
-encoding => 'utf-8',
-style => { -code => $css },
),
p('Here are all input parameters:'),
pre(Data::Dumper->Dump([\%FORM],['FORM'])),
(map { p(a({ href => $_->[0] }, $_->[1])) }
['/', 'Home'],
['/ping', 'Ping the simple text/plain content'],
['/error', 'Sample error page'],
['/other', 'Sample not found page'],
),
end_html(),
)
}
elsif ($r->uri->path eq '/ping') {
_http_response($c, { content_type => 'text/plain' }, 1);
}
elsif ($r->uri->path eq '/error') {
my $error = 'AAAAAAAAA! My server error!';
_http_error($c, RC_INTERNAL_SERVER_ERROR, $error);
die $error;
}
else {
_http_error($c, RC_NOT_FOUND);
}
$c->close();
undef $c;
}
}
sub _http_error {
my ($c, $code, $msg) = #_;
$c->send_error($code, $msg);
}
sub _http_response {
my $c = shift;
my $options = shift;
$c->send_response(
HTTP::Response->new(
RC_OK,
undef,
[
'Content-Type' => $options->{content_type},
'Cache-Control' => 'no-store, no-cache, must-revalidate, post-check=0, pre-check=0',
'Pragma' => 'no-cache',
'Expires' => 'Thu, 01 Dec 1994 16:00:00 GMT',
],
join("\n", #_),
)
);
}
There is a very fine example in the documentation for HTTP::Daemon.
A client example compliant with the synopsys from HTTP::Daemon :
require LWP::UserAgent;
my $ua = LWP::UserAgent->new;
$ua->timeout(10);
$ua->env_proxy;
my $response = $ua->get('http://localhost:52798/xyzzy');
if ($response->is_success) {
print $response->decoded_content; # or whatever
}
else {
die $response->status_line;
}
You just need to adapt the port and maybe the host.

Getting a Bareword error on Perl Tutorial

I'm making progress but I've run into a new problem.
This is the new code:
#!/usr/bin/perl -w
use strict;
use LWP::Simple;
use HTML::TreeBuilder;
my $url = 'http://oreilly.com/store/complete.html';
my $page = get( $url ) or die $!;
my $p = HTML::TreeBuilder->new_from_content( $page );
my($book);
my($edition);
my #links = $p->look_down(
_tag => 'a',
href => qr{^ /Qhttp://www.oreilly.com/catalog/\E \w+ $}x
);
my #rows = map { $_->parent->parent } #links;
my #books;
for my $row (#rows) {
my %book;
my #cells = $row->look_down( _tag => 'td' );
$book{title} =$cells[0]->as_trimmed-text;
$book{price} =$cells[2]->as_trimmed-text;
$book{price} =~ s/^\$//;
$book{url} = get_url( $cells[0] );
$book{ebook} = get_url( $cells[3] );
$book{safari} = get_url( $cells[4] );
$book{examples} = get_url( $cells[5] );
push #books, \%book;
}
sub get_url {
my $node = shift;
my #hrefs = $node->look_down( _tag => 'a');
return unless #hrefs;
my $url = $hrefs[0]->atr('href');
$url =~ s/\s+$//;
return $url;
}
$p = $p->delete; #we don't need this anymore.
{
my $count = 1;
my #perlbooks = sort { $a->{price} <=> $b->{price} }
grep { $_->{title} =~/perl/i } #books;
print $count++, "\t", $_->{price}, "\t", $_->{title} for #perlbooks;
}
{
my #perlbooks = grep { $_->{title} =~ /perl/i } #books;
my #javabooks = grep { $_->{title} =~ /java/i } #books;
my $diff = #javabooks - #perlbooks;
print "There are ".#perlbooks." Perl books and ".#javabooks. " Java books. $diff more Java than Perl.";
}
for my $book ( $books[34] ) {
my $url = $book->{url};
my $page = get( $url );
my $tree = HTML::TreeBuilder->new_from_content( $page );
my ($pubinfo) = $tree->look_down(
_tag => 'span',
class => 'secondary2'
);
my $html = $pubinfo->as_HTML; print $html;
my ($pages) = $html =~ /(\d+) pages/,
my ($edition) = $html =~ /(\d)(?:st|nd|rd|th) Edition/;
my ($date) = $html =~ /(\w+ (19|20)\d\d)/;
print "\n$pages $edition $date\n";
my ($img_node) = $tree->look_down(
_tag => 'img',
src => qr{^/catalog/covers/},
);
my $img_url = 'http://www.oreilly.com'.$img_node->attr('src');
my $cover = get( $img_url );
# now save $cover to disk
}
Now I'm getting these errors,
Bareword "text" not allowed while "strict subs" in use at ./SpiderTutorial_19_06.pl line 23.
Bareword "text" not allowed while "strict subs" in use at ./SpiderTutorial_19_06.pl line 24.
Execution of ./SpiderTutorial_19_06.pl aborted due to compilation errors.
Any help would be greatly appreciated.
I don't know the original program but most likely as_trimmed-text should be as_trimmed_text.
The problem is the method name as_trimmed-text. Hyphens aren't allowed in names in perl. You probably meant as_trimmed_text. Now it parsed as $cells[0]->as_trimmed() - text().