Rng
(for Discipulus)
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package My;
sub new {
return bless{ rng => $_[1] // sub { 1 + int rand($_[0]) } }, $
+_[0]
}
sub rand { $_[0]->{rng}($_[1]) }
}
my $o = 'My'->new();
say o => $o->rand(6) for 1 .. 7;
my @values = 1 .. 6;
my $i;
my $t = 'My'->new(sub { $values[$i++ % @values] });
say t => $t->rand(6) for 1 .. 7;
Order of Evaluation
(for haukex)
#!/usr/bin/perl
use strict;
use warnings;
use feature qw{ say };
{ package MyScalar;
use Tie::Scalar;
use parent -norequire => 'Tie::StdScalar' ;
sub FETCH { warn 'f'; $_[0]->SUPER::FETCH(@_[1..$#_]) }
sub STORE { warn "s$_[1]"; $_[0]->SUPER::STORE(@_[1..$#_]) }
}
tie my $s, 'MyScalar', 5;
say $s, $s = 4;
say "" . $s, $s = 3;
Benchmarking qr// versus /o
#! /usr/bin/perl
use warnings;
use strict;
use Benchmark qw{ cmpthese };
use Test::More;
print $], "\n";
open my $W, '<', '/var/lib/dict/words' or die;
my @words = <$W>;
close $W;
my $s = '(.)(.)(.)\3\2\1';
my $re = qr/$s/;
my $tab = {
re => eval qq<sub { grep /$s/, \@words }>,
qr => sub { grep /$re/, @words },
qro => sub { grep /$re/o, @words },
s => sub { grep /$s/, @words },
so => sub { grep /$s/o, @words },
};
my $n = $tab->{re}->();
is $tab->{$_}->(), $n, $_ for qw( qr qro s so );
done_testing();
cmpthese(-5, $tab);
decode
#!/usr/bin/perl
use warnings;
use strict;
sub decode {
require Encode;
Encode::decode('UTF-8', shift);
}
print decode('abc');
lvalue methods
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{
package My;
sub new { bless {}, shift }
sub attr () :lvalue { shift->{attr} }
}
my $o = 'My'->new;
$o->attr = 12;
say $o->attr;
For Lady_Aleena
#!/usr/bin/perl
use warnings;
use strict;
my @options;
if ('backport' eq $ARGV[0]) {
shift;
my $release = qx{ lsb_release -sc };
push @options, -t => "$release-backports";
}
system 'sudo', 'apt-get', @options, 'install', @ARGV;
Angry Fruit Salad
#! /usr/bin/perl
use warnings ;
use strict ;
sub setup {
my $self = shift ;
$self->start_mode('mode1') ;
$self->mode_param('rm') ;
$self->run_modes(
'mode1' => 'do_stuff' ,
'mode2' => 'do_more_stuff' ,
'mode3' => 'do_something_else'
) ;
}
For ww: Duplicate output
When using your inserts, I'm still not getting the output lines duplicated.
#! /usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use Syntax::Construct qw{ // };
use DBI;
my $db = 'DBI'->connect('dbi:SQLite:dbname=:memory:', q(), q(), {
RaiseError => 1,
});
$db->do(<< '__SQL__');
CREATE TABLE items (
ID INTEGER PRIMARY KEY AUTOINCREMENT,
link_id INTEGER,
item VARCHAR NOT NULL,
style VARCHAR)
__SQL__
$db->do(<< '__SQL__');
CREATE TABLE times (
ID INTEGER PRIMARY KEY AUTOINCREMENT,
link_id INTEGER,
time1 VARCHAR,
time2 VARCHAR,
location VARCHAR,
who VARCHAR,
note VARCHAR,
extra VARCHAR)
__SQL__
my $insert = $db->prepare(<< '__SQL__');
INSERT INTO items(link_id, item, style) VALUES(?, ?, ?)
__SQL__
$insert->execute(@$_) for
[ 1, 'Large RV Permit Holders must arrive', "H" ],
[ 2, 'Early Entry Permit Holders can arrive', "H"],
[ 3, 'Registration Gate ', "H"],
[ 4, 'Shuttle Bus Operates', "H"],
[ 42, 'The Science of Byurakan: The Golden Era of Soviet Astronomy
+', "A"],
[ 43, 'Astro Activities for Children', "K"],
[ 44, 'Stellafane New Horizons Project', "Y"],
[ 45, 'Scope Making For Teens', "Y"],
[ 46, 'Scope Making Demo', "T"];
$insert = $db->prepare(<< '__SQL__');
INSERT INTO times (link_id, time1, time2, location, who, note, extra)
VALUES(?, ?, ?, ?, ?, ?, ?)
__SQL__
$insert->execute(@$_) for
[ 1 , "2016-08-04 12:00", "2016-08-04 16:00", "Entry Gate", "", "P
+lease don't arrive before Noon!", "" ],
[ 2 , "2016-08-04 15:00", "2016-08-04 22:00", "Entry Gate", "", "P
+lease don't arrive before 3:00!", "" ],
[ 3 , "2016-08-05 09:00", "2016-08-05 22:00", "Entry Gate", "", "H
+ours", "" ],
[ 3 , "2016-08-06 07:00", "2016-08-06 19:00", "Entry Gate", "", "H
+ours", "" ],
[ 4 , "2016-08-05 10:00", "2016-08-05 18:00", "Bus Stops", "", "Bu
+s Stops: Pine Island, Food Tent, Pink Clubhouse", "" ],
[ 4 , "2016-08-06 09:00", "2016-08-06 17:00", "Bus Stops", "", "Bu
+s Stops: Pine Island, Food Tent, Pink Clubhouse", "" ],
[ 44 , "2016-08-05 13:00", "2016-08-05 17:00", "Bunkhouse", "Paul
+Fucile and James Lee", "(Teens 12-16)<i class='YellowHighlight'>(Requ
+ires Signup)</i>", "Modeling technology from the New Horizons" ],
[ 45 , "2016-08-06 11:00", "2016-08-06 12:30", "Bunkhouse", "\"Sta
+rgazer\" Steve Dodson", "Ages 12-16", "" ],
[ 46 , "2016-08-05 10:00", "2016-08-05 16:00", "Tent north of Pavi
+lion", "Ray Morits", "ATM Demo Hours", "" ],
[ 46 , "2016-08-06 10:00", "2016-08-06 16:00", "Tent north of Pavi
+lion", "Ray Morits", "ATM Demo Hours", "" ],
[ 46 , "2016-08-05 10:00:01", "2016-08-05 10:30", "Tent north of P
+avilion", "Ray Morits", "Intro & Rough Grinding", "Intro & Ro
+ugh Grinding" ],
[ 46 , "2016-08-06 10:00:01", "2016-08-06 10:30", "Tent north of P
+avilion", "Ray Morits", "Intro & Rough Grinding", "Intro & Ro
+ugh Grinding" ],
[ 46 , "2016-08-05 10:30", "2016-08-05 11:00", "Tent north of Pavi
+lion", "Rick Hunter", "Fine Grinding", "Fine Grinding" ],
[ 46 , "2016-08-06 10:30", "2016-08-06 11:00", "Tent north of Pavi
+lion", "Rick Hunter", "Fine Grinding", "Fine Grinding" ],
[ 46 , "2016-08-05 11:00", "2016-08-05 13:30", "Tent north of Pavi
+lion", "Junie Esslinger", "Making Dental Stone Tools", "Making Dental
+ Stone Tools" ],
[ 46 , "2016-08-06 11:00", "2016-08-06 11:30", "Tent north of Pavi
+lion", "Junie Esslinger", "Making Dental Stone Tools", "Making Dental
+ Stone Tools" ],
[ 46 , "2016-08-05 11:30", "2016-08-05 12:00", "Tent north of Pavi
+lion", "Phil Rounseville","Making Pitch Laps", "Making Pitch Laps" ]
+,
[ 46 , "2016-08-06 11:30", "2016-08-06 12:00", "Tent north of Pavi
+lion", "Phil Rounseville","Making Pitch Laps", "Making Pitch Laps" ]
+,
[ 46 , "2016-08-05 13:00", "2016-08-05 14:00", "Tent north of Pavi
+lion", "Dave Groski", "Polishing & Figuring", "Polishing & Fi
+guring" ],
[ 46 , "2016-08-06 13:00", "2016-08-06 14:00", "Tent north of Pavi
+lion", "Dave Groski", "Polishing & Figuring", "Polishing & Fi
+guring" ],
[ 46 , "2016-08-05 14:00", "2016-08-05 16:00", "Mirror Lab Room in
+ Pavilion", "Dave Kelly", "Testing (Bring your own mirror)", "Testing
+ (Bring your own mirror)" ],
[ 46 , "2016-08-06 14:00", "2016-08-06 16:00", "Tent north of Pavi
+lion", "Ken Slater", "Dobsonian Basics", "Dobsonian Basics" ];
my $select = $db->prepare(<< '__SQL__');
SELECT item, time1, time2, location, who, note, extra
FROM items
INNER JOIN times
ON items.link_id = times.link_id
WHERE times.time1 LIKE "2016-08-06 %"
ORDER BY times.time1
__SQL__
$select->execute;
while (my @row = $select->fetchrow_array) {
say join ' ', map $_ // '--', @row;
}
__END__
Numbers of occurrences:
1 Shuttle Bus Operates 2016-08-06 09:00 2016-08-06 17:00 Bus Sto
+ps Bus Stops: Pine Island, Food Tent, Pink Clubhouse
1 Scope Making For Teens 2016-08-06 11:00 2016-08-06 12:30 Bunkh
+ouse "Stargazer" Steve Dodson Ages 12-16
1 Scope Making Demo 2016-08-06 14:00 2016-08-06 16:00 Tent north
+ of Pavilion Ken Slater Dobsonian Basics Dobsonian Basics
1 Scope Making Demo 2016-08-06 13:00 2016-08-06 14:00 Tent north
+ of Pavilion Dave Groski Polishing & Figuring Polishing & Fig
+uring
1 Scope Making Demo 2016-08-06 11:30 2016-08-06 12:00 Tent north
+ of Pavilion Phil Rounseville Making Pitch Laps Making Pitch Laps
1 Scope Making Demo 2016-08-06 11:00 2016-08-06 11:30 Tent north
+ of Pavilion Junie Esslinger Making Dental Stone Tools Making Dental
+Stone Tools
1 Scope Making Demo 2016-08-06 10:30 2016-08-06 11:00 Tent north
+ of Pavilion Rick Hunter Fine Grinding Fine Grinding
1 Scope Making Demo 2016-08-06 10:00 2016-08-06 16:00 Tent north
+ of Pavilion Ray Morits ATM Demo Hours
1 Scope Making Demo 2016-08-06 10:00:01 2016-08-06 10:30 Tent no
+rth of Pavilion Ray Morits Intro & Rough Grinding Intro & Rou
+gh Grinding
1 Registration Gate 2016-08-06 07:00 2016-08-06 19:00 Entry Gat
+e Hours
#!/usr/bin/perl
use warnings;
use strict;
use Time::Piece;
$ENV{TZ} = 'Europe/Berlin';
print 'Time::Piece'->VERSION, " $]\n";
for my $ts (qw( 2016-09-25 2016-10-31 )) {
$_ = $ts . 'T12:00:00';
my $datetime = 'Time::Piece'->strptime($_, '%Y-%m-%dT%H:%M:%S');
my $utc_offset = $datetime->strftime('%z');
chomp( my $system_offset = qx{ date +%z -d $_ } );
printf "%s - %s - %s - %s\n", $datetime, $utc_offset, $system_offs
+et, $datetime->tzoffset;
}
__END__
1.20_01 5.018002
Sun Sep 25 12:00:00 2016 - +0100 - +0200 - 0
Mon Oct 31 12:00:00 2016 - +0100 - +0100 - 0
1.31 5.025007
Sun Sep 25 12:00:00 2016 - +0000 - +0200 - 0
Mon Oct 31 12:00:00 2016 - +0000 - +0100 - 0
#! /usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
say '1..3';
say 'ok ', $_ for 1 .. 2;
say 'not ok 3';
Run with prove script.pl .
Capture group repeat
RT,
SO
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
no warnings 'uninitialized';
say for 'abA' =~ /^( (?{warn "* [$1,$2,$3]\n"})
([ab]) (?{warn "\tL [$1,$2,$3]\n"})
|
([ab]) (?{warn "\t\tR [$1,$2,$3]\n"})
)*
((?{ warn "\t\t\t\\3 [$1,$2,$3]\n"})
\2
)
$/xi;
I'm not convinced using named captures makes it more readable:
say for 'abA' =~ /^
(?<whole>
(?<left>[ab])
|
(?<right>[ab])
)*
(\g{right})
$/xi;
Tying array to support negative indices#!/usr/bin/perl
use warnings;
use strict;
{ package Array::Stretch;
use Tie::Array;
sub TIEARRAY { bless \ my $o, shift }
our $AUTOLOAD;
sub AUTOLOAD {
warn "** $AUTOLOAD: @_";
}
}
tie my @array, 'Array::Stretch';
@array = qw(a b c);
$array[-1] = 'A';
Coverage History
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use HTML::TableExtract;
use Time::Piece;
use XML::XSH2;
sub shell {
my $status = system @_;
die "@_: $status" if $status;
}
sub git_ready {
open my $GIT, '-|', qw{ git status --porcelain } or die $!;
my $ready = 1;
while (<$GIT>) {
$ready = 0;
}
return $ready
}
sub git_branch {
open my $GIT, '-|', qw{ git branch } or die $!;
my $branch;
while (<$GIT>) {
$branch = "$1", last if /^\* (.*)/
}
close $GIT or die $!;
return $branch
}
my @columns = qw( file stmt bran cond sub pod time total );
sub extract_coverage {
my ($commit, $n, $total) = @_;
open my $HTML, '<', "cover_db.$n/coverage.html" or die $!;
my $te = 'HTML::TableExtract'
->new(headers => [ @columns ]);
my $html = do { local $/ ; <$HTML> };
my $tables = $te->parse($html);
for my $row ($tables->rows) {
next unless 'Total' eq $row->[0];
$total->{ $commit->{id} }
= { date => $commit->{date},
map { $columns[$_] => $row->[$_] } 1 .. $#columns
};
}
}
sub add_navigation {
my ($n, $max, $commit) = @_;
{ package XML::XSH2::Map;
our $n = $n;
our $date = $commit->{date};
our $max = $max;
}
xsh << '__XSH__';
open { "cover_db.$n/coverage.html" } ;
register-namespace h http://www.w3.org/1999/xhtml ;
rm //h:a[@id = 'coverage-history-previous'
or @id = 'coverage-history-next'] ;
$date_header = //h:td[text() = 'Report Date:'] ;
if ($date_header) {
set $date_header/text() 'Commit Date:' ;
set $date_header/following-sibling::h:td[1]/text() $date ;
}
if (0 != $n) {
$prev := insert element a append //h:body ;
set $prev/@id 'coverage-history-previous' ;
set $prev/text() { "\x{2190}" } ;
set $prev/@href concat('../cover_db.', $n - 1, '/coverage.
+html') ;
insert text ' ' after $prev ;
}
if ($max != $n) {
$next := insert element a append //h:body ;
set $next/@id 'coverage-history-next' ;
set $next/text() { "\x{2192}" } ;
set $next/@href concat('../cover_db.', $n + 1, '/coverage.
+html');
}
save :f { "cover_db.$n/coverage.new" } ;
__XSH__
rename "cover_db.$n/coverage.new", "cover_db.$n/coverage.html" or
+die $!;
}
sub graph_data {
my ($total) = @_;
for my $id (keys %$total) {
my $date = $total->{$id}{date};
my $tz = substr $date, -5, 5, q();
my $tp = 'Time::Piece'->strptime($date, '%a %b %d %H:%M:%S %Y
+');
my ($sign, $hours, $minutes) = $tz =~ /([-+])(\d\d)(\d\d)/;
$tp -= "${sign}1" * $minutes * 60 + $hours * 60 * 60;
$total->{$id}{UTC} = $tp->datetime;
}
open my $OUT, '>', 'coverages.data' or die $!;
for my $id ( sort { $total->{$a}{UTC} cmp $total->{$b}{UTC} }
keys %$total
){
my $commit = $total->{$id};
say {$OUT} join "\t", map 'n/a' eq $_ ? q() : $_,
@$commit{qw{ UTC sub stmt cond bran
+}};
}
close $OUT or die $!;
}
sub draw {
my ($output) = @_;
open my $GP, '|-', 'gnuplot' or die $!;
print {$GP} << '__GNUPLOT__';
set term png tiny
set output "coverages.png"
set key outside
set xdata time
set timefmt '%Y-%m-%dT%H:%M:%S'
plot "coverages.data" u 1:2 w lines t "subs", \
"" u 1:3 w lines t "statements", \
"" u 1:4 w lines t "conditions", \
"" u 1:5 w lines t "branches"
__GNUPLOT__
close $GP or die $!;
}
sub startup_check {
die 'Not a git repository' unless -d '.git';
die 'Devel::Cover not installed properly' unless qx{ which cover }
+;
die 'gnuplot not found' unless qx{ which gnuplot };
die "Repository not clean. Maybe stash the changes?" unless git_re
+ady();
}
sub get_commits {
my (@commits, %current);
open my $LOG, '-|', qw{ git log --stat } or die $!;
while (<$LOG>) {
if (/^commit (.*)/) {
if (delete $current{keep}) {
unshift @commits, { %current };
}
%current = ( id => "$1" );
} elsif (/^Date:\s+(.*)/) {
$current{date} = "$1";
} elsif (m=^ (?:lib|t)/=) {
$current{keep} = 1;
}
}
close $LOG or die $!;
return \@commits
}
sub make_or_build {
my ($makefile) = grep -f, qw( Makefile.PL Build.PL );
shell('perl', $makefile);
}
sub get_total {
my ($commits) = @_;
my %total;
for my $idx (reverse 0 .. $#$commits) {
my $commit = $commits->[$idx];
my $id = $commit->{id};
say STDERR @$commits - $idx, '/', scalar @$commits;
if (! -d "cover_db.$idx") {
system qw{ rm -f dump.t };
shell(qw{ git checkout }, $id);
make_or_build();
system qw{ cover -test };
rename 'cover_db', "cover_db.$idx" or die $!;
}
add_navigation($idx, $#$commits, $commit);
extract_coverage($commit, $idx, \%total);
}
return \%total
}
sub good_bye {
print << "__EOF__"
Done.
coverage.png created.
file://$ENV{PWD}/cover_db.0/coverage.html
__EOF__
}
sub main {
startup_check();
my $commits = get_commits();
my $branch = git_branch();
my $total = get_total($commits);
shell(qw{ git checkout }, $branch);
graph_data($total);
draw();
good_bye();
}
main();
Matching differently encoded strings
(for shmem)
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
use Encode;
my $iso8859 = join '', map chr, 191 .. 207,
209 .. 214,
216,
217 .. 221,
223 .. 239,
241 .. 246,
248 .. 253;
my $utf8 = encode('utf8', decode('latin1', join '|', split //, $iso8
+859));
my $valid = qr/ ^ (?: [[:print:]$iso8859] | $utf8 ) $ /x;
my $o_uml = decode('latin1', "\N{LATIN CAPITAL LETTER O WITH DIAERESI
+S}");
my $o_l1 = encode('latin1', $o_uml);
my $o_utf8 = encode('utf8', $o_uml);
say 'bytes' if $o_uml =~ /$valid/;
say 'latin' if $o_l1 =~ /$valid/;
say 'utf8' if $o_utf8 =~ /$valid/;
say 'yup' if "\x82" =~ /$valid/; # chr 130
Instance and class methods
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package Method::Types;
use Carp;
use Attribute::Handlers;
sub handler {
my ($package, $symbol, $ref, $attr, $data, $phase) = @_;
die if 'CHECK' ne $phase;
my $method_type = { Class => 'static',
Instance => 'instance',
}->{$attr};
{ no warnings 'redefine';
*$symbol = sub {
croak("Can't call $method_type method '", *{$symbol}{N
+AME},
"' on ", ref $_[0] ? 'an object' : 'a class',
".\n") if ref $_[0] xor 'instance' eq $method_ty
+pe;
goto $ref
};
}
}
sub Class : ATTR(CODE) { handler(@_) }
sub Instance : ATTR(CODE) { handler(@_) }
}
{ package Named;
use parent -norequire => 'Method::Types';
sub new : Class {
bless {}, shift
}
sub set_name : Instance {
$_[0]->{name} = $_[1]
}
sub get_name : Instance {
shift->{name}
}
}
my $o = 'Named'->new;
$o->set_name('John');
say $o->get_name;
eval {$o->new; 1} or warn $@;
eval {'Named'->get_name; 1} or warn $@;
Tied scalar remembereing previous values
Discipulus mmh.. could a tied scalar know his previous value?
In this example, the variable reports the previous value when assigned.
#!/usr/bin/perl
use warnings;
use strict;
use Syntax::Construct '//';
{ package Previous;
use Tie::Scalar;
use parent -norequire => 'Tie::StdScalar';
sub TIESCALAR { bless \ my $o, shift }
sub STORE {
my ($self, $value) = @_;
warn 'I was ', $$self // 'undefined', "\n";
$$self = $value;
}
}
tie my $p, 'Previous';
$p = $_ for 'a' .. 'z';
Magic date
[chacham] Yesterday was 3/24/2015 using all numbers 0-5. In just over a week it'll happen again.
#! /usr/bin/perl
use warnings;
use strict;
use Time::Piece;
use Time::Seconds qw{ ONE_DAY };
sub is_magical {
my $s = shift;
my %chars;
undef @chars{ split //, $s };
my ($first, $last) = (sort keys %chars)[0, -1];
return (keys %chars == length $s
and $last - $first + 1 == length $s)
}
my $t = 'Time::Piece'->strptime('2015-01-01', '%Y-%m-%d');
while () {
print $t->ymd, "\n" if is_magical(join q(), $t->mon, $t->mday, $t-
+>year);
$t = $t + ONE_DAY;
}
Deparse weirdness (Inspired by yitzchak)
(1)$ perl -MO=Deparse -e 'do("foo")->{bar};'
do $foo{'bar'};
-e syntax OK
(2)$ perl -MO=Deparse -e '(do "foo")->{bar};'
do('foo')->{'bar'};
-e syntax OK
(3)$ perl -MO=Deparse -Mstrict -e 'do("foo")->{bar};'
Global symbol "%foo" requires explicit package name at -e line 1.
-e had compilation errors.
use strict 'refs';
do $<none>::foo{'bar'};
ERROR CODE: [34]
(4)$ perl -MO=Deparse -Mstrict -e '(do "foo")->{bar};'
use strict 'refs';
do('foo')->{'bar'};
-e syntax OK
So, (3) is not permitted under strict. (4) is permitted, but deparses to (3). What's going on here? (v5.14.4 under cygwin)
For pankaj_it09
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
my $number = '343243-23423*234-2342-3';
my @separators = $number =~ /([^0-9])/g;
my %uniq;
undef @uniq{@separators};
say 1 == keys %uniq ? 'Same' : 'Different';
Grouping similar elements
For mohan2monks:
#!/usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
my @array = qw(AB AB CD AB AB AB);
my @result = [ shift @array ];
for (@array) {
if ($_ eq $result[-1][0]) {
push @{ $result[-1] }, $_;
} else {
push @result, [ $_ ];
}
}
print Dumper \@result;
The end.
|
