Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Discipulus's scratchpad

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



perl -MList::Util="first" -E "@c[0..123456789]=(0..123456789);say for +grep{$e=eval $_;$c[$e]=undef if $e >=0;$h{$e}++;eval $_ == 100} glob +'{-,}'.join '{+,-,}',1..9;END{ say for (sort{ $h{$b}<=>$h{$a}}grep{$_ +>=0}keys %h)[0], first{defined $_}@c}" Out of memory! panic: gen_constant_list JMPENV_PUSH returned 2 at -e line 1.

wiki error

Won't update doctext as it appears the end marker has been truncated from the text. This could be because your browser cannot handle text fields as large as are needed.

for choroba

hello, dunno if I understood you fully; but I tried your sample code:

#!/usr/bin/perl use warnings; use strict; use Encode; sub decode { require Encode; Encode::decode('UTF-8', shift); } # output Prototype mismatch: sub main::decode ($$;$) vs none at test_decode01.p +l line 26. Subroutine decode redefined at test_decode01.pl line 23. abc

Then I modified ..perl5.26.64bit\perl\lib\Encode.pm as follow:

# # $Id: Encode.pm,v 2.92 2017/07/18 07:15:29 dankogai Exp dankogai $ # package Encode; use strict; use warnings; use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG}; our $VERSION; BEGIN { $VERSION = sprintf "%d.%02d", q$Revision: 2.92 $ =~ /(\d+)/g; require XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); } use Data::Dump; dd caller(1); ...

And so I get:

do { my $f = undef; ( "main", "D:/ulisse/perl5.26.64bit/perl/lib/Encode.pm", 0, "main::BEGIN", 1, $f, $f, $f, 2018, "UUUUUUUUUUUUUUUUU\5", $f, ); } Prototype mismatch: sub main::decode ($$;$) vs none at test_decode01.p +l line 26. Subroutine decode redefined at test_decode01.pl line 23. abc

best regards Discipulus

AutoLoader           5.74
C:::ulisse::str-5.26.0.1-32::perl::site::lib::auto::Tk::Frame::autosplit.ix
C:::ulisse::str-5.26.0.1-32::perl::site::lib::auto::Tk::Toplevel::autosplit.ix
C:::ulisse::str-5.26.0.1-32::perl::site::lib::auto::Tk::Widget::autosplit.ix
C:::ulisse::str-5.26.0.1-32::perl::site::lib::auto::Tk::Wm::autosplit.ix
C:::ulisse::str-5.26.0.1-32::perl::site::lib::auto::Tk::autosplit.ix
C:::ulisse::str-5.26.0.1-32::perl::site::lib::auto::Tk::getEncoding.al
Carp                 1.42
Config               5.026000
Config_git.pl
Config_heavy.pl
Cwd                  3.67
DynaLoader           1.42
Encode               2.89
Encode::Alias        2.21
Encode::Config       2.05
Encode::Encoding     2.07
Encode::Unicode      2.15
Exporter             5.72
Exporter::Heavy      5.72
Fcntl                1.13
File::Copy           2.32
File::Glob           1.28
File::RandomAccess   1.10
File::Spec           3.67
File::Spec::Unix     3.67
File::Spec::Win32    3.67
FileHandle           2.03
GD                   2.66
GD::Image            2.66
GD::Polygon
Getopt::Long         2.5
IO                   1.38
IO::File             1.16
IO::Handle           1.36
IO::Seekable         1.1
Image::ExifTool      10.55
List::Util           1.47
MIME::Base64         3.15
Pod::Escapes         1.07
Pod::Simple          3.35
Pod::Simple::BlackBox 3.35
Pod::Simple::LinkSection 3.35
Pod::Text            4.09
Pod::Usage           1.69
Portable             1.22
Portable::CPAN       1.22
Portable::Config     1.22
Portable::FileSpec   1.22
Portable::HomeDir    1.22
Portable::LoadYaml   1.22
Portable::minicpan   1.22
Scalar::Util         1.47
SelectSaver          1.02
Symbol               1.08
Time::HiRes          1.9742
Tk                   804.033
Tk::After            4.008
Tk::CmdLine          4.007
Tk::Configure        4.009
Tk::Derived          4.011
Tk::Event            4.033
Tk::Event::IO        4.009
Tk::Frame            4.010
Tk::Image            4.011
Tk::JPEG             4.003
Tk::MainWindow       4.015
Tk::Pane             4.007
Tk::Photo            4.006
Tk::Submethods       4.005
Tk::Toplevel         4.006
Tk::Widget           4.036
Tk::Wm               4.015
XSLoader             0.27
base                 2.25
bytes                1.05
constant             1.33
integer              1.01
overload             1.28
overloading          0.02
parent               0.236
strict               1.11
vars                 1.03
warnings             1.37
warnings::register   1.04

Wir hören von einer besondern Einrichtung bei der englischen Marine. Sämtliche Tauwerke der königlichen Flotte, vom stärksten bis zum schwächsten, sind dergestalt gesponnen, daß ein roter Faden durch das Ganze durchgeht, den man nicht herauswinden kann, ohne alles aufzulösen, und woran auch die kleinsten Stücke kenntlich sind, daß sie der Krone gehören. Ebenso zieht sich durch Ottiliens Tagebuch ein Faden der Neigung und Anhänglichkeit, der alles verbindet und das Ganze bezeichnet.

Goldberg Variations by Evgeni Koroliov

answer about is_mersenne_prime:

Yes, is_mersenne_prime is meant specifically for M numbers (see http://mathworld.wolfram.com/MersenneNumber.html for instance). It keeps the arguments native size and prevents dealing with invalid inputs (non-Mersenne numbers).

The GMP module does an LLR test as part of the standard primality routine, including noticing if k=1 then it can do a Lucas-Lehmer test. But that doesn't include the precalculated results shortcut.


perl -MMath::Prime::Util::GMP=":all" -E "@p=grep{is_prime($_)}1..1000; + say qq($p[$_] = ),$p[$_]-($p[$_-1]-1), (is_prime($p[$_]-$p[$_-1]-1)?' prime':'')for 1..$#p"

use warnings; use strict; use Win32::Console qw(GENERIC_READ GENERIC_WRITE); use Data::Dump qw(dd); my $con_current = Win32::Console->new(GENERIC_READ | GENERIC_WRITE); $con_current or die 'new Win32::Console failed'; my ($left, $top, $right, $bottom) = $con_current->Window; print "Dimensions (left top right bottom):",qq($left, $top, $right, $b +ottom \n); my $rect = $con_current->ReadRect($left, $top, $right, $bottom); $rect or die 'read Win32::Console failed'; #$rect =~ s{ \0\a\0 } ''xmsg; #$rect =~ s{ [ ]+ \z } ''xmsg; #dd $rect; print qq{======\nBefore writing anything from Win32.:Console\n======\n +}; $con_current->WriteRect($rect,$left, $top, $right, $bottom )or die 'wr +ite Win32::Console failed'; print "dd of \$rect: "; dd $rect; ###################################################################### use strict; use warnings; use GD; my $file = $ARGV[0]; die "Please feed a jpg file.." unless -e $file; my $orig_gd = GD::Image->new($file); my $photo_ratio = 0.3; my $small_w = int($orig_gd->width * $photo_ratio); my $small_h = int($orig_gd->height * $photo_ratio); draw_photo ($file); ###################################################################### +########## sub draw_photo { my $file_path = shift; # create the resized but still empty GD image my $resized = GD::Image->new($small_w,$small_h); # copy from source into resized on $resized->copyResampled($orig_gd,0,0,0,0, $small_w, $small_h, $orig_gd->width, $orig_gd->height); # save open my $out, '>', time.'.jpg' or die "unable to open for write"; binmode $out; print $out $resized->jpeg or die "unable to write jpg data!"; close $out; }

see for perl -s Parsing your script's command line http://www.perlmonks.org/?node_id=324749 perl -s is evil? http://www.perlmonks.org/?node_id=54671

and mine Re: how to check for a word in a file and if found remove previous and next -- 3 oneliner variations

use strict; use warnings; @ARGV = grep {length $_} map {my @ar = split /\s/; shift @ar,"@ar"} ma +p {split /\n/} <<EOF -f ftp-example.log -separator \s -regex PASS\s[^\d]+\s-\s530 -max 77 -wait 7 -position 1 -verbosity 3 -block_rule netsh advfirewall firewall add rule name=_NAME_ dir=in act +ion=block protocol=TCP localport=21 remoteip=_IP_ -unblock_rule netsh advfirewall firewall delete rule name=_NAME_ EOF ; 1;

#output preceded by pipe sign, Perl version below general>check_perl_distro -e "opendir $D, '.' or die $!; print !! file +no $D || !! $!;" | [OK] C:\ulisse\strawberry\perl\bin\perl.exe | [OK] C:\ulisse\straw64\perl\bin\perl.exe | [OK] C:\ulisse\straw5.20-32b\perl\bin\perl.exe | 1 [OK] C:\ulisse\strP5.22-32\perl\bin\perl.exe

# PICK ONE OF TWO OPEN OPTIONS BELOW #1#print STDERR "Option 1\n"; open($fh1, '>&', $fhSave) + or die "Can't restore fh1"; #2#print STDERR "Option 2\n";open($fh1, '>', \ substr($s1, length($s +1)) ) or die "Can't restore fh1";


#!perl use strict; use warnings; use Encode; use LWP::Simple; use XML::Twig; my $url = 'http://www.paginebianche.it/ricerca?qs='.($ARGV[0] or 'Disc +epoli'); my $t = XML::Twig->new(); #keep_encoding=>1 my $html = get ($url); #$html = encode('UTF-8', $html); # whit the line above i get: # not well-formed (invalid token) at line 3, column 549 +, byte 763 at C:/perl/vendor/lib/XML/Parser.pm line 187 # without it i got: # Cannot decode string with wide characters at C:/uliss +e/strawberry/perl/lib/Encode.pm line 196. $t->parse_html ($html);

#!perl use strict; use warnings; use Data::Dumper; $|++; use Term::Readline; #thanks http://perlmonks.org/?node_id=940134 $ENV{TERM} =''; my $term = Term::ReadLine->new('Package explorator'); my %cmds = ( 'pkg' => sub { print "Enter a package name:\n"; my $pkg = <STDIN>; chomp $pkg; print "Enter some code in package $pkg.\nAt the end insert CRT +L-Z on a empty line.\n"; my @in = <STDIN>; my $to_eval = "package $pkg {\n".(join "\n\t",@in)."}\n"; print "DEBUG:\n$to_eval\n\n"; { local $@; eval "$to_eval"; print "\n\nERROR:$@\n" if $@; } dump_symbols_of_package($pkg); }, 'dump' => sub { my $pkg = shift; dump_symbols_of_package($pkg); }, 'inspect' => sub { my ($pkg,$name,$slot) = @_; unless ($pkg && $name && $slot){ print "Please feed a package, a name and a slot.\n"; return; } inspect_slot ($pkg,$name,$slot); }, ); &user_input; ###################################################################### +########## sub user_input { $term->Attribs->{completion_function} = sub { my $txt = shift; return grep { /^$txt/i } sort keys %cmds; }; my $in; while ( defined( $in = $term->readline('Package Explorer>') ) ) { chomp($in); $in =~ s/^\s+//; my ( $cmd, @arg ) = split /\s+/, $in; next if !$cmd; ## if ( $cmd eq 'q' or $cmd eq 'x' ) { exit } #? #elsif ($in eq 'r'or $in eq 'b') {bench} elsif ( exists $cmds{$cmd} ) { $cmds{$cmd}->(@arg) } else { print "WARNING Command '$in' not recognized.\n"; next; } } }

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);<P> #$comp = "descr is ".(defined $first ? q{$first} : <C>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 "$comp\n"; ######### RE: RE: Re: Dreaming of Post Interpolation 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 Re: Dreaming of Post Interpolation my $text = q{ Dear $person, I know that this text is $adjective. But I

Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others lurking in the Monastery: (6)
As of 2018-06-18 08:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Should cpanminus be part of the standard Perl release?



    Results (109 votes). Check out past polls.

    Notices?