pippo pluto #### use strict; use warnings; use Symbol qw(geniosym); my $FH = 'scalar'; open FH,'>','test.txt' or die; print "File n. of FH before: ", fileno FH , $/ ; *FH = geniosym; # as choroba noted the following 2 statements are not useful. # for sure I dont understand the docs: # Symbol::geniosym creates an anonymous IO handle. This can be assigned into an existing glob without affecting the non-IO portions of the glob. # # undef $::{FH}{IO}; # delete $::{FH}{IO}; print "File n. of FH after: ",( fileno FH ? fileno FH : '-NA-'), $/ ; print "SCALAR slot of FH: ",$FH, $/; #### $n=4; print $n." -- ".(--$n,($n||'no more')).".\n" while $n; __END__ sub b{' bottle'.($n==1?'':'s').' of beer'} $w=' on the wall'; $n=99;print$n.b.$w.', '.$n.b.".\nTake one down and pass it around, ".(--$n,($n||'no more').b.$w).".\n\n"while$n; print"No more".b."$w, no more".b.".\nGo to the store and buy some more, 99".b."$w." #output on 5.28 98 bottles of beer on the wall, 98 bottles of beer. Take one down and pass it around, 98 bottles of beer on the wall. ... 1 bottles of beer on the wall, 1 bottles of beer. Take one down and pass it around, 1 bottle of beer on the wall. 0 bottle of beer on the wall, 0 bottle of beer. Take one down and pass it around, no more bottles of beer on the wall. No more bottles of beer on the wall, no more bottles of beer. Go to the store and buy some more, 99 bottles of beer on the wall. #### # more above but I suppose not so much related but ask me if interested wagnerc: sometimes you'd setup ssi for cgi output too! that sounds terrifying and insecure not terribly hobbs: I don't think I've ever in my life been in a situation where I was responsible for deployments and there wasn't anything 'not normal' involved :P I remember when that was how you put a counter on your web page :D execute a C program. sim, CGI and then SSI?? > execute a C program. Hey, people are starting to that again! With webassembly this time, though wagnerc: yea, because the adserver stuff was all SSI based The Great Wheel turns inexoribly. But SSI is how we got PHP. :) * daxim has quit (Quit: WeeChat 2.3) also these days we have people serving up their entire app in a gig of client-side js :( i can't wait for WASI to really start getting it's feet on the ground. it'll make for some really interesting deployment stuff WASI? https://www.infoq.com/news/2019/04/wasi-wasm-system-interface and no that's not an april fools day joke Ok cool 'cause wikipediaing it brought me to Wechsler Abbreviated Scale of Intelligence Mozilla .NET :D wagnerc: basically :) once it gets further I'm *really* tempted to try to get perl running under it honestly webassembly sounds like java or silverlight but "This time it won't have all those security flaws because *we* made it" Why haven't you implemented Perl in JavaScript yet?? wagnerc: someone else beat me to it https://webperl.zero-g.net/ XD Will this initiative to run perl under wasm include getting xs modules to run under wasm 'cause that seems hard wasi will be a bit different PavelB: that'd be the idea, it should be doable I don't know how you can translate arbitrary C into WASM The way I see it you'd have to adapt the source of every XS module you want to use That doesn't look like a Perl implementation. It looks like a script server. http://blog.builtinperl.com/post/5-major-websites-that-use-perl wagnerc: it's a port of perl to WASM that then lets you use it as the scripting language for html PavelB: you can absolutely do C in WASM, that's kinda the point. there's a number of system interfaces (i.e. sockets, files, etc.) that need to exist to do any arbitrary stuff, and that's what WASI is intending to do. you probably wouldn't get things like mmap and other low-level system stuff but that's not a big deal * theory has quit (Quit: theory) There's C you've written to target WASM specifically, and there's arbitrary C they're the same WASM doesn't require special casing of things What happens if you try to dynamically link a library? that's not a C thing, that's a platform thing which is the kind of thing that WASI is targeting C itself doesn't know a damned thing about linking. #### Global symbol "$VERSION" requires explicit package name (did you forget to declare "my $VERSION"?) at D:/ulisseDUE/perl5.26.64bit/perl/site/lib/Tk/Frame.pm line 16, <__ANONIO__> line 21. Compilation failed in require at D:/ulisseDUE/perl5.26.64bit/perl/lib/base.pm line 100, <__ANONIO__> line 21. ...propagated at D:/ulisseDUE/perl5.26.64bit/perl/lib/base.pm line 109, <__ANONIO__> line 21. BEGIN failed--compilation aborted at D:/ulisseDUE/perl5.26.64bit/perl/site/lib/Tk/Toplevel.pm line 10, <__ANONIO__> line 21. Compilation failed in require at D:/ulisseDUE/perl5.26.64bit/perl/lib/base.pm line 100, <__ANONIO__> line 21. ...propagated at D:/ulisseDUE/perl5.26.64bit/perl/lib/base.pm line 109, <__ANONIO__> line 21. BEGIN failed--compilation aborted at D:/ulisseDUE/perl5.26.64bit/perl/site/lib/Tk/MainWindow.pm line 5, <__ANONIO__> line 21. Compilation failed in require at D:/ulisseDUE/perl5.26.64bit/perl/site/lib/Tk.pm line 192, <__ANONIO__> line 21. Compilation failed in require at D:/ulisseDUE/pm-cb-Mar2019/lib/PM/CB/GUI.pm line 38, <__ANONIO__> line 21. #### use strict; use warnings; use Storable qw(dclone); use Test::More; my %nested = ( a => { b=> 2, c=>3, d=>4}, e => { f => 6} ); my %copy1 = %nested; is_deeply( \%nested,\%copy1, "plain hash copies are equal" ); my %nested_with_refs = ( g => 7, h => \%nested, ); my %copy_with_refs = %nested_with_refs; is_deeply( \%nested_with_refs,\%copy_with_refs, "hash with references copies are equal" ); my $ref = \%nested_with_refs; my %ref_copy = %{$ref}; is_deeply( \%nested_with_refs,\%ref_copy, "reference and hash with references copies are equal" ); # original example: my %hash = (); $hash{a}{drinks}=1; $hash{b}{drinks}=2; my $p = \%hash; my %copy = %{ $p }; is_deeply( \%hash,\%copy , "also original example copies are equal" ); $copy{a}{drinks}=4; is_deeply( \%hash,\%copy , "also after changing \$copy{a}{drinks} copies are equal, because share the same ref" ); my $deep_copy_ref = dclone(\%hash); is_deeply( \%hash, $deep_copy_ref , "dclone copies are equal" ); $hash{a}{drinks} = 444; # this now fails is_deeply( \%hash, $deep_copy_ref , "THIS WILL FAIL: dclone copies are equal" ); # until.. $$deep_copy_ref{a}{drinks} = 444; is_deeply( \%hash, $deep_copy_ref , "dclone copies are equal again" ); done_testing(); #### git-client> git request-pull master https://github.com/LorenzoTa/Win32-Backup-Robocopy warn: No match for commit 9b2300bc640ab759adeac6ffb206d82c23d0d5d6 found at https://github.com/LorenzoTa/ Win32-Backup-Robocopy warn: Are you sure you pushed 'HEAD' there? The following changes since commit d7473d06cfb9b2043877a430563b90aa3ec7a0b2: used module bkpscenario in test 09 (2018-12-30 16:00:57 +0100) are available in the Git repository at: https://github.com/LorenzoTa/Win32-Backup-Robocopy for you to fetch changes up to 9b2300bc640ab759adeac6ffb206d82c23d0d5d6: pod for restore (2019-01-04 21:54:59 +0100) ---------------------------------------------------------------- LorenzoTa (15): some clean some clean restore mode 1 more restore more restore 2 history restore changed return val from restore typos and _validate_upto added test validate_upto added 11-restorehistory.t last line fixed restore upto used check_last_line in test 10 fixed verbose restore upto pod for restore lib/Win32/Backup/Robocopy.pm | 273 +++++++++++++++++++++++++++++++++---------- t/02-run.t | 4 +- t/03-job.t | 4 +- t/04-runjobs.t | 4 +- t/05-writeconf.t | 4 +- t/06-loadconf.t | 4 +- t/07-listjobs.t | 4 +- t/09-runjobs-ranges.t | 4 +- t/10-restore.t | 120 +++++++++++++++++++ t/11-restorehistory.t | 137 ++++++++++++++++++++++ t/bkpscenario.pm | 35 ++++-- 11 files changed, 512 insertions(+), 81 deletions(-) create mode 100644 t/10-restore.t create mode 100644 t/11-restorehistory.t #### C:\Users\io\gittest2>git status On branch master nothing to commit, working tree clean C:\Users\io\gittest2>git checkout newbr Switched to branch 'newbr' C:\Users\io\gittest2>git status On branch newbr nothing to commit, working tree clean C:\Users\io\gittest2>echo TRE >> file1 C:\Users\io\gittest2>git status On branch newbr Changes not staged for commit: (use "git add ..." to update what will be committed) (use "git checkout -- ..." to discard changes in working directory) modified: file1 no changes added to commit (use "git add" and/or "git commit -a") C:\Users\io\gittest2>git checkout master error: Your local changes to the following files would be overwritten by checkout: file1 Please commit your changes or stash them before you switch branches. Aborting #################### # OK #################### C:\Users\io\gittest2>git status On branch newbr Changes not staged for commit: (use "git add ..." to update what will be committed) (use "git checkout -- ..." to discard changes in working directory) modified: file1 no changes added to commit (use "git add" and/or "git commit -a") C:\Users\io\gittest2>git commit -a -m "third line" [newbr 3573539] third line 1 file changed, 1 insertion(+) C:\Users\io\gittest2>git checkout master Switched to branch 'master' C:\Users\io\gittest2>echo FROM MASTER >> file1 C:\Users\io\gittest2>git commit -a -m "from master" [master d55d746] from master 1 file changed, 1 insertion(+) C:\Users\io\gittest2>git checkout newbr Switched to branch 'newbr' C:\Users\io\gittest2>git status On branch newbr nothing to commit, working tree clean C:\Users\io\gittest2>echo FROM NEWBR 1 >> file1 C:\Users\io\gittest2>git status On branch newbr Changes not staged for commit: (use "git add ..." to update what will be committed) (use "git checkout -- ..." to discard changes in working directory) modified: file1 no changes added to commit (use "git add" and/or "git commit -a") C:\Users\io\gittest2>git commit -a -m "from newbr" [newbr b774b92] from newbr 1 file changed, 1 insertion(+) C:\Users\io\gittest2>git checkout master Switched to branch 'master' # ok again C:\Users\io\gittest2>git checkout master Switched to branch 'master' C:\Users\io\gittest2>echo FROM MASTER 1 >> file2 C:\Users\io\gittest2>git add file2 C:\Users\io\gittest2>git commit -a -m"master 1" [master 489b9ee] master 1 1 file changed, 1 insertion(+) create mode 100644 file2 C:\Users\io\gittest2>type file2 FROM MASTER 1 C:\Users\io\gittest2>echo FROM MASTER 2 >> file2 C:\Users\io\gittest2>git commit -a -m"master 2" [master f9721b9] master 2 1 file changed, 1 insertion(+) C:\Users\io\gittest2>type file2 FROM MASTER 1 FROM MASTER 2 C:\Users\io\gittest2>git branch new C:\Users\io\gittest2>git checkout new Switched to branch 'new' C:\Users\io\gittest2>type file2 FROM MASTER 1 FROM MASTER 2 C:\Users\io\gittest2>echo FROM NEW 1 >> file2 C:\Users\io\gittest2>echo FROM NEW 2 >> file2 C:\Users\io\gittest2>git commit -a -m"new 1" [new dc62b5e] new 1 1 file changed, 2 insertions(+) C:\Users\io\gittest2>git checkout master Switched to branch 'master' C:\Users\io\gittest2>type file2 FROM MASTER 1 FROM MASTER 2 C:\Users\io\gittest2>git checkout new Switched to branch 'new' C:\Users\io\gittest2>type file2 FROM MASTER 1 FROM MASTER 2 FROM NEW 1 FROM NEW 2 C:\Users\io\gittest2>git checkout master Switched to branch 'master' C:\Users\io\gittest2>echo FROM MASTER 3 >> file2 C:\Users\io\gittest2>type file2 FROM MASTER 1 FROM MASTER 2 FROM MASTER 3 C:\Users\io\gittest2>git checkout new error: Your local changes to the following files would be overwritten by checkout: file2 Please commit your changes or stash them before you switch branches. Aborting C:\Users\io\gittest2>git commit -a -m"master 2" [master 73a0135] master 2 1 file changed, 1 insertion(+) C:\Users\io\gittest2>git checkout new Switched to branch 'new' C:\Users\io\gittest2>type file2 FROM MASTER 1 FROM MASTER 2 FROM NEW 1 FROM NEW 2 C:\Users\io\gittest2> #### general>check_perl_distro -e "use B::Xref; print $B::Xref::VERSION,$/;" | 1.07 [OK] D:\ulisseDUE\perl5.28.32bit\perl\bin\perl.exe | 1.05 [OK] D:\ulisseDUE\perl5.20.64bit\perl\bin\perl.exe | 1.05 [OK] D:\ulisseDUE\perl5.22.64bit\perl\bin\perl.exe | 1.05 [OK] D:\ulisseDUE\perl5.24.64bit\perl\bin\perl.exe | 1.06 [OK] D:\ulisseDUE\perl5.26.64bit\perl\bin\perl.exe | 1.06 [OK] D:\ulisseDUE\perl-5.26.64bit-PDL\perl\bin\perl.exe #### general>check_perl_distro -MO=Xref,-r,-d tst_b_xref.pl | grep row tst_b_xref.pl syntax OK | tst_b_xref.pl (main) 7 (lexical) @ row used | tst_b_xref.pl (main) 9 (lexical) @ row intro [OK] D:\ulisseDUE\perl5.28.32bit\perl\bin\perl.exe tst_b_xref.pl syntax OK | tst_b_xref.pl (main) 7 (lexical) @ row used | tst_b_xref.pl (main) 9 (lexical) @ row intro [OK] D:\ulisseDUE\perl5.20.64bit\perl\bin\perl.exe tst_b_xref.pl syntax OK | tst_b_xref.pl (main) 7 (lexical) @ row used | tst_b_xref.pl (main) 9 (lexical) @ row intro [OK] D:\ulisseDUE\perl5.22.64bit\perl\bin\perl.exe tst_b_xref.pl syntax OK | tst_b_xref.pl (main) 7 (lexical) @ row used | tst_b_xref.pl (main) 9 (lexical) @ row intro [OK] D:\ulisseDUE\perl5.24.64bit\perl\bin\perl.exe tst_b_xref.pl syntax OK | tst_b_xref.pl (main) 7 (lexical) @ row used | tst_b_xref.pl (main) 9 (lexical) @ row intro [OK] D:\ulisseDUE\perl5.26.64bit\perl\bin\perl.exe tst_b_xref.pl syntax OK | tst_b_xref.pl (main) 7 (lexical) @ row used | tst_b_xref.pl (main) 9 (lexical) @ row intro [OK] D:\ulisseDUE\perl-5.26.64bit-PDL\perl\bin\perl.exe #### 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. #### #!/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.pl line 26. Subroutine decode redefined at test_decode01.pl line 23. abc #### # # $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); ... #### 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.pl line 26. Subroutine decode redefined at test_decode01.pl line 23. abc #### 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, $bottom \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 'write 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; } #### use strict; use warnings; @ARGV = grep {length $_} map {my @ar = split /\s/; shift @ar,"@ar"} map {split /\n/} <## #output preceded by pipe sign, Perl version below general>check_perl_distro -e "opendir $D, '.' or die $!; print !! fileno $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($s1)) ) 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 'Discepoli'); 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:/ulisse/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 = ; chomp $pkg; print "Enter some code in package $pkg.\nAt the end insert CRTL-Z on a empty line.\n"; my @in = ; 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; } } } #### 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]->att($_)} qw/initialtest mintestsize testlength threadsperurl/}, 'settings/upload' => sub { map {$$upld{$_} = $_[1]->att($_)} qw/initialtest maxchunkcount maxchunksize mintestsize ratio testlength 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-static.php"; my $rsp_servers = $ua->request (HTTP::Request->new (GET => $url_servers)); # ATTENTION the die was die "Cannot get config: " AND NOT get servers.. $rsp_servers->is_success or die "Cannot get servers ", $rsp_servers->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 'MSWin32';} $\="\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 EXISTS\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);} } #### #!perl use strict; use warnings; use Data::Dump::Streamer; use Term::ReadLine; # CPANnn would be impossible without a big ABuse of 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 before 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::UserAgent 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 all 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 readme files my @infos = "\nINFO:\n\n"; # infos about the file and help too # now feed @infos with headers from file while (<$cpanfh>){print "Processing data, please wait..\n" and last if /^$/;push @infos, $_} push @infos, $_ for "\n\n","USAGE: $0 [02packages.details.txt]\n\nNAVIGATION:\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 the current namespace's package\n", "? print this help\n","\nTAB completion enabled on all sub namespaces\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 element eval '$cpan->{\''. # start of cpan container; it ends before next = sign (join '\'}{\'', @names).'\'} ='.# expand names and vivifies BECAUSE there is an assignment '{'. # hasref start '"."=>$names[-1],'. # hasref . is name and .. is a ref to father '".."=> \%{$cpan'.(defined $ancestors[0] ?'->{\''.(join '\'}{\'', @ancestors ).'\'}':'').'},'. '"+"=> [$fields[1],$fields[2]],'. # hashref + is used for version and author path array '}; '; # hashref end }Dump $cpan; my $current = \%$cpan; # the current hashref namespace starts at top level 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 autocompletes 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 "-- press Enter to continue..";while (){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/'.$$current{'+'}->[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,sort 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]})," namespaces\n"; } #### #!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 (){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @names"; 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] ?'->{'.(join '}{', @ancestors ).'}':'').','.'},'. '"+"=> [$fields[1],$fields[2]],'. '}; '; # hashref end } Dump($cpan); } my $current = \%$cpan;&header($current); my @cur_names; while(){ 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 $current->{'.'}" : 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=~$skiprx;print "$k @{$current->{$k}{'+'}}\n"} if (defined $$current{'+'}->[0]) { print "$$current{'.'} ". ($$current{'+'}->[0]||'').#($$current{'+'}->[0] ? $$current{'+'}->[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]})," 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'}; #_=>'',__=>'' my $skiprx = qr/^\.{1,2}|\+$/; #our @names; &grow_tree; sub grow_tree { while (){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @names"; 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] ?'->{'.(join '}{', @ancestors ).'}':'').','.'},'. '"+"=> [$fields[1],$fields[2]],'. '}; '; # hashref end } Dump($cpan); } my $current = \%$cpan;&header($current); while(){ 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 $current->{'.'}" : 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=~$skiprx;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, keys %$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 (){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @names"; my $cur; my @ancestors = @names; pop @ancestors; #print "for '",(join '::',@names),"' ancestor is ",( $ancestors[$#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(){ chomp; #say +( defined $$current{_} ? $$current{_} : 'CPAN')," has ",(scalar@{[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; &header($current);} elsif($_ eq '__'){ ref $current->{__} eq 'HASH' ? say "ok father defined for $current->{_}" : 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 ",(scalar@{[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]})," namespaces\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 (){ chomp; my @fields = split /\s+/;#say "@fields"; my @names = split /::/, $fields[0];#say "names($#names): @names"; 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.tar.gz Abilities::Features 0.5 I/ID/IDOPEREL/Abilities-0.5.tar.gz Abilities::Scoped 0.2 I/ID/IDOPEREL/Abilities-0.2.tar.gz Abilities::Scoped::FAKE 0.2 I/ID/fake/Abilities-0.2.tar.gz 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 = ; $cnt = @cnt_file; print "$cnt\n"; open (MYFILE,"file2"); $line = ; foreach $line () { print "$line" if $. >= $cnt; } #### #!perl use strict; use warnings; $|++; my ($comp,$first,@sec); #$comp = "descr is ".(defined $first ? q{$first} : null').