scratchpad
Corion
<h1>SQL window functions and where clauses and subselects</h1>
<c>
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" clause
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
</c>
<h1>Count of Perl 5 / Perl 6 meditations</h1>
<pre class="code"><tt class='codetext'><font size="-1">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 <span class="line-breaker">
<font color="red">+</font></span>(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
</font></tt></pre>
(50 rows)
<br /><table border="1" cellpadding="2" cellspacing="2"> <tr>
<td align="center" bgcolor="#CC99CC"><font color="#000000">count(*)</font></td>
<td align="center" bgcolor="#CC99CC"><font color="#000000">year</font></td>
<td align="center" bgcolor="#CC99CC"><font color="#000000">title_type</font></td>
</tr>
<tr>
<td>7</td>
<td>1999</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>351</td>
<td>2000</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>7</td>
<td>2000</td>
<td>Perl 6</td>
</tr>
<tr>
<td>4</td>
<td>2001</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>1221</td>
<td>2001</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>18</td>
<td>2001</td>
<td>Perl 6</td>
</tr>
<tr>
<td>10</td>
<td>2002</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>989</td>
<td>2002</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>30</td>
<td>2002</td>
<td>Perl 6</td>
</tr>
<tr>
<td>7</td>
<td>2003</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>723</td>
<td>2003</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>12</td>
<td>2003</td>
<td>Perl 6</td>
</tr>
<tr>
<td>3</td>
<td>2004</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>658</td>
<td>2004</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>14</td>
<td>2004</td>
<td>Perl 6</td>
</tr>
<tr>
<td>2</td>
<td>2005</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>701</td>
<td>2005</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>23</td>
<td>2005</td>
<td>Perl 6</td>
</tr>
<tr>
<td>2</td>
<td>2006</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>469</td>
<td>2006</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>13</td>
<td>2006</td>
<td>Perl 6</td>
</tr>
<tr>
<td>6</td>
<td>2007</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>378</td>
<td>2007</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>15</td>
<td>2007</td>
<td>Perl 6</td>
</tr>
<tr>
<td>7</td>
<td>2008</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>324</td>
<td>2008</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>10</td>
<td>2008</td>
<td>Perl 6</td>
</tr>
<tr>
<td>1</td>
<td>2009</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>273</td>
<td>2009</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>6</td>
<td>2009</td>
<td>Perl 6</td>
</tr>
<tr>
<td>4</td>
<td>2010</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>178</td>
<td>2010</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>5</td>
<td>2010</td>
<td>Perl 6</td>
</tr>
<tr>
<td>2</td>
<td>2011</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>234</td>
<td>2011</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>1</td>
<td>2011</td>
<td>Perl 6</td>
</tr>
<tr>
<td>6</td>
<td>2012</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>155</td>
<td>2012</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>5</td>
<td>2012</td>
<td>Perl 6</td>
</tr>
<tr>
<td>4</td>
<td>2013</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>489</td>
<td>2013</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>3</td>
<td>2013</td>
<td>Perl 6</td>
</tr>
<tr>
<td>2</td>
<td>2014</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>401</td>
<td>2014</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>2</td>
<td>2014</td>
<td>Perl 6</td>
</tr>
<tr>
<td>5</td>
<td>2015</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>77</td>
<td>2015</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>4</td>
<td>2015</td>
<td>Perl 6</td>
</tr>
<tr>
<td>12</td>
<td>2016</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>2</td>
<td>2016</td>
<td>Perl 6</td>
</tr>
</table>
<h1>Count of Perl 5 / Perl 6 questions</h1>
<hr /><pre class="code"><tt class='codetext'><font size="-1">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 <span class="line-breaker">
<font color="red">+</font></span>(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
</font></tt></pre>
(51 rows)
<br /><table border="1" cellpadding="2" cellspacing="2"> <tr>
<td align="center" bgcolor="#CC99CC"><font color="#000000">count(*)</font></td>
<td align="center" bgcolor="#CC99CC"><font color="#000000">year</font></td>
<td align="center" bgcolor="#CC99CC"><font color="#000000">title_type</font></td>
</tr>
<tr>
<td>18</td>
<td>1999</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>6</td>
<td>2000</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>3190</td>
<td>2000</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>2</td>
<td>2000</td>
<td>Perl 6</td>
</tr>
<tr>
<td>30</td>
<td>2001</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>8353</td>
<td>2001</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>5</td>
<td>2001</td>
<td>Perl 6</td>
</tr>
<tr>
<td>39</td>
<td>2002</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>8898</td>
<td>2002</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>6</td>
<td>2002</td>
<td>Perl 6</td>
</tr>
<tr>
<td>62</td>
<td>2003</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>9225</td>
<td>2003</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>11</td>
<td>2003</td>
<td>Perl 6</td>
</tr>
<tr>
<td>51</td>
<td>2004</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>9170</td>
<td>2004</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>6</td>
<td>2004</td>
<td>Perl 6</td>
</tr>
<tr>
<td>36</td>
<td>2005</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>9668</td>
<td>2005</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>19</td>
<td>2005</td>
<td>Perl 6</td>
</tr>
<tr>
<td>36</td>
<td>2006</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>7375</td>
<td>2006</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>10</td>
<td>2006</td>
<td>Perl 6</td>
</tr>
<tr>
<td>31</td>
<td>2007</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>6795</td>
<td>2007</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>13</td>
<td>2007</td>
<td>Perl 6</td>
</tr>
<tr>
<td>52</td>
<td>2008</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>7146</td>
<td>2008</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>23</td>
<td>2008</td>
<td>Perl 6</td>
</tr>
<tr>
<td>46</td>
<td>2009</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>7941</td>
<td>2009</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>9</td>
<td>2009</td>
<td>Perl 6</td>
</tr>
<tr>
<td>41</td>
<td>2010</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>6450</td>
<td>2010</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>29</td>
<td>2010</td>
<td>Perl 6</td>
</tr>
<tr>
<td>40</td>
<td>2011</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>6434</td>
<td>2011</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>11</td>
<td>2011</td>
<td>Perl 6</td>
</tr>
<tr>
<td>44</td>
<td>2012</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>6335</td>
<td>2012</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>13</td>
<td>2012</td>
<td>Perl 6</td>
</tr>
<tr>
<td>32</td>
<td>2013</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>5811</td>
<td>2013</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>7</td>
<td>2013</td>
<td>Perl 6</td>
</tr>
<tr>
<td>21</td>
<td>2014</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>4211</td>
<td>2014</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>13</td>
<td>2014</td>
<td>Perl 6</td>
</tr>
<tr>
<td>24</td>
<td>2015</td>
<td>Perl 5 (explicit)</td>
</tr>
<tr>
<td>3518</td>
<td>2015</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>10</td>
<td>2015</td>
<td>Perl 6</td>
</tr>
<tr>
<td>359</td>
<td>2016</td>
<td>Perl 5 (implicit)</td>
</tr>
<tr>
<td>2</td>
<td>2016</td>
<td>Perl 6</td>
</tr>
</table>
<h1>SQL statements for migrating columns between an EAV-table and a plain table in both directions</h1>
<p>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.</p>
<p>One drawback of this dual approach is that SQL queries querying the large table <c>foo</c> 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.</p>
<c>
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'
</c>
<h1>My SQLite queue</h1>
<c>
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, {RaiseError => 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;
</c>
<h1>Pads are threadsafe/thread-local</h1>
<c>
#! 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;
</c>
<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]