Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

Corion's scratchpad

by Corion (Pope)
on Jun 01, 2004 at 14:33 UTC ( #358095=scratchpad: print w/ replies, xml ) Need Help??

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

  • The Revolution Will Not Be Televised
  • The Revolution Will Not Be Webcast
  • The Revolution Will Not Have Rounded Corners
  • The Revolution Will Not Be Verified
  • The Revolution's FAQ Will Not Be Archived At rtfm.mit.edu

Grand pile of projects

  • Optimize <> in void context so it just skips forward to the next occurrence of $/ without wasting memory.
  • Hack OpenOffice.org so the PDF-printing engine becomes available as a command line tool. This means ripping out the import/export filter engines and glueing them together into a trivial pipeline that will read a Word/Excel/whatever file and turn it into PDF.
  • Write a test for Perl as outlined in http://www.nntp.perl.org/group/perl.perl5.porters/114256
  • Create Google Sitemap files from PM:
    • Users should be "fairly recent", based on their lastedit times
    • Nonuser nodes older than a month should become virtually static
    • All items should live in the robot playpen
  • Look at App::Info to let Alien::Util offer locally installed versions instead of building perl-owned versions
  • Create a (offline) (mp4) video mogrifier in Perl, to extract "sprites"/sprite sequences from video and to recreate a static "scene" image from a sequence of images, with all moving parts eliminated:
    1. Use ffmpeg or ImageMagick to extract frames from video
    2. Detect moving parts ("actors") on the image by xor-ing two frames of the movie that are "close" together (5 seconds apart maybe, or maybe two I-frames apart)
    3. Then track the moving parts (as rectangular boxes) between adjactent frames, adding some fudge value and output them into a new video so they become actors
    4. Recomposite the movie, inserting actors at will
    5. Paper on sprite/mosaic generation from movies - a "sprite" in their lingo is the background, not the actor in the foreground
    6. Automatically creating random looped videos by estimating the cost between frames to generate split/cut points

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
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 browsing the Monastery: (5)
As of 2014-09-02 03:54 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite cookbook is:










    Results (19 votes), past polls