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 #### 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' #### 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; #### #! 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; #### 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; #### 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); }; #### 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] #### my @data = $cv->recv() #### my @result = $plugin->execute('1+1'); # sends data over to Firefox, and returns the response #### 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 }; #### 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 as a read-only filehandle. =head1 METHODS =head2 C<< ->new ReadMember >> The C<< ->new >> constructor takes the same arguments as LC<< ->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. =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 =head1 COPYRIGHT This file is copyright (2009) Max Maischein L This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut #### #!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 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 use 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 passed into indent -X include "XSUB.h" (and undefine PERL_CORE) =cut #### #!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" }; #### 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) #### #!/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; }; }; #### use strict; use threads; use Thread::Queue; my $threadcount = 4; =head2 C Launches C<$threadcount> threads that process the items in C in parallel. Returns the input queue, output queue and an array reference to the threads. The aliasing effect of C 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 Processes a list in parallel and returns the results in the order they were finished. The aliasing effect of C 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 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 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); #### @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 #### #!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 #### sub GimmeStdErr(@){ # ... bangles, tangles and spaghetti! local *R, *W; pipe R,W; if(fork){ close W; }else{ close R; open STDERR, ">&W"; exec @_ } }; #### =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 }; #### 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;" #### 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]; } } #### 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 } ; 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 #### #!/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(<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']); } #### SELECT COUNT(*) FROM mx_forums WHERE id=? OR category = ? -- $q->param('forum'), $q->param('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') #### 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 ) { ... } #### 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"; } #### #!/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.";