Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
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 imbibing at the Monastery: (6)
As of 2016-09-01 07:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found