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
##
@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.";