scratchpad
Corion
<h1>DateTime::Range</h1>
<c>
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[12]|)(\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_month, 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;
</c>
<h2>Memory consumption with Excel files</h2>
<p>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.</p>
<c>
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 .xls-file) and the given worksheet (by name or number (0-based)).
# If the supplied worksheetID is a number, a negative number -n will refer 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 [" . $benchmark->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);
};
</c>
<c>
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]</c>
<h2>
Having a blocking API and still use AnyEvent
</h2><p>
I'm in the process of making (my) modules play nice with [mod://AnyEvent].
Most of the time, I'm content with being <i>compatible</i> with [mod://AnyEvent], that
means, allowing timers, socket callbacks and other AnyEvent stuff run while
some function call in my preexisting code blocks.
</p><p>
The basic approach that [mod://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
<c>AnyEvent::condvar</c> 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
<c>
my @data = $cv->recv()
</c>
While your code waits for the values to be fetched, [mod://AnyEvent] will
dispatch other events and timers to callbacks.
</p><p>
In the concrete example of making [mod://WWW::Mechanize::Firefox] (through [mod://MozRepl])
play nice with [mod://AnyEvent], MozRepl has the following API:
</p><p>
<c>
my @result = $plugin->execute('1+1'); # sends data over to Firefox, and returns the response
</c>
<p>I can't change <i>that</i> API, but I want to allow timers and callbacks to
be fired while waiting for <c>->execute()</c> to complete.</p>
<p>To that effect, I try the following approach:</p>
<c>
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
};
</c>
<p>This works all nice and dandy, except it does not work well if
I want to do this from a constructor:</p>
<c>...</c>
<h2>Archive::Zip::MemberRead::FH</h2>
<c>
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 it under the same terms as Perl itself.
=cut
</c>
<h2>Patched <c>expand_macro.pl</c></h2>
<c>
#!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-expression 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 may. */
#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, reading 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 ignored
#
# 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 | - > [headers] ]
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
</c>
<h2>Making <c>@ARGV</c> work better</h2>
<p>The idea is to [doc://tie] <c>*ARGV</c> once and then
process <c>@ARGV</c> one by one when needed, and calling
<c>&ARGV</c> between the files (or something like that).
<c>
#!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"
};
</c>
<h2>[http://groups.google.de/group/perl.perl5.porters/msg/fe0b8645e81f3424|Perl Stable release test]</h2>
<p>
I think that for a stable release the question "is it ready" is more like:
</p><blockquote>
Does CPAN pass?
</blockquote><p>
which comes down to:
</p><c>
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)
</c>
<p>
</p>
<ol start=11>
<li>check that <c>./Configure -des && make all test</c> works in one place
<li>check that <c>./Configure ... && make all test_harness install</c> works
<blockquote>
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]
</blockquote>
<li>bootstrap the CPAN client on the clean install
<li>install CPANPLUS
<li>bootstrap the CPANPLUS client
<li>install an XS module
<li>if this is good, commit this.
sit, and wait.
</ol>
<h2><tt>grate.pl</tt> - grep rate</h2>
<c>
#!/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/$_/ ] } @buckets;
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 } } @slots[ 1.. $w ] ) / $w;
};
print "\n";
};
$last_update = $now;
};
};
</c>
<h2>Parallel map</h2>
<c>
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->dequeue( scalar @$out )
};
print "Got $_\n" for smap {
sleep rand 10;
printf "%d %d\n", threads->tid, $_;
$_
} (1..10);
</c>
<h2>Environment Setup for Strawberry Perl</h2>
<p>Put this into <c>C:\Strawberry\Path.cmd</c> and call it to add the relevant directories to <c>$ENV{PATH}</c>. You can also move Strawberry Perl away from <c>C:\Strawberry</c> with that.
<c>
@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
</c>
<h2>WMI queries for Chronic::Win32</h2>
<c>
#!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
</c>
<h2>Capturing STDERR via backticks</h2>
<p>Stolen from [dave_the_m] in [http://groups.google.de/group/perl.perl5.porters/browse_thread/thread/326aa5b020a746d1/00cec87e7e400efa#00cec87e7e400efa| a p5p post]
<c>
sub GimmeStdErr(@){ # ... bangles, tangles and spaghetti!
local *R, *W;
pipe R,W;
if(fork){
close W;
<R>
}else{
close R;
open STDERR, ">&W";
exec @_
}
};
</c>
<h2>An ugly nest of map</h2>
<p>I think the <c>map</c> invocation in <c>flatten()</c> needs a bit of documentation...</p>
<c>
=head2 C<< flatten LISTNAME CHILDLIST $var >>
Removes one level of hierarchy and merges all keys from the current hierarchy
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
};
</c>
<h2>Load trace/timing information</h2>
<p>This is the short hack I came up with but it's substantially longer than 4 lines :)</p>
<c>
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().qq[ $m done
.\n];}}" -e "use strict; use warnings;use LWP::UserAgent;"
</c>
<c>
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];
}
}
</c>
<h2>Check that <tt>[cpan://File::Spec]->path</tt> works sanely on Win32</h2>
<c>
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
</c>
<h2>Using [cpan://DBD::WMI] to get (and reconfigure) the DNS resolution order</h2>
<c>
#!/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']);
}
</c>
<h2>The Revolution Will Not Be In A Bulleted List</h2>
<ul>
<li>The Revolution Will Not Be Televised</li>
<li>The Revolution Will Not Be Webcast</li>
<li>The Revolution Will Not Have Rounded Corners</li>
<li>The Revolution Will Not Be Verified</li>
<li>The Revolution's FAQ Will Not Be Archived At <c>rtfm.mit.edu</c></li>
</ul>
<h2>Grand pile of projects</h2>
<ul>
<li>Optimize <c><></c> in void context so it just skips forward to the next occurrence of <c>$/</c> without wasting memory.</li>
<li>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.</li>
<li>Write a test for Perl as outlined in [http://www.nntp.perl.org/group/perl.perl5.porters/114256]</li>
<li>Create [google://Google Sitemap] files from PM:
<ul>
<li>Users should be "fairly recent", based on their lastedit times</li>
<li>Nonuser nodes older than a month should become virtually static</li>
<li>All items should live in the robot playpen</li>
</ul>
</li>
<li>Look at [cpan://App::Info] to let <c>Alien::Util</c> offer locally installed versions instead of building perl-owned versions</li>
</ol>
<li>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:
<ol>
<li>Use [http://ffmpeg.mplayerhq.hu/|ffmpeg] or ImageMagick to extract frames from video</li>
<li>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)</li>
<li>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</li>
<li>Recomposite the movie, inserting actors at will</li>
<li>[http://www.ee.iitb.ac.in/~icvgip/PAPERS/154.pdf|Paper on sprite/mosaic generation from movies] - a "sprite" in their lingo is the background, not the actor in the foreground</li>
<li>[http://www-static.cc.gatech.edu/gvu/perception//projects/videotexture/SIGGRAPH2000/vtbody.htm|Automatically creating random looped videos] by estimating the cost between frames to generate split/cut points</li>
</ol>
</li>
</ul>
<h2>How to construct a static query for dynamic parameters</h2>
<p>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.</p><p>
The idea is to guard all query parameters with a second parameter
indicating if that parameter is to be used. Starting from:
</p>
<c>
SELECT COUNT(*)
FROM mx_forums
WHERE id=? OR category = ?
-- $q->param('forum'), $q->param('category')
</c>
<p>we want to add a second clause guarding the <c>id</c>
and another one guarding <c>category</c>:</p>
<c>
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')
</c>
<p>Now you need to pass the two additional parameters:</p>
<c>
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
) { ... }
</c>
<h2>Using clauses with [cpan://SQL::Abstract]::Clauses (yet-to-be released)</h2>
<p>The following statement is used to find all values for the columns <tt>artist</tt> and <tt>album</tt> that refine/subdivide the current result set.
</p>
<code>
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";
}
</code>
<hr />
<h2>Another stab at making IPC::Open3 <c>select</c>able</h2>
<c>
#!/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, because
# 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{sleep 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.";
</c>
<h2>Nodes whose content was overwritten and which can't be restored</h2>
<br />[id://641995]