Dear Corion,
This is perl 5, version 24, subversion 1 (v5.24.1)
t/50-gh63-encode-response-content.t ........... Possible unintended in
+terpolation of @50 in string at t/50-gh63-encode-r
esponse-content.t line 49.
t/50-gh63-encode-response-content.t ........... 1/4
Terminating on signal SIGINT(2)
Terminating on signal SIGINT(2)
Caught SIGINT. Trying to quit ...
dmake.exe: Warning: -- dmake.exe: Error code 130, while making 'test
+_dynamic'
Internal Warning: finished pid 12 is not in pq!?Signal SIGINT received
+, but no signal handler set.
Terminare il processo batch (S/N)? s
#################
dear Athanasius
#raku
<Discipulus> hello folks!
<Discipulus> I read on perlmonks an interesting question about raku on windows
<Discipulus> it seems that raku expand * passed in the command line as glob fo surdir filenames
<Discipulus> *as glob of curdir filenames
<Discipulus> cmd.exe was always unable to expand * so it must be raku
<Discipulus> details: [Raku] Asterisk on DOS command line
<El_Che> don't people use a capable terminal on Windows nowadays? I hear there is even one created by MS
<El_Che> https://github.com/microsoft/terminal
<Discipulus> eh eh.. evidently not
<Discipulus> but the question is valid: must be something on raku side to the glob and I cant find it documented
<El_Che> it looks to me that raku does what's expected
<El_Che> and the poster should quote correctly
<El_Che> (for instance perl works on the same way on Linux als raku)
<Discipulus> mmhh..
<Discipulus> args are not processed by the shell ?
<El_Che> this is the entry point: https://github.com/rakudo/rakudo/blob/master/src/main.nqp#L57
<Discipulus> for the little I understand nothing is done there. So where the expansion of * happens?
<Scimon> Is the raku command on windows a batch file wrapping a call to the VM? Might it be in there? (I'm on Linux ATM so can't check).
# here in CB
Discipulus: args passed to perl on commandline are processed by the shell, right?
Discipulus: [Raku Asterisk on DOS command line] is surprising me
Corion: Discipulus: This is usually some "helpful" re-globbing by either the program or the invoking shell
Corion: (but as cmd.exe is supposed to be the shell, it must be Rakudo being "helpful" here)
Discipulus: Corion it was the same I imagined but someone pointed me to this entry point which seems unoffensive to me
choroba: what does command_line do?
Corion: It's inherited from somewhere ("HLLCompiler"), and I can't find that source code
Corion: (supposedly it comes somewhere from Parrot, but I'm not sure that Raku-on-JVM uses Parrot anywhere still...)
###############
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8" />
<meta name="viewport" path1tent=
"width=device-width,
initial-scale=1.0" />
<script src="https://d3js.org/d3.v5.js"></script>
</head>
<body>
<style>
circle {
stroke: #05668D;
fill: white;
opacity: 0.6;
stroke-width: 2px;
}
path {
fill: none;
stroke: #05668D;
opacity: 0.6;
stroke-width: 2px;
}
</style>
<svg>
<g></g>
</svg>
<script>
var vWidth = 300;
var vHeight = 200;
console.log("Hello world ONE!");
// Prepare our physical space
var g = d3.select('svg').attr('width', vWidth).attr('height', vHei
+ght)
.select('g').attr('transform', 'translate(20,20)');
console.log(g);
// Get the data from our CSV file
d3.json('data.json', function(error, vData) {
console.log(error);
console.log("Hello world!");
if (error) throw error;
drawViz(vData);
});
function drawViz(vData) {
console.log(vData);
console.log('pluto');
// Declare d3 layout
var vLayout = d3.tree().size([vHeight * 0.9, vWidth * 0.8]);
// Layout + Data
var vRoot = d3.hierarchy(vData);
var vNodes = vRoot.descendants();
var vLinks = vLayout(vRoot).links();
// Draw on screen
g.selectAll('path').data(vLinks).enter().append('path')
.attr('d', d3.linkHorizontal()
.x(function(d) { return d.y; })
.y(function(d) { return d.x; }));
g.selectAll('circle').data(vNodes).enter().append('circle')
.style('r', 10)
.attr('transform', function (d) { return 'translate(' + d.
+y + ',' + d.x + ')'; });
}
</script>
pippo pluto
</body>
</html>
#########################
Dear haukex,
it can be accomplished using Symbol (poor docs..)
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 assigne
+d 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 intereste
+d
<simcop2387> wagnerc: sometimes you'd setup ssi for cgi output too!
<PavelB> that sounds terrifying and insecure
<hobbs> not terribly
<mst> hobbs: I don't think I've ever in my life been in a situation wh
+ere I was responsible for deployments and there wasn't anything 'not
+normal' involved :P
<wagnerc> I remember when that was how you put a counter on your web p
+age :D
<wagnerc> execute a C program.
<wagnerc> sim, CGI and then SSI??
<PavelB> > execute a C program.
<PavelB> Hey, people are starting to that again! With webassembly this
+ time, though
<simcop2387> wagnerc: yea, because the adserver stuff was all SSI base
+d
<wagnerc> The Great Wheel turns inexoribly.
<wagnerc> But SSI is how we got PHP. :)
* daxim has quit (Quit: WeeChat 2.3)
<PavelB> also these days we have people serving up their entire app in
+ a gig of client-side js :(
<simcop2387> i can't wait for WASI to really start getting it's feet o
+n the ground. it'll make for some really interesting deployment stuf
+f
<PavelB> WASI?
<simcop2387> https://www.infoq.com/news/2019/04/wasi-wasm-system-inter
+face
<simcop2387> and no that's not an april fools day joke
<PavelB> Ok cool 'cause wikipediaing it brought me to Wechsler Abbrevi
+ated Scale of Intelligence
<wagnerc> Mozilla .NET :D
<simcop2387> wagnerc: basically :) once it gets further I'm *really*
+tempted to try to get perl running under it
<PavelB> honestly webassembly sounds like java or silverlight but "Thi
+s time it won't have all those security flaws because *we* made it"
<wagnerc> Why haven't you implemented Perl in JavaScript yet??
<simcop2387> wagnerc: someone else beat me to it
<simcop2387> https://webperl.zero-g.net/
<wagnerc> XD
<PavelB> Will this initiative to run perl under wasm include getting x
+s modules to run under wasm
<PavelB> 'cause that seems hard
<simcop2387> wasi will be a bit different
<simcop2387> PavelB: that'd be the idea, it should be doable
<PavelB> I don't know how you can translate arbitrary C into WASM
<PavelB> The way I see it you'd have to adapt the source of every XS m
+odule you want to use
<wagnerc> That doesn't look like a Perl implementation. It looks like
+a script server.
<wagnerc> http://blog.builtinperl.com/post/5-major-websites-that-use-p
+erl
<simcop2387> wagnerc: it's a port of perl to WASM that then lets you u
+se it as the scripting language for html
<simcop2387> 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 W
+ASI is intending to do.
<simcop2387> 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)
<PavelB> There's C you've written to target WASM specifically, and the
+re's arbitrary C
<simcop2387> they're the same
<simcop2387> WASM doesn't require special casing of things
<PavelB> What happens if you try to dynamically link a library?
<simcop2387> that's not a C thing, that's a platform thing
<simcop2387> which is the kind of thing that WASI is targeting
<simcop2387> C itself doesn't know a damned thing about linking.
choroba: the latest versione did not run anymore here:
Global symbol "$VERSION" requires explicit package name (did you forge
+t 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.
dear Athanasius,
The dclone is not about nested structures but about shallow/deep:
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, becau
+se 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();
Maybe the title (or the content) of the categorized answer should explain the matter in a deeper ( ;) way
L*
git-client> git request-pull master https://github.com/LorenzoTa/Win32
+-Backup-Robocopy
warn: No match for commit 9b2300bc640ab759adeac6ffb206d82c23d0d5d6 fou
+nd at https://github.com/LorenzoTa/
Win32-Backup-Robocopy
warn: Are you sure you pushed 'HEAD' there?
The following changes since commit d7473d06cfb9b2043877a430563b90aa3ec
+7a0b2:
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 9b2300bc640ab759adeac6ffb206d82c23d0d5d
+6:
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 <file>..." to update what will be committed)
(use "git checkout -- <file>..." to discard changes in working direc
+tory)
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 <file>..." to update what will be committed)
(use "git checkout -- <file>..." to discard changes in working direc
+tory)
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 <file>..." to update what will be committed)
(use "git checkout -- <file>..." to discard changes in working direc
+tory)
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>
Lanx:if interested the behaviour is the same with different module version and different strawberry versions:
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
Also note that both $sth and $lines are reported as introduced in line 2 that is not true
with your original program the output is:
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
hope this helps
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);
#$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
|