Beefy Boxes and Bandwidth Generously Provided by pair Networks
"be consistent"
 
PerlMonks  

Discipulus's scratchpad

by Discipulus (Curate)
on Jun 03, 2004 at 10:36 UTC ( #360051=scratchpad: print w/ replies, xml ) Need Help??

Dear Tux, here you have my effert to enhance your precious speedtest.pl Lines 19-45 slightly modify your initialization but nothing heavy. The sub get_config_and_servers_Twig replace the two subs get_config and get_servers. That subs return nothing and only sets globals. this is because the twig handlers parses the docs on the flight. Hth. lorenzo
use 5.10.0; use warnings; use strict; use LWP::UserAgent; ## switch to a maintained (more performant?) module use XML::Twig; use Data::Peek; ##### force the dump of $config, only for this test my $opt_v = 6; my $ua = LWP::UserAgent->new ( max_redirect => 2, agent => "Opera/25.00 opera 25", parse_head => 0, cookie_jar => {}, ); ###NEW THINGS FROM HERE ON ### my $client; my $times; my $downld; my $upld; #new my $ignore_ids; my %list; ## a global instead my %list = get_servers (); at line 385 my $config={};## a global get_config_and_servers_Twig(); ## SAME TEST BUT INVERTED ASSIGNMENT $config->{"client"} = $client or die "Config saw no client\n"; $config->{"times"} = $times or die "Config saw no times\n"; $config->{"download"} = $downld or die "Config saw no download\n"; $config->{"upload"} = $upld or die "Config saw no upload\n"; $config->{"server-config"}{"ignoreids"} = $ignore_ids or die "Config +saw no ignore ids\n"; $opt_v > 5 and DDumper $config; ### ################################################################## +########## sub get_config_and_servers_Twig { my $url = "http://www.speedtest.net/speedtest-config.php"; my $rsp = $ua->request (HTTP::Request->new (GET => $url)); $rsp->is_success or die "Cannot get config: ", $rsp->status_line, +"\n"; ## my $twig_config=XML::Twig->new( twig_handlers => { 'settings/client' => sub { map {$$client{$_} = $_[1]->att( +$_)} qw/ip isp ispdlavg isprating ispulavg lat loggedin lon rating/} +, # times seems not used by your program!! 'settings/times' => sub { map {$$times{$_} = $_[1]->att($_ +)} qw/dl1 dl2 dl3 ul1 ul2 ul3/}, 'settings/download' => sub { map {$$downld{$_} = $_[1]->at +t($_)} qw/initialtest mintestsize testlength threadsperurl/}, 'settings/upload' => sub { map {$$upld{$_} = $_[1]->att($_ +)} qw/initialtest maxchunkcount maxchunksize mintestsize ratio testl +ength threads threadsperurl/}, # 'settings/server-config' => sub { $ignore_ids = $_[1]->att +('ignoreids') }, }, ); $twig_config->parse( $rsp->content ); # now get_servers my $url_servers = "http://www.speedtest.net/speedtest-servers-stat +ic.php"; my $rsp_servers = $ua->request (HTTP::Request->new (GET => $url_se +rvers)); # ATTENTION the die was die "Cannot get config: " AND NOT get serv +ers.. $rsp_servers->is_success or die "Cannot get servers ", $rsp_server +s->status_line, "\n"; my $twig_servers=XML::Twig->new( twig_handlers => { 'settings/servers/server' => sub { $list{$_[1]->att('id')} = { map {$_=>$_[1]-> +att($_)} qw/cc country lat lon name sponsor url url2/ } }, }, ); $twig_servers->parse( $rsp_servers->content ); # HERE IS TOO SOON.....$opt_v > 5 and DDumper $config;##was $xml-> +{settings} #return $xml->{settings}; } # get_config_and_servers_Twig
#!perl use strict; use warnings; #use Term::ReadLine; ##http://bvr.github.io/2010/11/term-readline/ BEGIN { $ENV{PERL_RL}="Perl";$ENV{TERM} = 'not dumb' if $^O eq 'MSWin3 +2';} $\="\n"; use Term::ReadLine; my $term=Term::ReadLine->new("test"); print $term->ReadLine; print $term->Attribs; use Data::Dump::Streamer; $term->Attribs->{completion_function} = sub { my ($text, $line, $start) = @_; return grep { /^$text/i } (qw( SELECT INSERT UPDATE DELETE FROM WHERE AS IN ASC DESC ),'ORDER BY'); }; #foreach my $k (keys $term->Attribs){print "$k ${$term->Attribs}{$k}\n +"} #exit; #Dump %{$term->Attribs};exit; my %cmds = (alloid=>1,ammoid=>2); # THIS WORKS #&readline::rl_basic_commands(keys %cmds); # THE FOLLOWING CHECK DOES NOT WORK #if (exists &readline::rl_basic_commands){print "BEFORE WHILE EXIST +S\n"; &readline::rl_basic_commands(keys %cmds);} while ( defined ( $_ = $term->readline( '>') ) ) { print "$_\n"; } continue{ # THIS CHECK WORKS INDEED! if (exists &readline::rl_basic_commands){print "IN CONTINUE EXISTS\ +n"; &readline::rl_basic_commands(keys %cmds);} }
v30 bug linea 65
#!perl use strict; use warnings; use Data::Dump::Streamer; use Term::ReadLine; # CPANnn would be impossible without a big ABuse o +f Data::Dump::Streamer $ENV{TERM}=undef; # TAB completion made possible on win32 via Term:: +Readline with TERM= my ($ua,$cpanfh); # ugly again? no! UserAgent. need to be here befor +e BEGIN is found,the file handle for cpan data too BEGIN{ local $@; eval{ require LWP::UserAgent; }; if ($@){print "WARNING: no LWP::UserAgent support!"} if ($@ and !$ARGV[0]){die "FATAL: no filename as argument nor LWP::U +serAgent support!\n"} $ua = LWP::UserAgent->new; my $filename = defined $ARGV[0] ? $ARGV[0] : '02packages.details.txt +'; # this must go inside or assignment is not run if (!$ARGV[0]){ print "Downloading $filename, please wait..\n"; $ua->get('http://www.cpan.org/modules/'.$filename,': +content_file'=>$filename) } open $cpanfh,'<',$filename or die "FATAL: unable to open '$filename' + for reading!\n"; } my $term = Term::ReadLine->new('CPAN namespace navigator'); my $cpan = {'.'=>'CPAN'}; # the main cpan hasref, container of a +ll namespaces my $skiprx = qr/^[\.\+]{1,2}$/; # regex used to skip secret hash keys: + . .. + ++ (last not used really) my $pagination = 20; # used to divide in screenfulls the re +adme files my @infos = "\nINFO:\n\n"; # infos about the file and help too # now feed @infos with headers from fi +le while (<$cpanfh>){print "Processing data, please wait..\n" and last if + /^$/;push @infos, $_} push @infos, $_ for "\n\n","USAGE: $0 [02packages.details.txt]\n\nNAVI +GATION:\n\n", ". simple list of contained namespaces\n",".. move one level up +\n","+ detailed list of contained namespaces\n", "* read the readme file of current namespace\n", "** download t +he current namespace's package\n", "? print this help\n","\nTAB completion enabled on all sub name +spaces\n","$0 by Discipulus as found at perlmonks.org\n\n"; while (<$cpanfh>){ # main extrapolation loop chomp; # AA::BB::CC 0.01 D/DI/DISCIPULUS/AA +-BB-CC-0.001.tar.gz my @fields = split /\s+/;# split namespaces, version, partial +path my @names = split /::/, $fields[0];# split namespace in AA BB +CC my @ancestors = @names; pop @ancestors; # @ancestors are @names less last ele +ment eval '$cpan->{\''. # start of cpan containe +r; it ends before next = sign (join '\'}{\'', @names).'\'} ='.# expand names and vivif +ies BECAUSE there is an assignment '{'. # hasref start '"."=>$names[-1],'. # hasref . is name and . +. is a ref to father '".."=> \%{$cpan'.(defined $ancestors[0] ?'->{\''.(j +oin '\'}{\'', @ancestors ).'\'}':'').'},'. '"+"=> [$fields[1],$fields[2]],'. # hashref + is use +d for version and author path array '}; '; # hashref end }Dump $cpan; my $current = \%$cpan; # the current hashref namespace starts at top l +evel of the hash &header($current); # first time header my @cur_names; # take track of namespaces and, if empty, tell +us we are at top level &readline::rl_basic_commands(@{&autocompletes}); #first time autoc +ompletes filling while ( defined ( $_ = $term->readline( (join '::',@cur_names).'>') ) +) { /^$/ ? next : chomp; s/\s+//g; if (exists $$current{$_} and $_ !~ $skiprx) { $current = \%{$$current{$_}}; push @cur_names, $_; next; } elsif($_ eq '.'){ # . -> ls print "$_\n" for grep $_ !~ $skiprx, sort keys %$current; } elsif($_ eq '+'){ # + -> ls -l foreach my $k(grep $_ !~ $skiprx, sort keys %$current) { print "$k\t", ${$current->{$k}{'+'}}[0] ? join "\t" +, @{$current->{$k}{'+'}} : "--CONTAINER NAMESPACE--","\n"; } } elsif($_ eq '..'){# .. -> cd .. #$current = ref $current->{'..'} eq 'HASH' ? \%{$current->{'. +.'}}: \%$cpan; $current = \%{$current->{'..'}} ; pop @cur_names; } elsif($_ eq '*'){ # * -> dump the readme unless ($ua){print "WARNING: no LWP::UserAgent support!\n"; +next;} if (defined $$current{'+'}->[0]) { (my $url = 'http://www.cpan.org/authors/id/'.$$current +{'+'}->[1]) =~s/\.tar\.gz/\.readme/ ; my $line_count; foreach my $line (split "\n",$ua->get($url)->content() +) { ++$line_count; print "$line_count:".$line."\n" ; if ($line_count % $pagination == 0){print "-- pres +s Enter to continue..";while (<STDIN>){last if $_ }} } } } elsif($_ eq '**'){# ** -> download the package unless ($ua){print "WARNING: no LWP::UserAgent support!\n"; +next;} if (defined $$current{'+'}->[0]) { (my $gzfile = 'http://www.cpan.org/authors/id/'.$$curr +ent{'+'}->[1]) =~s{.+/}{} ; my $resp = $ua->get('http://www.cpan.org/authors/id/' +.$$current{'+'}->[1],':content_file'=>$gzfile); print $resp->is_success ? "OK: download of '$gzfile' +succesfull\n" : "WARNING: $resp->status_line!\n"; } } elsif($_ eq '?'){ print for @infos }# * -> shows infos and help else{print "WARNING: '$_' command not found!\n"; next} } continue{ &header($current); &readline::rl_basic_commands(@{&autocompletes}); } sub autocompletes{scalar @cur_names > 0 ? return [grep $_ !~ $skiprx,s +ort keys %$current] : return [grep $_ !~ $skiprx, keys %$cpan]; } sub header { my $hr = shift; print "\n",(join '::',@cur_names or 'CPAN'),($$hr{'+'}->[0] ? "\t$ +$hr{'+'}->[0]\t$$hr{'+'}->[1]" : ""), " has ",(scalar@{[grep $_ !~ $skiprx, keys %$hr]})," namespa +ces\n"; }
v20
#!perl my $ua; BEGIN{ my $ua; local $@; eval{ require LWP::UserAgent; #LWP::UserAgent->import; $ua = LWP::UserAgent->new; }; if ($@){warn "WARNING: no LWP::UserAgent support!"} if ($@ and !$ARGV[0]){die "FATAL: no filename as argoument nor LWP:: +UserAgent support!\n"} eval{ require Term::ReadKey; #Term::ReadKey->import; #$ua = LWP::UserAgent->new; }; if ($@){warn "WARNING: no Term::ReadKey support!"} #our $ua = LWP::UserAgenta->new; } my $ua; print $ua; #exit; use strict; use warnings; use feature qw (say); $|=1; use Diagnostics; use Data::Dumper; use Data::Dump::Streamer; my $cpan = {'.'=>'CPAN'}; #_=>'',__=>'' my $skiprx = qr/^[\.\+]{1,2}$/; #our @names; &grow_tree; sub grow_tree { while (<DATA>){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @name +s"; my $cur; my @ancestors = @names; pop @ancestors; eval '$cpan->{'. # start od cpan container (join '}{', @names).'} ='. # expand names and vivifies + because there is assignment '{'. # hasref start '"."=>$names[-1],'. '".."=> \%{$cpan'.(defined $ancestors[0] ?'->{'.(joi +n '}{', @ancestors ).'}':'').','.'},'. '"+"=> [$fields[1],$fields[2]],'. '}; '; # hashref end } Dump($cpan); } my $current = \%$cpan;&header($current); my @cur_names; while(<STDIN>){ chomp; if (exists $$current{$_} and $_ !~ $skiprx) { $current = \%{$$current{$_}}; push @cur_names, $_; next; } # . -> ls elsif($_ eq '.'){ say for grep $_ !~ $skiprx, keys %$current; } # + -> ls -l elsif($_ eq '+'){ foreach my $k(grep $_ !~ $skiprx, keys %$current +) { print "$k\t", ${$current->{$k}{'+'}}[0 +] ? join "\t", @{$current->{$k}{'+'}} : "--CONTAINER NAMESPACE--","\n +"; } } # .. -> cd .. elsif($_ eq '..'){ ref $current->{'..'} eq 'HASH' ? say "ok father defined for $c +urrent->{'.'}" : say "WARN no father defined"; #$current = \%{$current->{__}}||\%$cpan; $current = ref $current->{'..'} eq 'HASH' ? \%{$current->{'.. +'}}: \%$cpan; pop @cur_names; } # * -> dump the readme elsif($_ eq '*'){ #foreach my $k (keys %$current) {next if $k=~$sk +iprx;print "$k @{$current->{$k}{'+'}}\n"} if (defined $$current{'+'}->[0]) { print "$$current{'.'} ". ($$current{'+'}->[0]||'').#($$current{'+'}->[0] ? $$c +urrent{'+'}->[0] : ''). "\n"; my $url = 'http://www.cpan.org/authors/id/'.$$current{ +'+'}->[1]; $url =~s/\.tar\.gz/\.readme/; print "URL: $url\n"; print LWP::UserAgent->new->get($url)->content() ; } } else{next} } continue{&header($current); #print "CURRENT: ",$$current{_},"\n"; } sub header { my $hr = shift; print "-" x 35,"\n"; #print "# CURRENT: ",($$hr{'.'}or 'EMPTY')," has ",(scalar@{[grep +!$skiprx, keys %$hr]} or 'no')," namespaces\n"; print +(join '::',@cur_names or 'CPAN'), ($$hr{'+'}->[0] ? "\t$$hr{'+'}->[0]" : "\t"), "\thas ",(scalar@{[grep $_ !~ $skiprx, keys %$hr]})," namesp +aces\n"; #print "#" x 35,"\n"; } __DATA__ ABI 1.0 M/MA/MALAY/ABI-1.0.tar.gz A 0.5 I/ID/IDOPEREL/Abilities-0.5.tar.gz A::BB 0.5 I/ID/IDOPEREL/Abilities-0.5.tar.gz A::CC 0.2 I/ID/IDOPEREL/Abilities-0.2.tar.gz A::CC::DD 0.2 I/ID/fake/Abilities-0.2.tar.gz XX::ZZ::YY 0.1 I/jhsjkha
v17 OK
#!perl use strict; use warnings; use feature qw (say); $|=1; use Diagnostics; use Data::Dumper; use Data::Dump::Streamer; my $cpan = {'.'=>'CPAN'}; #_=>'',__=>'' my $skiprx = qr/^\.{1,2}|\+$/; #our @names; &grow_tree; sub grow_tree { while (<DATA>){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @name +s"; my $cur; my @ancestors = @names; pop @ancestors; eval '$cpan->{'. # start od cpan container (join '}{', @names).'} ='. # expand names and vivifies + because there is assignment '{'. # hasref start '"."=>$names[-1],'. '".."=> \%{$cpan'.(defined $ancestors[0] ?'->{'.(joi +n '}{', @ancestors ).'}':'').','.'},'. '"+"=> [$fields[1],$fields[2]],'. '}; '; # hashref end } Dump($cpan); } my $current = \%$cpan;&header($current); while(<STDIN>){ chomp; if (exists $$current{$_} and $_ !~ $skiprx) { $current = \%{$$current{$_}}; } elsif($_ eq '.'){ say for grep !$skiprx, keys %$current; } elsif($_ eq '..'){ ref $current->{'..'} eq 'HASH' ? say "ok father defined for $c +urrent->{'.'}" : say "WARN no father defined"; #$current = \%{$current->{__}}||\%$cpan; $current = ref $current->{'..'} eq 'HASH' ? \%{$current->{'.. +'}}: \%$cpan; } elsif($_ eq '+'){ print join ' ', $current->{'.'},@{$current->{'+' +}},"\n" } #or abstract? elsif($_ eq '*'){ foreach my $k (keys %$current) {next if $k=~$ski +prx;print "$k @{$current->{$k}{'+'}}\n"} } #or abstract? else{next} } continue{&header($current); #print "CURRENT: ",$$current{_},"\n"; } sub header { my $hr = shift; print "#" x 35,"\n"; print "# CURRENT: ",$$hr{'.'}," has ",(scalar@{[grep !$skiprx, key +s %$hr]})," namespaces\n"; print "#" x 35,"\n"; } __DATA__ ABI 1.0 M/MA/MALAY/ABI-1.0.tar.gz A 0.5 I/ID/IDOPEREL/Abilities-0.5.tar.gz A::BB 0.5 I/ID/IDOPEREL/Abilities-0.5.tar.gz A::CC 0.2 I/ID/IDOPEREL/Abilities-0.2.tar.gz A::CC::DD 0.2 I/ID/fake/Abilities-0.2.tar.gz XX::ZZ::YY 0.1 I/jhsjkha #!perl use strict; use warnings; use feature qw (say); $|=1; use Diagnostics; use Data::Dumper; use Data::Dump::Streamer; my $cpan = {'_'=>'CPAN'}; #_=>'',__=>'' #our @names; &grow_tree; sub grow_tree { while (<DATA>){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @name +s"; my $cur; my @ancestors = @names; pop @ancestors; #print "for '",(join '::',@names),"' ancestor is ",( $ancestor +s[$#ancestors]?(join '::',@ancestors) : 'CPAN' ),"\n"; #print "\t\t-->\$cpan",(defined $ancestors[0] ?'{'.(join '}{', + @ancestors ).'}':''),"\n"; eval '$cpan->{'.(join '}{', @names).'} = {_=>$names[-1],__=> \ +%{$cpan'.(defined $ancestors[0] ?'->{'.(join '}{', @ancestors ).'}':' +').'}' .'}; '; #print "\n-------------\n-------------\n"; } Dump($cpan); } my $current = \%$cpan;&header($current); while(<STDIN>){ chomp; #say +( defined $$current{_} ? $$current{_} : 'CPAN')," has ",(sc +alar@{[grep !/^_{1,2}$/, keys %$current]})," namespaces\n"; #print '#' x 34,"\nCURRENT",(Dump $current),"\n",'#' x 34,"\n"; if (exists $$current{$_} and $_ !~ /^_{1,2}$/) { $current = \%{$$current{$_}}; &header($current); } elsif($_ eq '_'){ say for grep !/^_{1,2}$/, keys %$current; &head +er($current);} elsif($_ eq '__'){ ref $current->{__} eq 'HASH' ? say "ok father defined for $cur +rent->{_}" : say "WARN no father defined"; #$current = \%{$current->{__}}||\%$cpan; $current = ref $current->{__} eq 'HASH' ? \%{$current->{__}}: + \%$cpan; &header($current); } else{next} } #continue{ #say +( defined $$current{_} ? $$current{_} : 'CPAN')," has ",(scala +r@{[grep !/^_{1,2}$/, keys %$current]})," namespaces\n"; #print '#' x 34,"\nCURRENT",(Dump $current),"\n",'#' x 34,"\n"; #} sub header { my $hr = shift; #Dump $hr; print "CURRENT: ",$$hr{_},"\n"; #say +( defined $hr->{_} ? $hr->{_} : 'CPAN'), # " has ",(scalar@{[grep !/^_{1,2}$/, keys %$$hr]})," namespace +s\n"; } __DATA__ ABI 1.0 M/MA/MALAY/ABI-1.0.tar.gz A 0.5 I/ID/IDOPEREL/Abilities-0.5.tar.gz A::BB 0.5 I/ID/IDOPEREL/Abilities-0.5.tar.gz A::CC 0.2 I/ID/IDOPEREL/Abilities-0.2.tar.gz A::CC::DD 0.2 I/ID/fake/Abilities-0.2.tar.gz XX::ZZ::YY 0.1 I/jhsjkha
#!perl use strict; use warnings; use feature qw (say); $|=1; use Diagnostics; use Data::Dumper; use Data::Dump::Streamer; my $cpan = {a=>0}; #_=>'',__=>'' &grow_tree; sub grow_tree { while (<DATA>){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @name +s"; my $cur; my @ancestors = @names; pop @ancestors; #print "for ",(join '::',@names)," ancestor is ",( $ancestors[ +$#ancestors]||'CPAN' ),"\n"; print "for ",(join '::',@names)," ancestor is ",( $ancestors[$ +#ancestors]?(join '::',@ancestors) : 'CPAN' ),"\n"; print "\t\t-->\$cpan",(defined $ancestors[0] ?'{'.(join '}{', +@ancestors ).'}':''),"\n"; my $pater; say ' $pater = \$cpan'.(defined $ancestors[0] ?'{'.(join '}{' +, @ancestors ).'}':''); eval ' $pater = \$cpan'.(defined $ancestors[0] ?'{'.(join '}{' +, @ancestors ).'}':''); say '$cpan->{'.(join '}{', @names).'} = {_=>$names[-1],__=> \ +$pater}; '; eval '$cpan->{'.(join '}{', @names).'} = {_=>$names[-1],__=> \ +$pater}; '; print "\n"; } Dump($cpan); } exit; __DATA__ ABI 1.0 M/MA/MALAY/ABI-1.0.tar.gz Abilities 0.5 I/ID/IDOPEREL/Abilities-0.5.t +ar.gz Abilities::Features 0.5 I/ID/IDOPEREL/Abilities-0.5.t +ar.gz Abilities::Scoped 0.2 I/ID/IDOPEREL/Abilities-0.2.t +ar.gz Abilities::Scoped::FAKE 0.2 I/ID/fake/Abilities-0.2.tar.g +z ABNF::Generator undef N/NY/NYAAPA/ABNF-Grammar-0.08 +.tar.gz ABNF::Generator::Honest undef N/NY/NYAAPA/ABNF-Grammar-0.08 +.tar.gz ABNF::Generator::Liar undef N/NY/NYAAPA/ABNF-Grammar-0.08 +.tar.gz ABNF::Grammar 0.08 N/NY/NYAAPA/ABNF-Grammar-0.08 +.tar.gz ABNF::Validator undef N/NY/NYAAPA/ABNF-Grammar-0.08 +.tar.gz about undef S/SH/SHERWOOD/xisofs-1.3.tar. +gz above 0.03 B/BR/BRUMMETT/UR-0.43.tar.gz
use strict; use warnings; my ($line,$cnt,@cnt_file); #!/usr/bin/perl open (FILE,"file1"); @cnt_file = <FILE>; $cnt = @cnt_file; print "$cnt\n"; open (MYFILE,"file2"); $line = <MYFILE>; foreach $line (<MYFILE>) { print "$line" if $. >= $cnt; }

Need help with http 1.1 headers on LWP Host =>
"Some people, when confronted with a problem, think "I know, I'll use regular expressions." Now they have two problems." -- Jamie Zaqinski "You cannot parse XHTML with regex." -- bobince on StackOverflow
#!perl use strict; use warnings; $|++; my ($comp,$first,@sec); #$comp = "descr is ".(defined $first ? q{$first} : 'null').' and list +is '.( @sec ? q{join ' ', @sec} : 'empty'); $comp = q{descr is $first and list is @sec}; my $list = q{defined $sec[0] ? 'full' : 'empty'} ; print "$comp\n"; print eval "qq{$comp}","\n"; &mf('UNO'); &ms (1);&ms (2); &mf ('DUE'); &rs; sub mf{$first = shift; my $it = eval "qq{$comp $list} ";print $it." +\n"} sub ms {push @sec, shift; print eval "qq{$comp}","\n";} sub rs {@sec=qw(); print eval "qq{$comp}","\n";} #was print "$c +omp\n"; ######### http://www.perlmonks.org/?node_id=15380 my $n = sub {1}; my $m = sub {&$n*2}; my $o = sub {&$m*2}; my $s = sub {&$n." ".&$m." ".&$o."\n"}; print &$s; $n = sub {2}; print &$s; __DATA__ #from http://www.perlmonks.org/?node_id=15437 my $text = q{ Dear $person, I know that this text is $adjective. But I wish it could be... }; my $person = 'Mom'; my $adjective = 'not interpolated'; print eval "qq{$text}";
############################################################
use strict; use warnings; my $lines = <<'EOT'; A named capture group. Identical in every respect to normal captu +ring parentheses () but for the additional fact that the group can be referred to by name in various regular expression con +structs (like \g{NAME} ) and can be accessed by name after a successful match via %+ or %- . See perlvar for more deta +ils on the %+ and %- hashes. If multiple distinct capture groups have the same name then the $+{NAM +E} will refer to the leftmost defined group in the match. The forms (?'NAME'pattern) and (?<NAME>pattern) are equivalent. NOTE: While the notation of this construct is the same as the similar +function in .NET regexes, the behavior is not. In Perl the groups are numbered sequentially regardless of being named or not. + Thus in the pattern EOT $lines=~s/^\s*(?!$)//gm; print $lines
dear chromatic,

thank you for writing the Modern Perl book: now i know that mine is baby Perl ;=)
I had no time to learn github so i'll put my typos review here.. sorry
May be something is here only because i do not understand well; excuse me.
I'll refer to the A4 pdf edition for page numbers.

i-introducing Test::More maybe better spends more wards about it's function, altough briefly.

100-middle She'll have to..
           He'll   or is omenage to someone?
118- has 'enbled' is -> 'ro' 
     has 'enbled' is -> 'rw' or i do not understand the (Note following
154- bottom line Yet Even 
                 Yet even
162-last par. The callee side 
              i think calee need explanation and maybe italic font 
165-at end of file slurp: The second example... this line is obscure..
168-bottom the last 2 lines begin with ] and, probably, a comment by someone.. 

again thank you.. the better Perl's book after many years..

L*

PS if i'll have time i want to write a little review of the book here
 
 

Ten years...

Ten years are passed from my entrance in the monasterium. maybe time flies when you are amusing.. or time flies anyway.. the fastest decade ever!

My first problem was about traversing a directory tree and i'm still remember my head boiling imagining a recursive algorithm.

The solution heard in the monastery was so simple that I was impressed.

I'm think about me as a newbie in Perl, but ten years here and near the compiler make me a skilful one.

I used Perl in many many different environment and with etherogeneous purposes: Win32 sysadmin, CGI, databases, Tk, linux sysadmin, LWP, some math and fun.. Here I ever found some big ol' monk suggesting the right thing, quickly and friendly.

In last ten years few think are still solid point in this floating reality: my woman, my kawasaki gpz and PerlMonks; I learned the order of priorities may be confused if you not follow The Twelves Pillars Of Wisdom..


Here you can walk in the cloister and hazard to asks some wise one about strange, until you know the truth, Perl's feature (like the uppercaseness of %ENV's keys on win32, or the prefilled input using Term::ReadLine), or hear discussion about storing log as video file to enjoy the compression, or whisper about hexagonal tessellation in Tk and having back a working program in two days..

Here you can search back in the time and find old answer that still works for an enormous amount of problems.

Here you can rediscover that Perl'programmers are still humans (minus some one that only play one on Earth server): may be one day someone is nervous or sad or upset.. but everyday is here creatively.

Here I have meet a lot of people; the monastery was my only netplace ever. Some monk is lost during this years, few one physically too.. we miss them all.

HereI discovered the escathological doctrine of Perl6 (i heard it can write bytecode to stones for a geological later retrieve..) waiting the future revenge of Perl on the rest of the IT.

Here i saw little hashes grow and reference themselves and become objects, blessed by Some::Class, and object becomes transparent, translucent, singletons or insideout ones (it everytime remind me the poor babuin of 'the Fly' movie..).. and as you turn your eyes:"Eeek a Moose!".

Here you can have the folgoration that Perl let you to be near the compiler so you can evaluates what you want (arbitrium).

Here you learn how laziness is an hard work.

Here, if you are hungry, you go down in the kitchen and choose some DBI recipe that suit your taste.

Here you wake up and peoples from everywhere greet you with a "good localtime(time)!".

So monks i very pleased this Ten Years... Thank you to all!
Urrah! Urrah!


L*



------------- ten years... ten years are passed from my entrance in the monasterium. maybe time flies when you are amusing.. or time flies anyway. My first problem was about traversing a directory tree and i'm still remember my head boiling imagining a recursive algorithm. The solution eard in the monastery was so simple that I was impressed. I'm think about me as a newbie in Perl, but ten years here and near the compiler make me a skilfull one. I used Perl in many many different environement and with etherogeneous purposes: Win32 sysadmin, CGI, databases, Tk, linux sysadmin, LWP, some math and fun.. Here I ever found some big ol' monk suggesting the rigth thing, quickly and friendly. Here you can walk in the cloister and hazard to aks some wise one about strange, until you know the truth, perl feature (like the uppercaseness of %ENV's keys on win32, or the prefilled input using Term::ReadLine), or ear discussion about storing log as video file to enjoy the compression, or whisper about hexagonal tasselation in Tk and having back a working program in two days.. Here you can search back in the time and find old answer that still works for an enourmous amount of problems. Here you can rediscover that Perl'programmers are still humans (minus some one that only play one on Earth server): may be one day someone is nervous or sad or upset.. but everyday is here creatively. Some one is lost during this yaers, few one phisically too.. we miss them all. Here I learned the escathological doctrine of perl6 (i eard it can write bytecode to stones for a geolocical later retrieve..) waiting the future revenge of Perl on the rest of the IT. Here i saw little hashes grow and reference themselves and become objects, blessed by Some::Class, and object becomes transparent, translucid, singletons or insideout ones (it everytime remind me the poor babuin of 'the Fly' movie..).. and as you turn your eyes:"Eeek a Moose!". Here you can have the folgoration that Perl let you to be near the compiler so you can evaluates what you want (arbitrium). Here you learn how laziness is an hard work. Here if you are hungry, you go down in the cook room and choose some DBI recipe that suit your taste.


Dear zentara, I was fast-att-hacking-and-paste some code to display jpg photos and, as you can see, I get this pics dinamically and I fetch their dimensions,url and comment. I' want this acting in a fullscreen mode with pics smaller than the screen ($sx $sy >= $px $py) well centered with an elegant black bg and pics bigger to be resized. this code works quite but the tk part is a horrible and buggy (it does not take the focus when a new pic is on..) thanks a lot Lorenzo
#!/usr/bin/perl -w use REST::Client; use JSON; use Data::Dumper; use LWP::Simple; use Tk; use Tk::JPEG; use constant DELAY => 1000; my $index = 0; my $client = REST::Client->new(); $client->GET('http://www.panoramio.com/map/get_panoramas.php?order=po +pularity&set=public&from=0&to=100&minx='.$ARGV[0].'&miny='.$ARGV[1].' +&maxx='.$ARGV[2].'&maxy='.$ARGV[3].'&size=original'); my $aoh = decode_json $client->responseContent(); my @urls; #print Dumper $aoh; foreach my $pic(@{$aoh->{photos}}) { print "$pic->{photo_file_url}\n"; print "$pic->{photo_title}\n"; print "$pic->{latitude} $pic->{longitude} ($pic->{width +}x$pic->{height})\n\n"; push @urls,$pic->{photo_file_url}; } ###################################################################### +########## my $mw = new MainWindow(-background=>'black'); #$mw->FullScreen(1); #$mw->geometry($mw->screenwidth . 'x' . $mw->screenheight . '+0+0'); my $sx =$mw->screenwidth; my $sy =$mw->screenheight; my $image = $mw->Photo(); #qw/-width 800 -height 600/ $mw->bind('all' => '<Key-Escape>' => sub {exit;}); $mw->Button(-image => $image,-background => 'black')->pack(-side => "t +op", -fill=> "both"); $mw->after(DELAY, \&next_image); MainLoop; ###################################################################### +########## sub next_image { $image->blank(); my $file = &download(${$aoh->{photos}}[$index]{photo_file_url}); my $title = ${$aoh->{photos}}[$index]{photo_title}; my $px = ${$aoh->{photos}}[$index]{width}; my $py = ${$aoh->{photos}}[$index]{height}; print "NEXTIMG: $px x $py\n"; if (eval {$image->read($file,-shrink); 1}) { if ($px >= $sx and $py >= $sy ) { print "SUBSSAMPLING: $px/$sx , $py/$sy: ",$px/$sx,' ',$py/$s +y,"\n"; $image->copy($image, -subsample => ( int ($px/$sx),int + ($py/$sy) )); #, $py/$sy } else { #$image->copy($image, -zoom => ( 2,2)); } $mw->configure(-title => $title,-width=>$px, -height=> $py); + #,-width=>$x, -height=> $y $mw->after(DELAY, \&next_image) if (++$index <= $#{$aoh->{phot +os}}); } else { $mw->after(0, \&next_image) if (++$index <= $#{$aoh->{photos}} +); } } sub download{ my $url=shift; print "RECEIVING: $url\n"; mirror ($url, 'file.jpg'); return 'file.jpg' }
while (<DATA>){ chomp; my @temp = split /\?/,$_; $ipmatch = $temp[0] ; #unless defined $ipmatch; next unless $temp[4] eq 'Started'; $dati{$.} = { webnum=>$temp[1], alias => { map {$_ => &risolvi( $_ )} split / +/,$temp[12] } , }; } sub risolvi{ my $host = shift; my $dnsserver = '122.211.222.221'; my @arr; open DNS, "nslookup $host $dnsserver 2>&1|"||die; while (<DNS>) {push @arr, $_} if ($arr[0]=~/\s*Non-existent domain/ ){return ("NON-EXI +STENT-DOMAIN")} elsif ($arr[0]=~/Non-authoritative answer:/ ) {$arr[5]=~ +/\s*(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})/;return ("NON-AUTH: $1")} elsif ($arr[4]=~/\s*(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}) +/ ){return $1;} else {return ("????")} close DNS; } __DATA__ 999.110.136.999?50?www.google.it?usr1?Started?c:\webroot\google?172517 +?NA??--?--?--?www.google.it www.google.com www.google.org ?? 999.110.136.999?51?www.fedoracore.it?usr2?Started?c:\webroot\thebossma +nagement?835304?NA??--?--?--?www.fedoracore.it ?? #!perl use strict; use warnings; use GD; use GD::Polyline; # create an image use GD::Text::Align; my $image = new GD::Image (1024,768); my $align = GD::Text::Align->new($image, valign => 'top', halign => 'left', ); ################### COLORI my $gray = $image->colorAllocate(127,127,127); my $white = $image->colorAllocate(255,255,255); my $black = $image->colorAllocate( 0, 0, 0); my $red = $image->colorAllocate(255, 0, 0); $image->setThickness(1); ################### COSTANTI my $pig = 3.141592653589793238462643383279502884197169399375; my $radius = 90; my $apo = ($radius*sqrt(3))/2; ################### initial positioN of the center my $xc = 512; my $yc = 384; my $vertex= 6; ################### MAIN #### &hexagon($xc,$yc); print "original coord: $xc -- $yc\n-------------\n"; $align->set_text("X"); $align->draw($xc,$yc,0); foreach my $cardinal (qw(N NE SE S NO SO)) { my ($xc2, $yc2) = &vicini ($xc,$yc,$cardinal,1); #$yc2=sprintf("%10.3f",$yc2);#CORREZIONE print "$cardinal coord: $xc2 -- $yc2\n"; $align->set_text($cardinal); $align->draw($xc2,$yc2,0); &hexagon($xc2,$yc2); } &disegna; ############################################################ sub hexagon { my $xc = shift; my $yc = shift; my $poly = new GD::Polygon; foreach my $i (0..5 ){ my $newX=$xc+($radius*cos($i*2 *$pig/$vertex)); my $newY=$yc+($radius*sin($i*2 *$pig/$vertex)); $poly->addPt( $newX, $newY); $align->set_text(" $i "); $align->draw($newX,$newY,0); } $image->polydraw($poly,$black); #my @vertices = $poly->vertices; } ############################################################ sub disegna { open PNG, ">testHEX2.jpeg"; select PNG; binmode PNG; print $image->jpeg(100); } ############################################################ sub vicini { my $xc = shift; my $yc = shift; my $quale = shift; my $dist =shift||1; my %vicini = ( SE => sub{my $xc2 = $xc+($radius*3/2) *$dist; my $yc2 = $yc+ $apo *$dist; return($xc2,$yc2)}, NE => sub{my $xc2 = $xc+($radius*3/2) *$dist; my $yc2 = $yc- $apo *$dist; return($xc2,$yc2)}, N => sub{my $xc2 = $xc; my $yc2 = $yc- $apo*2 *$dist; return($xc2,$yc2)}, S => sub{my $xc2 = $xc; my $yc2 = $yc+ $apo*2 *$dist; return($xc2,$yc2)}, NO => sub{my $xc2 = $xc-($radius*3/2) *$dist; my $yc2 = $yc- $apo *$dist; return($xc2,$yc2)}, SO => sub{my $xc2 = $xc-($radius*3/2) *$dist; my $yc2 = $yc+ $apo *$dist; return($xc2,$yc2)}, ); return &{$vicini{$quale}}($xc,$yc); }
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others chilling in the Monastery: (9)
As of 2014-12-26 08:10 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (168 votes), past polls