http://www.perlmonks.org?node_id=358095

SQL window functions and where clauses and subselects

create table test ( id integer not null, category varchar(4) not null, elements integer not null default 0 ); insert into test (id, category, elements) values (1,'foo',14); insert into test (id, category, elements) values (2,'foo',10); insert into test (id, category, elements) values (3,'bar',11); insert into test (id, category, elements) values (1,'bar',12); insert into test (id, category, elements) values (1,'baz',13); /* This one returns two rows, as expected*/ select * from ( select rank() over (partition by category order by elements desc +) as pos , * from test ) test2 where pos > 1 and id > 1 ; /* This one returns no rows, also expected, because the "and id > 1" c +lause inside the subquery prevents rank() ever going over 1 */ select * from ( select rank() over (partition by category order by elements desc +) as pos , * from test where 1=1 and id > 1 ) test2 where pos > 1

Count of Perl 5 / Perl 6 meditations

select
    count(*)
  , year(createtime) as year
  , case
      when title like '%Perl6%' or title like '%Perl 6%' then 'Perl 6'
      when title like '%Perl5%' or title like '%Perl 5%' then 'Perl 5 
+(explicit)'
      else 'Perl 5 (implicit)'
    end as title_type
from node n
where n.type_nodetype = 120 -- Meditation
group by year, title_type
order by year, title_type
(50 rows)
count(*) year title_type
7 1999 Perl 5 (implicit)
351 2000 Perl 5 (implicit)
7 2000 Perl 6
4 2001 Perl 5 (explicit)
1221 2001 Perl 5 (implicit)
18 2001 Perl 6
10 2002 Perl 5 (explicit)
989 2002 Perl 5 (implicit)
30 2002 Perl 6
7 2003 Perl 5 (explicit)
723 2003 Perl 5 (implicit)
12 2003 Perl 6
3 2004 Perl 5 (explicit)
658 2004 Perl 5 (implicit)
14 2004 Perl 6
2 2005 Perl 5 (explicit)
701 2005 Perl 5 (implicit)
23 2005 Perl 6
2 2006 Perl 5 (explicit)
469 2006 Perl 5 (implicit)
13 2006 Perl 6
6 2007 Perl 5 (explicit)
378 2007 Perl 5 (implicit)
15 2007 Perl 6
7 2008 Perl 5 (explicit)
324 2008 Perl 5 (implicit)
10 2008 Perl 6
1 2009 Perl 5 (explicit)
273 2009 Perl 5 (implicit)
6 2009 Perl 6
4 2010 Perl 5 (explicit)
178 2010 Perl 5 (implicit)
5 2010 Perl 6
2 2011 Perl 5 (explicit)
234 2011 Perl 5 (implicit)
1 2011 Perl 6
6 2012 Perl 5 (explicit)
155 2012 Perl 5 (implicit)
5 2012 Perl 6
4 2013 Perl 5 (explicit)
489 2013 Perl 5 (implicit)
3 2013 Perl 6
2 2014 Perl 5 (explicit)
401 2014 Perl 5 (implicit)
2 2014 Perl 6
5 2015 Perl 5 (explicit)
77 2015 Perl 5 (implicit)
4 2015 Perl 6
12 2016 Perl 5 (implicit)
2 2016 Perl 6

Count of Perl 5 / Perl 6 questions


select
    count(*)
  , year(createtime) as year
  , case
      when title like '%Perl6%' or title like '%Perl 6%' then 'Perl 6'
      when title like '%Perl5%' or title like '%Perl 5%' then 'Perl 5 
+(explicit)'
      else 'Perl 5 (implicit)'
    end as title_type
from node n
where n.type_nodetype = 115 -- SoPW
group by year, title_type
order by year, title_type
(51 rows)
count(*) year title_type
18 1999 Perl 5 (implicit)
6 2000 Perl 5 (explicit)
3190 2000 Perl 5 (implicit)
2 2000 Perl 6
30 2001 Perl 5 (explicit)
8353 2001 Perl 5 (implicit)
5 2001 Perl 6
39 2002 Perl 5 (explicit)
8898 2002 Perl 5 (implicit)
6 2002 Perl 6
62 2003 Perl 5 (explicit)
9225 2003 Perl 5 (implicit)
11 2003 Perl 6
51 2004 Perl 5 (explicit)
9170 2004 Perl 5 (implicit)
6 2004 Perl 6
36 2005 Perl 5 (explicit)
9668 2005 Perl 5 (implicit)
19 2005 Perl 6
36 2006 Perl 5 (explicit)
7375 2006 Perl 5 (implicit)
10 2006 Perl 6
31 2007 Perl 5 (explicit)
6795 2007 Perl 5 (implicit)
13 2007 Perl 6
52 2008 Perl 5 (explicit)
7146 2008 Perl 5 (implicit)
23 2008 Perl 6
46 2009 Perl 5 (explicit)
7941 2009 Perl 5 (implicit)
9 2009 Perl 6
41 2010 Perl 5 (explicit)
6450 2010 Perl 5 (implicit)
29 2010 Perl 6
40 2011 Perl 5 (explicit)
6434 2011 Perl 5 (implicit)
11 2011 Perl 6
44 2012 Perl 5 (explicit)
6335 2012 Perl 5 (implicit)
13 2012 Perl 6
32 2013 Perl 5 (explicit)
5811 2013 Perl 5 (implicit)
7 2013 Perl 6
21 2014 Perl 5 (explicit)
4211 2014 Perl 5 (implicit)
13 2014 Perl 6
24 2015 Perl 5 (explicit)
3518 2015 Perl 5 (implicit)
10 2015 Perl 6
359 2016 Perl 5 (implicit)
2 2016 Perl 6

SQL statements for migrating columns between an EAV-table and a plain table in both directions

The following statements allow modeling data as both, an EAV-table (with three columns, Entity, Attribute and Value) and a conventional relational table. One goal is to make migrations of data to and from the EAV table transparent and to allow simulatneous access while a migration is in progress. This concept needs an additional column in the "main" table which holds the schema version of that row. Each schema version change indicates where the valid data resides, in the EAV-table or in the plain table.

One drawback of this dual approach is that SQL queries querying the large table foo can only take advantage of the SQL query engine if all rows satisfy a minimum schema version. I'm not sure how to enforce that on the database level.

alter table add column foo; create table foo ( row_version integer not null default 0 id integer not null unique; ); create table foo_eav ( id integer not null unique; recno integer not null references foo (id); name varchar(32) not null; value varchar(32); ); -- add a column to foo and move all fields named "bar" into that field alter table foo add colum bar varchar(32); -- row_version 1 update foo rec set foo.bar = eav.value , foo.row_version = 1 join foo_eav eav on (foo.id = foo_eav.recno) where eav.name = 'bar' and foo.row_version = 0 -- this can be done incrementally -- your program should write its schema version for the row to the DB -- move column "bar" back to the EAV store insert into rec select foo.id as recno , 'bar' as name , foo.bar as value where foo.row_version = 1; update foo rec set foo.row_version = 2; -- if there are no more rows with version < 2, we can drop the column +"bar" -- retrieve rows select id , foo.row_version , case when foo.row_version = 1 then foo.bar else foo_bar.bar end as bar from foo left join foo_eav foo_bar on foo.id = foo_eav.recno and foo_eav.name = + 'bar'

My SQLite queue

package App::RemoteDownload::Queue; use strict; use DBI; use vars qw'$VERSION'; $VERSION = '0.01'; sub dbh { $_[0]->{dbh} }; sub new { my ($class,%args) = @_; $args{dsn} ||= 'DBI:SQLite:dbname=remotedownload.sqlite'; $args{dbh} ||= DBI->connect( delete $args{dsn}, undef,undef, {Rais +eError => 1, PrintError => 0, AutoCommit => 1} ); my $self = bless \%args, $class; if (delete $args{create}) { eval { $self->create; }; }; $self; }; sub create { my ($self) = @_; my $res = $self->dbh->do(<<""); CREATE TABLE queue ( job_id VARCHAR(32) PRIMARY KEY UNIQUE NOT NULL, owner VARCHAR(256), pid INTEGER, url VARCHAR(4096) NOT NULL, destination VARCHAR(1024) NOT NULL, status VARCHAR(16), position INTEGER, size INTEGER ); }; sub get_pending_job { my ($self,$count) = @_; $count ||= 1; my $sth_lock = $self->dbh->prepare(<<""); UPDATE queue SET pid = ? WHERE job_id IN ( SELECT job_id FROM queue WHERE pid IS NULL AND status IS NULL LIMIT $count ) if ($sth_lock->execute($$) > 0) { $sth_lock->finish; my $sth_items = $self->dbh->prepare(<<""); SELECT job_id FROM queue WHERE pid = ? AND status IS NULL if (! $sth_items->execute($$)) { die "DB error. Couldn't find locked jobs for '$$'."; }; my $jobs = $sth_items->fetchall_arrayref; return map { @$_ } @$jobs; } else { $sth_lock->finish; return () }; }; sub running_jobs { my ($self) = @_; my $running_jobs = $self->dbh->selectall_arrayref(<<""); SELECT count(*) FROM queue WHERE pid IS NOT NULL AND pid <> 0 $running_jobs->[0]->[0] }; sub pending_jobs { my ($self) = @_; my $running_jobs = $self->dbh->selectall_arrayref(<<""); SELECT count(*) FROM queue WHERE pid IS NULL AND status IS NULL $running_jobs->[0]->[0] }; 1;

Pads are threadsafe/thread-local

#! perl -slw use strict; use threads; sub take { print "Original take\n"; }; sub setup { *take= sub { print "Fresh take\n" }; sleep 10; }; async \&setup; sleep 1; take(); sleep 12;

DateTime::Range

package DateTime::Range; use strict; use DateTime; use vars '%months'; =head1 NAME DateTime::Range - decode strings like 2007Q3 to start and end date =head1 SYNOPSIS use DateTime::Range; my ($span) = @ARGV; # 2007Q3 or 199902 my ($first,$last) = DateTime::Range::get_days($span); printf "Report $part From %s to %s\n", map { $_->strftime('%Y%m%d') +} $first,$last; =cut %months = ( 'Q1' => ['01','03'], 'Q2' => ['04','06'], 'Q3' => ['07','09'], 'Q4' => ['10','12'], 'H1' => ['01','06'], 'H2' => ['07','12'], '' => ['01','12'], ); for (1..12) { my $m = sprintf "%02d", $_; $months{$m} = [$m,$m]; }; sub get_days { my ($yearmonth) = @_; if ($yearmonth eq '--letzter-monat') { $yearmonth = DateTime->now; $yearmonth->set_day(1); $yearmonth->add( days => -1 ); $yearmonth = $yearmonth->strftime('%Y%m'); } my ($year,$month,$day) = ($yearmonth =~ /^(\d{4})(\d\d|Q[1234]|H[1 +2]|)(\d\d)?$/); die "Weirdo date: '$yearmonth'" unless $year and defined $month; my ($start_month,$end_month) = @{$months{ $month }}; my ($first_day, $last_day); if ($day) { $first_day = $yearmonth; $last_day = $yearmonth; } else { $first_day = DateTime->new(year => $year, month => $start_mont +h, day => 1)->strftime('%Y%m%d'); $last_day = DateTime->last_day_of_month(year => $year, month = +> $end_month)->strftime('%Y%m%d'); } ($first_day, $last_day) }; 1;

Memory consumption with Excel files

I rewrote the code so it is somewhat more stand-alone. The results aren't great, as Perl still bloats its process up to 300MB for 50k lines out of a (multi-sheet) 350k line XLS file. Maybe that memory goes out for just storing the file structure.

package Interfaces::ExcelBinary; use strict; use Spreadsheet::ParseExcel; warn "Spreadsheet::ParseExcel $Spreadsheet::ParseExcel::VERSION"; use vars qw($Headers $rowcount); $Headers = []; # cell_handler (Workbook, Sheet_index, Row, Col, Cell) # Called by Spreadsheet::ParseExcel for every cell encountered. sub cell_handler { my ($workbook, $sheet_index, $row, $col, $cell) = @_; if ($row == 0) { push(@{$Interfaces::ExcelBinary::Headers}, $cell->value); $rowcount = 0; } if ($row > 0) { $rowcount++; #Data::Dump::dd($Interfaces::ExcelBinary::Headers); #$workbook->ParseAbort(1); #exit; } } # ReadData (Filename, [WorkSheetID]) returns $ar_data # Reads data from the given file (which should be a BIFF-formatted .xl +s-file) and the given worksheet (by name or number (0-based)). # If the supplied worksheetID is a number, a negative number -n will r +efer to the n-to-last worksheet. sub ReadData { my ($self, $FileName, $WorkSheetID) = @_; my $ExcelParser = Spreadsheet::ParseExcel->new( CellHandler => \&cell_handler, NotSetCell => 1, ); print("Parsing $FileName\n"); main::mem_usage(); my $WorkBook = $ExcelParser->parse($FileName); print("Done parsing\n"); main::mem_usage(); []; #exit; }; package main; use strict; use File::Basename; use Benchmark; sub ReadXLS { my ($interface,$file) = @_; my $ar_data; print("Reading from xls..."); my $benchmark = Benchmark::timeit(1, sub { $ar_data = $interface-> +ReadData($file); }); print("$Interfaces::ExcelBinary::rowcount records in [" . $benchma +rk->real . " seconds], [" . (scalar @{$ar_data} / ($benchmark->real+1 +)) . " records/s]\n"); return $ar_data; } sub mem_usage { print for grep {/^perl.exe\s+$$\b/i} `tasklist`; }; @ARGV = map { glob $_ } @ARGV; for my $file (@ARGV) { printf "%s %d bytes\n", basename($file), -s $file; mem_usage(); ReadXLS(Interfaces::ExcelBinary::, $file); };
Spreadsheet::ParseExcel 0.58 at q:\tmp.pl line 5. medium.xls 47344673 bytes perl.exe 2940 Console 0 7.292 +K Reading from xls...Parsing medium.xls perl.exe 2940 Console 0 7.300 +K Done parsing perl.exe 2940 Console 0 331.140 +K 54175 records in [34 seconds], [0 records/s]

Having a blocking API and still use AnyEvent

I'm in the process of making (my) modules play nice with AnyEvent. Most of the time, I'm content with being compatible with AnyEvent, that means, allowing timers, socket callbacks and other AnyEvent stuff run while some function call in my preexisting code blocks.

The basic approach that AnyEvent follows for asynchronous operation allows two methods. The first is to have callbacks in your API for the various events that occur. The second is to return AnyEvent::condvar objects that represent a future value to be filled in when the call completes on the "other side". The data for a condvar can be fetched with

my @data = $cv->recv()
While your code waits for the values to be fetched, AnyEvent will dispatch other events and timers to callbacks.

In the concrete example of making WWW::Mechanize::Firefox (through MozRepl) play nice with AnyEvent, MozRepl has the following API:

my @result = $plugin->execute('1+1'); # sends data over to Firefox, an +d returns the response

I can't change that API, but I want to allow timers and callbacks to be fired while waiting for ->execute() to complete.

To that effect, I try the following approach:

package My::Plugin::AnyEvent; ... sub execute_async { my ($self,$command, $complete) = @_; $complete ||= AnyEvent->condvar; # Send the command to Firefox $self->handle->push_write($command); # Read the response as soon as it becomes available $self->handle->push_read(line => sub { $complete->send($_[0]); # send the data to whoever waits }); $complete }; sub execute { my ($self,$command) = @_; # synchronously execute the command $self->execute_async($command)->recv };

This works all nice and dandy, except it does not work well if I want to do this from a constructor:

...

Archive::Zip::MemberRead::FH

package Archive::Zip::MemberRead::FH; use strict; #use parent 'Tie::Handle'; use base 'Tie::Handle'; use Archive::Zip::MemberRead; =head1 NAME Archive::Zip::MemberRead::FH - readonly filehandle for zip members =head1 SYNOPSIS require Archive::Zip; require Archive::Zip::MemberRead::FH; my $ar = Archive::Zip->new(); my $file = 'test.zip'; $ar->read($file) == Archive::Zip::AZ_OK() or die "Couldn't read '$file': $!"; my @members = $ar->members(); print "Reading first file from '$file'\n"; $fh = Archive::Zip::MemberRead::FH->new($members[0]); while (<$fh>) { ... }; =head1 NOTES This is a very crude wrapper that tries to dress up a L<Archive::Zip::MemberRead> as a read-only filehandle. =head1 METHODS =head2 C<< ->new ReadMember >> The C<< ->new >> constructor takes the same arguments as L<Archive::Zip::ReadMember>C<< ->new >>, but returns a filehandle instead of an object. =cut sub new { my $class = shift; local *ZIPFH; tie *ZIPFH, $class, @_; return *ZIPFH }; =head2 C<< ->readmember >> The C<< ->readmember >> function allows access to the underlying L<Archive::Zip::ReadMember>. =cut sub readmember { my ($glob) = @_; $$glob }; sub TIEHANDLE { my $class = shift; my $m = Archive::Zip::MemberRead->new(@_); return bless \$m, $class; }; sub reflect { my ($name,$args) = @_; my $glob = shift @$args; my $self = $glob->readmember; unshift @$args, $self; return $self->can($name); }; =head1 FUNCTIONALITY The following functionality is implemented for the filehandle: =cut =head2 C< read > Reading octets into a buffer, using the C<< ->read >> method of the underlying ReadMember object. =cut sub READ { goto &{ reflect('read', \@_) } }; =head2 C< readline > Reading lines into a buffer, using the C<< ->getline >> method of the underlying ReadMember object. No special provision for treating C<$/> properly is made, the default behaviour of the underlying ReadMember applies. =cut sub READLINE { goto &{ reflect('getline', \@_)} }; =head2 C< close > Closes the filehandle, using the C<< ->close >> method of the underlying ReadMember object. =cut sub CLOSE { goto &{ reflect('close', \@_)} }; =head2 C< binmode > Not implemented =cut #sub BINMODE { goto reflect('binmode', \@_) }; =head2 C< eof > Not implemented =cut #sub EOF { goto reflect('eof', \@_)}; 1; __END__ =head1 AUTHOR Max Maischein L<corion@cpan.org> =head1 COPYRIGHT This file is copyright (2009) Max Maischein L<corion@cpan.org> This program is free software; you can redistribute it and/or modify i +t under the same terms as Perl itself. =cut

Patched expand_macro.pl

#!perl -w use strict; use Pod::Usage; use Getopt::Std; use Config; $Getopt::Std::STANDARD_HELP_VERSION = 1; my $trysource = "try.c"; my $tryout = "try.i"; getopts('fF:ekvI:X', \my %opt) or pod2usage(); my($expr, @headers) = @ARGV ? splice @ARGV : "-"; pod2usage "-f and -F <tool> are exclusive\n" if $opt{f} and $opt{F}; foreach($trysource, $tryout) { unlink $_ if $opt{e}; die "You already have a $_" if -e $_; } if ($expr eq '-') { warn "reading from stdin...\n"; $expr = do { local $/; <> }; } my($macro, $args) = $expr =~ /^\s*(\w+)((?:\s*\(.*\))?)\s*;?\s*$/s or pod2usage "$expr doesn't look like a macro-name or macro-expres +sion to me"; if (!(@ARGV = @headers)) { open my $fh, '<', 'MANIFEST' or die "Can't open MANIFEST: $!"; while (<$fh>) { push @ARGV, $1 if m!^([^/]+\.h)\t!; } push @ARGV, 'config.h' if -f 'config.h'; } my $header; while (<>) { next unless /^#\s*define\s+$macro\b/; my ($def_args) = /^#\s*define\s+$macro\(([^)]*)\)/; if (defined $def_args && !$args) { my @args = split ',', $def_args; print "# macro: $macro args: @args in $_\n" if $opt{v}; my $argname = "A0"; $args = '(' . join (', ', map {$argname++} 1..@args) . ')'; } $header = $ARGV; last; } die "$macro not found\n" unless defined $header; if ($^O =~ /MSWin(32|64)/) { # The Win32 (and Win64) build process expects to be run from # bleadperl/Win32 chdir "Win32" or die "Couldn't chdir to win32: $!"; }; open my $out, '>', $trysource or die "Can't open $trysource: $!"; my $sentinel = "$macro expands to"; my %done_header; sub do_header { my $header = shift; return if $done_header{$header}++; print $out qq{#include "$header"\n}; } print $out <<'EOF' if $opt{X}; /* Need to do this like this, as cflags.sh sets it for us come what ma +y. */ #undef PERL_CORE EOF do_header('EXTERN.h'); do_header('perl.h'); do_header($header); do_header('XSUB.h') if $opt{X}; print $out <<"EOF"; #line 4 "$sentinel" $macro$args EOF close $out or die "Can't close $trysource: $!"; print "doing: $Config{make} $tryout\n" if $opt{v}; my $cmd = "$Config{make} $tryout"; system( $cmd ) == 0 or die "Couldn't launch [$cmd]: $! / $?"; # if user wants 'indent' formatting .. my $out_fh; if ($opt{f} || $opt{F}) { # a: indent is a well behaved filter when given 0 arguments, readi +ng from # stdin and writing to stdout # b: all our braces should be balanced, indented back to column 0, + in the # headers, hence everything before our #line directive can be i +gnored # # We can take advantage of this to reduce the work to indent. my $indent_command = $opt{f} ? 'indent' : $opt{F}; if (defined $opt{I}) { $indent_command .= " $opt{I}"; } open $out_fh, '|-', $indent_command or die $?; } else { $out_fh = \*STDOUT; } { open my $fh, '<', $tryout or die "Can't open $tryout: $!"; while (<$fh>) { print $out_fh $_ if /$sentinel/o .. 1; } }; unless ($opt{k}) { foreach($trysource, $tryout) { die "Can't unlink $_: $!" unless unlink $_; } } __END__ =head1 NAME expand-macro.pl - expand C macros using the C preprocessor =head1 SYNOPSIS expand-macro.pl [options] [ < macro-name | macro-expression | - > [h +eaders] ] options: -f use 'indent' to format output -F <tool> use <tool> to format output (instead of -f) -e erase try.[ic] instead of failing when they're present ( +errdetect) -k keep them after generating (for handy inspection) -v verbose -I <indent-opts> passed into indent -X include "XSUB.h" (and undefine PERL_CORE) =cut

Making @ARGV work better

The idea is to tie *ARGV once and then process @ARGV one by one when needed, and calling &ARGV between the files (or something like that).

#!perl -w BEGIN { { package My::ARGV; use strict; use Data::Dumper; sub TIEHANDLE { my ($class,@elts) = @_; warn 'TIEHANDLE'; bless {}; #[@elts] }; sub OPEN { warn 'OPEN: ' . Dumper \@_; 1 }; sub EOF { warn 'EOF: ' . Dumper \@_; @{ $_[0] } }; sub CLOSE { warn 'CLOSE: ' . Dumper \@_; 1 }; sub BINMODE { warn 'BINMODE: ' . Dumper \@_; @{ $_[0] } }; sub READLINE { my ($self) = @_; while (@ARGV and (!defined $self->{curr} or !scalar @{ $self-> +{curr}})) { $self->{curr} = shift @ARGV; }; if(scalar @{ $self->{curr} }) { return shift @{ $self->{curr} } } else { return $self->{curr} = undef } }; } tie *ARGV, 'My::ARGV'; } @ARGV = ([qw(1 2 3)],[qw(4 5 6)],[qw(7 8 9)]); while (<>) { print "$_\n" };

Perl Stable release test

I think that for a stable release the question "is it ready" is more like:

Does CPAN pass?

which comes down to:

for each module that fails its regression tests on $current did it fail identically on $previous? if yes, "SEP" else work out why it failed (a bisect is useful for this) attempt to group failure causes for each failure cause is that a regression? if yes, figure out how to fix it (more code? revert the code that broke it) else (presumably) it's relying on something un-or-under-documented should the existing behaviour stay? yes - goto "regression" no - note it in perldelta as a significant bugfix (also, try to inform the module's author)

  1. check that ./Configure -des && make all test works in one place
  2. check that ./Configure ... && make all test_harness install works
    that's likely something that needs fixing in the Parrot checklist - there's no step to check that it installs, that the installed parrot runs, or that the installed parrot can be used to build a third-party language such as Rakudo or Pynie]
  3. bootstrap the CPAN client on the clean install
  4. install CPANPLUS
  5. bootstrap the CPANPLUS client
  6. install an XS module
  7. if this is good, commit this. sit, and wait.

grate.pl - grep rate

#!/usr/bin/perl -w use strict; use Getopt::Long; use Time::HiRes; use List::Util qw( sum ); use Data::Dumper; #use IO::Select; # does not work the way I want on Windows GetOptions( 'debug|d' => \my $debug, 're:s' => \my @buckets, 'totals|t' => \my $totals, 'window|w:s' => \my @windows, # in seconds 'update|u:i' => \my $update, ); if (! @windows) { @windows = qw(1 5 60); }; @windows = sort { $a <=> $b } @windows; $update ||= 1; @buckets = map { s/:(\w+)$// ? [ $1 => qr/$_/ ] : [$_ => qr/$_/ ] } @b +uckets; if ($totals) { unshift @buckets, ['totals' => qr/(?!)/ ]; }; my @names = map { $_->[0] } @buckets; my @slots; my $last = 0; my $last_update = 0; while (<>) { my $now = time; $last ||= $now - $windows[-1]; my $elapsed = $now - $last; #print "Elapsed: $elapsed ($slots[0]->{totals})\n"; chomp; # Check how many buckets have passed without data for (0..int($now - $last)-1) { unshift @slots, +{ map {; $_ => 0 } @names }; }; # Limit slots to maximum reporting size splice @slots, $windows[-1]+1; if ($totals) { $slots[0]->{totals}++; }; BUCKET: for my $b (@buckets) { my ($n,$r) = @$b; if (/$r/) { $slots[0]->{ $n }++; last BUCKET; }; }; $last = $now; if ($now - $last_update >= $update) { local $" = "\t"; print "\t@windows\n"; for my $n (@names) { print "$n\t"; for my $w (@windows) { print sprintf "%0.2f\t", sum( map { $_->{ $n } } @slot +s[ 1.. $w ] ) / $w; }; print "\n"; }; $last_update = $now; }; };

Parallel map

use strict; use threads; use Thread::Queue; my $threadcount = 4; =head2 C<qmap CODE ARGS> Launches C<$threadcount> threads that process the items in C<ARGS> in parallel. Returns the input queue, output queue and an array reference to the threads. The aliasing effect of C<map> on C<$_> is not preserved. =cut sub qmap(&;@) { my $cb = shift; my $in = Thread::Queue->new(@_); my $out = Thread::Queue->new(); my $handler = sub { while (defined(my $args = $in->dequeue())) { local $_ = $args; $out->enqueue($cb->()); }; }; my @threads = map { threads->new($handler) } 1..$threadcount; $in,$out,\@threads }; =head2 C<pmap CODE ARGS> Processes a list in parallel and returns the results in the order they were finished. The aliasing effect of C<map> on C<$_> is not preserved. =cut sub pmap(&;@) { my ($in,$out,$threads) = &qmap(@_); $in->enqueue((undef) x scalar @$threads); $_->join for @$threads; return $out->dequeue( scalar @$out ) }; =head2 C<smap CODE ARGS> Processes a list in parallel and returns the results in the order they were input. This is slightly more processing intensive, as the results are sorted after having been processed. The aliasing effect of C<map> on C<$_> is not preserved. =cut sub smap(&;@) { my $user_cb = shift; my $cb = sub { my $args = $_; local $_ = $args->[1]; [ $args->[0], $user_cb->() ]; }; my $pos = 0; my ($in,$out,$threads) = &qmap($cb, map {[ $pos++, $_ ]} @_); $in->enqueue((undef) x scalar @$threads); $_->join for @$threads; return map { shift @$_; @$_ } sort { $a->[0] <=> $b->[0] } $out->d +equeue( scalar @$out ) }; print "Got $_\n" for smap { sleep rand 10; printf "%d %d\n", threads->tid, $_; $_ } (1..10);

Environment Setup for Strawberry Perl

Put this into C:\Strawberry\Path.cmd and call it to add the relevant directories to $ENV{PATH}. You can also move Strawberry Perl away from C:\Strawberry with that.

@echo off set base=%~dp0 path %BASE%\perl\bin;%BASE%\c\bin;%PATH% set CCACHE_DIR=C:\temp\ccache set CCACHE_LOGFILE=%CCACHE_DIR%\ccache.log

WMI queries for Chronic::Win32

#!perl -w use strict; use DBI; use Data::Dumper; my $dbh = DBI->connect('dbi:WMI:', undef, undef, {RaiseError => 1}); sub dump_wql { my $res = $dbh->selectall_arrayref($_[1], {}); print $_[0], Dumper $res; }; dump_wql('Ping 192.168.1.1', <<''); select responsetime from Win32_PingStatus where Address = '192.168.1.1' dump_wql('CPU load', <<''); select Name,LoadPercentage from Win32_Processor dump_wql('Network connections', <<''); select RemotePath,ConnectionState from Win32_NetworkConnection

Capturing STDERR via backticks

Stolen from dave_the_m in a p5p post

sub GimmeStdErr(@){ # ... bangles, tangles and spaghetti! local *R, *W; pipe R,W; if(fork){ close W; <R> }else{ close R; open STDERR, ">&W"; exec @_ } };

An ugly nest of map

I think the map invocation in flatten() needs a bit of documentation...

=head2 C<< flatten LISTNAME CHILDLIST $var >> Removes one level of hierarchy and merges all keys from the current hi +erarchy into the elements below it: $VAR1 = { user => 'corion', pages => [ { title => 'This is page 1', url => '/pages/1', items => [ { url => '/items/1', description => 'A brand new item' }, { url => '/items/2', description => 'A brand new item' }, ], }, { title => 'This is page 2', url => '/pages/2', items => [ { url => '/items/3', description => 'A brand new item' }, { url => '/items/4', description => 'A brand new item' }, ], }, { title => 'This is page 3', url => '/pages/3', items => [] }, ], } flatten 'pages' => 'items', $VAR1 becomes $VAR1 = { user => 'corion', items => [ { title => 'This is page 1', url => '/items/1', description => 'A brand new item' }, { title => 'This is page 1', url => '/items/2', description => 'A brand new item' }, { title => 'This is page 2', url => '/items/3', description => 'A brand new item' }, { title => 'This is page 2', url => '/items/4', description => 'A brand new item' }, }, ], } =cut sub flatten($$$) { my ($key,$child,$items) = @_; if (! exists $items->{$key}) { croak "Cannot flatten '$key': The entry does not exist"; }; $items->{ $child } = [ map { my $p = $_; (exists $p->{ $child } && ref $p->{ $child } eq 'ARRAY') ? (map {; +{%$p,%$_} } @{ delete $p->{ $child }} ) : () } @{ delete $items->{ $key }} ]; $items };

Load trace/timing information

This is the short hack I came up with but it's substantially longer than 4 lines :)

Q:\>perl -e "my%l;BEGIN{unshift@INC,sub{my($s,$m)=@_;return if $l{$m}; +local $l{$ m}=$m;warn localtime().qq[ $m loading\n];require $m;warn localtime().q +q[ $m done .\n];}}" -e "use strict; use warnings;use LWP::UserAgent;"
package Devel::Timings; # or maybe B::Timings, so you can load it with -MO=Timings... my %loading; BEGIN{ unshift @INC, sub{ my ($self,$module) = @_; return if $loading{$m}; # reentrancy guard local $loading{$module} = $module; warn localtime().qq[ $module loading\n]; require $module; warn localtime().qq[ $module done.\n]; } }

Check that File::Spec->path works sanely on Win32

use Test::More tests => 4; use Data::Dumper; use Config; =head1 DESCRIPTION This test checks whether the current directory (".") is included in the list returned from File::Spec->path and whether a program in the current directory can be run. The test succeeds when both match. =cut use_ok 'File::Spec'; diag "\$File::Spec::VERSION is $File::Spec::VERSION"; my $tempfile = 'does_only_exist_in_current_directory.cmd'; $/ = ""; my %os = map { split /\r?\n/, $_, 2 } <DATA>; my $os = $os{$^O} || $os{'fallback'}; open my $fh, ">", $tempfile or die "Couldn't create '$tempfile': $!"; print {$fh} $os; close $fh; chmod 700, $tempfile; ok -x $tempfile, "'$tempfile' is executable"; my $explicit = File::Spec->catfile( ".", $tempfile ); is system($explicit), 0, "'$tempfile' can be executed as '$explicit'"; my $dot_in_path = grep { $_ eq '.'} File::Spec->path; my $implicit_execution = system( $tempfile ) == 0; diag "The current directory is " . ($dot_in_path ? "" : "not ") . "in +File::Spec->path."; diag $_ for File::Spec->path; diag "---"; diag $_ for split /$Config{path_sep}/, $ENV{PATH}; diag "Programs in the current directory can " . ($implicit_execution ? + "" : "not ") . "be launched."; is (($dot_in_path xor $implicit_execution), '', "dot is in File::Spec- +>path or files in the current directory don't get launched") or do { }; END { unlink $tempfile or diag "Couldn't remove '$tempfile': $!"; }; __DATA__ MSWin32 @echo off fallback #!/bin/sh

Using DBD::WMI to get (and reconfigure) the DNS resolution order

#!/usr/bin/perl -w package main; use strict; use Data::Dumper; use DBI; my ($machine,$user,$pass) = @ARGV; $machine ||= "."; my $target_ip = '192.168.1.13'; my $dbh = DBI->connect("dbi:WMI:$machine",$user,$pass); my $sth = $dbh->prepare(<<WQL); SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = 1 WQL $sth->execute(); while (defined (my $row = $sth->fetchrow_arrayref())) { my $conf = $row->[0]; print join "\t", @{ $conf->{IPAddress} }, "\n"; if ($conf->{IPAddress}->[0] ne $target_ip) { print "Skipped\n"; next }; my $order = $conf->{DNSServerSearchOrder}; if ($order) { print join "\t", @$order; } else { print "No DNS servers defined"; }; print "\n"; $conf->SetDNSServerSearchOrder(['192.168.1.102', '127.0.0.1']); }

The Revolution Will Not Be In A Bulleted List

Grand pile of projects

How to construct a static query for dynamic parameters

The problem is that you know on the Perl side which parameters are valid/given for a query, but you want to run one (and only one) SQL statement against the database, to return every row only once.

The idea is to guard all query parameters with a second parameter indicating if that parameter is to be used. Starting from:

SELECT COUNT(*) FROM mx_forums WHERE id=? OR category = ? -- $q->param('forum'), $q->param('category')

we want to add a second clause guarding the id and another one guarding category:

SELECT COUNT(*) FROM mx_forums WHERE ((1 = ?) AND (id = ?)) OR ((1 = ?) AND (category = ?)) -- defined $q->param('forum'), $q->param('forum') -- defined $q->param('category'), $q->param('category')

Now you need to pass the two additional parameters:

my $sql = q{ ... }; if ( $dbh->selectrow_array( $sql, { Slice => {} }, (defined $q->param('forum'))+0, $q->param('forum'), (defined $q->param('category'))+0, $q->param('category') ) >= 1 ) { ... }

Using clauses with SQL::Abstract::Clauses (yet-to-be released)

The following statement is used to find all values for the columns artist and album that refine/subdivide the current result set.

use strict; use lib '.'; use Clauses; #use SQL::Abstract::Clauses; my $s = SQL::Abstract::Clauses->new(); my $where = { 1 => 0 }; # some preexisting where clause my $total_count = 13; for my $column (qw(artist album)) { my ($sql,@bind) = $s->select('foo',[ $column, 'count(*) as col_count +' ], where => $where, order_by => [ "$column asc", 'col_count desc +' ], having => { col_count => [ -and => { '>' => + 0 }, { '<' => $total_count }]},); print $sql,"\n"; }

Another stab at making IPC::Open3 selectable

#!/usr/bin/perl use warnings; use strict; use IO::Handle; use IO::Select; use IPC::Open3; BEGIN { eval "sub WSAEINVAL () { 10022 }"; eval "sub WSAEWOULDBLOCK () { 10035 }"; eval "sub WSAEINPROGRESS () { 10036 }"; }; BEGIN { # cribbed from AnyEvent::Util use Socket; sub _win32_socketpair { # perl's socketpair emulation fails on many vista machines, bec +ause # vista returns fantasy port numbers. for (1..10) { socket my $l, &Socket::AF_INET, &Socket::SOCK_STREAM, 0 or next; bind $l, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01" or next; my $sa = getsockname $l or next; listen $l, 1 or next; socket my $r, &Socket::AF_INET, &Socket::SOCK_STREAM, 0 or next; bind $r, Socket::pack_sockaddr_in 0, "\x7f\x00\x00\x01" or next; connect $r, $sa or next; accept my $w, $l or next; # vista has completely broken peername/sockname that return # fantasy ports. this combo seems to work, though. # (Socket::unpack_sockaddr_in getpeername $r)[0] == (Socket::unpack_sockaddr_in getsockname $w)[0] or (($! = WSAEINVAL), next); # vista example (you can't make this shit up...): #(Socket::unpack_sockaddr_in getsockname $r)[0] == 53364 #(Socket::unpack_sockaddr_in getpeername $r)[0] == 53363 #(Socket::unpack_sockaddr_in getsockname $w)[0] == 53363 #(Socket::unpack_sockaddr_in getpeername $w)[0] == 53365 return ($r, $w); }; () }; *IPC::Open3::xpipe = sub { use Socket qw(AF_UNIX SOCK_STREAM PF_UNSPEC); use IO::Handle; #socketpair $_[0], $_[1], AF_UNIX, SOCK_STREAM, PF_UNSPEC # or die "socketpair: $!"; (*{$_[0]},*{$_[1]}) = _win32_socketpair(); # or die "socketpair: $!"; # stop reading on the write handle: shutdown $_[1], 0 or die "shutdown: $!"; # stop writing on the read handle: shutdown $_[0], 1 or die "shutdown: $!"; }; }; my $expected = 100; #my $cat_self = q{"%s" -ple "$|++;sleep(rand(0));$_=qq{%s_$_};END{slee +p 5}" %s}; #my $cat_self = q{"%s" -ple "$|++;sleep(rand(0));$_=qq{%s_$_};" %s}; my $proc = q{"%s" -le "$|=1;$n=shift;for(shift..shift){sleep(rand(3)); +print+qq($n $_)};" %s %s %s}; my @procs = ( sprintf( $proc, $^X, 'child_1', 1,$expected), sprintf( $proc, $^X, 'child_2', 1,$expected), sprintf( $proc, $^X, 'child_3', 1,$expected), ); my @kill_pids; END { print "Cleaning up children @kill_pids\n"; kill 9 => @kill_pids +}; my %children; my $select = IO::Select->new; for my $child (@procs) { my $child_err = IO::Handle->new(); my $pid= open3 my $child_in, my $child_out, $child_err, $child or die "Launching $child: $!"; push @kill_pids,$pid; $children{ $child_out } = $pid; print "[$pid] $child launched\n"; $select->add($child_out); }; print "Launched children, waiting for things to become readable\n"; print "Expecting $expected lines\n", ; my %buffer; my %received; $SIG{CHLD} = sub { warn "Child: " . wait }; $SIG{PIPE} = sub { warn "Child: $_" }; warn $select->count() . " children to read from."; while ($select->count) { my @ready = $select->can_read(); #warn "Got " . scalar(@ready) . " handles ready.\n"; for my $fh (@ready) { if (not exists $buffer{$fh}) { $buffer{$fh} = ""; }; my $bytesread = sysread($fh,$buffer{$fh},1024,length($buffer{$ +fh})); if ($bytesread == 0) { use POSIX ':sys_wait_h'; if ((my $state = waitpid($children{ $fh }, WNOHANG)) <= 0) + { print "\n$children{ $fh } is done\n"; } else { #print "\n$children{ $fh } is still alive :(\n"; } $select->remove($fh); } elsif (! defined $bytesread) { #print "\nError on reading from $fh: $! / $^E\n"; $select->remove($fh); } elsif (! $bytesread) { print "The lights are on but nobody's home for $fh\n"; } elsif ($buffer{$fh} =~ /\n$/) { $received{$fh}++ for split /\n/, $buffer{$fh}; #print $buffer{$fh}; $buffer{$fh} = ""; } }; for (sort keys %received) { print "[$children{ $_ }]\t$received{$_} lines\t"; } print "\n"; }; print "Waitpid-dding for children\n"; for (@kill_pids) { waitpid $_,0 }; for (sort keys %received) { print "$children{$_}\t$received{$_}\n"; } print "Done.";

Nodes whose content was overwritten and which can't be restored


Copy column