Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

choroba's scratchpad

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

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

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 all is quiet...

How do I use this? | Other CB clients
Other Users?
Others lurking in the Monastery: (7)
As of 2017-03-26 01:03 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    Should Pluto Get Its Planethood Back?



    Results (313 votes). Check out past polls.