http://qs1969.pair.com?node_id=832496

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 &amp; Rough Grinding", "Intro &amp; Ro +ugh Grinding" ], [ 46 , "2016-08-06 10:00:01", "2016-08-06 10:30", "Tent north of P +avilion", "Ray Morits", "Intro &amp; Rough Grinding", "Intro &amp; 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 &amp; Figuring", "Polishing &amp; Fi +guring" ], [ 46 , "2016-08-06 13:00", "2016-08-06 14:00", "Tent north of Pavi +lion", "Dave Groski", "Polishing &amp; Figuring", "Polishing &amp; 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 &amp; Figuring Polishing &amp; 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 &amp; Rough Grinding Intro &amp; Rou +gh Grinding 1 Registration Gate 2016-08-06 07:00 2016-08-06 19:00 Entry Gat +e Hours

For Corion: Time::Piece bug

#!/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

For toolic

#! /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.