Beefy Boxes and Bandwidth Generously Provided by pair Networks
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

choroba's scratchpad

by choroba (Chancellor)
on Apr 02, 2010 at 15:13 UTC ( #832496=scratchpad: print w/ replies, xml ) Need Help??

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; }

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;
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others meditating upon the Monastery: (7)
As of 2016-07-28 22:59 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    What is your favorite alternate name for a (specific) keyboard key?


















    Results (258 votes). Check out past polls.