| Public Scratchpad | Download, Select Code To D/L |
[Tue Mar 27 11:33:03 2007] testcore.cgi: install_driver(Oracle) failed +: Can't load '/usr/people/chemboy/lib/perl5/site_perl/5.8.1/i586-linu +x-thread-multi/auto/DBD/Oracle/Oracle.so' for module DBD::Oracle: lib +clntsh.so.9.0: cannot open shared object file: No such file or direct +ory at /usr/lib/perl5/5.8.1/i586-linux-thread-multi/DynaLoader.pm lin +e 229. [Tue Mar 27 11:33:03 2007] testcore.cgi: at (eval 27) line 3 [Tue Mar 27 11:33:03 2007] testcore.cgi: Compilation failed in require + at (eval 27) line 3. [Tue Mar 27 11:33:03 2007] testcore.cgi: Perhaps a required shared lib +rary or dll isn't installed where expected
merge into some_table OLD using ( select ? "A", ? "B", ? "C", ? "D" from dual ) NEW on (OLD.A = NEW.A and OLD.B = NEW.B) when matched then update set calc_date = sysdate, C = NEW.C, D = NEW.D when not matched then insert(A,B,C,D,calc_date) values(NEW.A,NEW.B,NEW.C,NEW.D,sysdate)
At this point, this only segfaults on 5.8.1 on Linux (2.4.21-303-smp4G). I've had versions of it that segfault on 5.6.1 on Linux, but I'm curiously unable to get that to happen at the moment (at one point, it segfaulted on 5.6.1 on one Linux but not another, which annoyed the heck out of me). On 5.6.1 on SGI/Irix, I haven't been able to get segfaults at all.
package AutoRequire; use 5.006; use strict; no strict 'refs'; use warnings; our $VERSION = substr q$Revision: 1.0$, 9; my %loadable; our $AUTOLOAD; sub import { my $self = shift; foreach (@_) { my $PACKAGE = $_; $DB::single=1; (my $pfile = "$PACKAGE.pm") =~ s#::#/#g; $loadable{$PACKAGE} = 1; my $full_auto = $PACKAGE . "::AUTOLOAD"; *{$full_auto} = sub { my $subname = $AUTOLOAD; my ($pkg,$sub) = $AUTOLOAD =~ / ^ ( \w+ (?: :: \w+)* ) :: ( \w+ ) \z /x; if ( delete $loadable{$PACKAGE} ) { require $pfile; # commenting out this line removes the segfault delete ${$PACKAGE."::"}{AUTOLOAD}; if ($PACKAGE eq $pkg) { print STDERR "This is the branch we execute\n"; goto &$subname; } } } } } 1;
package SimpleCase; our @ISA; # not explicitly set sub new { return "This is a very simple case"; } 1;
#!/usr/local/bin/perl use lib '.'; use AutoRequire 'SimpleCase'; print STDERR "Still alive...\n"; my $var = SimpleCase->new; print STDERR "We never get here\n";
sub findMagicname { my @userids = @_; my ($sth, $dbh,@ret); $dbh=DBI->connect_cached('DBI:ODBC:CHDDB', 'someid', 'somepass', {Ra +iseError =>1, PrintError =>0, ShowErrorStatement =>0}); $sth = $dbh->prepare_cached( "SELECT [Last Name] AS Last, [First Nam +e] AS First FROM _SMDBA_.[Support Staff] WHERE [Login ID]=?",{ChopBla +nks=>1} ); foreach my $userid (@userids) { $sth->execute($userid); my $row = $sth->fetchrow_hashref; push @ret, "$row->{First} $row->{Last}"; $sth->finish(); } wantarray ? @ret : $ret[0] } sub findMagicname { my @userids = @_; my ($sth, $dbh); #$userid = "l373l8"; $dbh=DBI->connect_cached('DBI:ODBC:CHDDB', 'someid', 'somepass', {Ra +iseError =>1, PrintError =>0, ShowErrorStatement =>0}); $sth = $dbh->prepare_cached( "SELECT [Last Name] AS Last, [First Nam +e] AS First FROM _SMDBA_.[Support Staff] WHERE [Login ID]=?", {'ChopB +lanks' => 1 } ); $sth->execute($userid); $sth->; #----Removes extra spaces from fixed char fields. See netToo +ls_help.doc. my $row = $sth->fetchrow_hashref; $sth->finish(); return $row->{First}. " " .$row->{Last}; }
Purpose: produce a constructor that maintains a 1:1 mapping between one argument ("ID", usually) and objects returned, then falls back on a superclass to do the actual construction work.
install_unique_constructor($new_child_class,"id"); sub install_unique_constructor { no strict 'refs'; my ($unique,$class) = @_; $class ||= caller; my %singleton; eval "package $class;" . q| sub new { my $class = shift; # this behavior should be consistent: my %args = 1 == @_ ? (id=>@_) : @_; my $key = $args{$unique}; my $self = $singleton{$key}; unless ( $self ) { $self = $class->SUPER::new(@_); $singleton{$key} = $self; } return $self; }; 1; |; }
This raises "will not stay shared" errors on $unique and %singleton.
sub scalar_install { no strict 'refs'; my ($class,$field) = @_; my %closed; *{$class . "::$field" } = sub { my $self = shift; if (@_) { $closed{$self} = $_[0]; } else { $closed{$self} } }; 1; }
function wwwEncodeObject(o) { var params = new Array(); for (var f in o) { var fieldname = escape(f).replace(/\+/g,'%2B'); var value = o[f]; switch(typeof(value)) { case 'string': case 'number': params.push(fieldname + "=" + escape(value).replace(/\+/g, +'%2B')); break; case 'boolean': params.push(fieldname + (value ? "=1" : "=")); break; case 'object': //Handle arrays logically. Other objects, die if(value.constructor != Array) throw("Can't handle non-Arr +ay objects"); for (var i = 0; i < value.length; i++) params.push(fieldname + "=" + escape(value[i]).replace +(/\+/g,'%2B')); } } return params.join('&') }
mysql> select count(1) from foo where remote in (select remote from ba +r); +----------+ | count(1) | +----------+ | 5750 | +----------+ 1 row in set (0.30 sec) mysql> select count(1) from foo ; +----------+ | count(1) | +----------+ | 94587 | +----------+ 1 row in set (0.01 sec) mysql> select count(1) from foo where remote not in (select remote fro +m bar); +----------+ | count(1) | +----------+ | 56 | +----------+ 1 row in set (0.45 sec)
Then...<table> <TMPL_LOOP name=ROWS> <TR><TD><TMPL_VAR name=key></td><td><TMPL_VAR name=value></td</tr> </TMPL_LOOP> </table>
$tmpl->param(ROWS => [ map +{key =>$_, value => $data{$_} }, keys %data ] )
require subs; my @autogen = qw(Foo Bar Trope Cliche); foreach my $thing (@autogen) { my @subs = map "$_$thing", qw(High Low Middle); push @EXPORT_OK, @subs; subs->import(@subs); } sub AUTOLOAD { if ($AUTOLOAD =~ /@{[__PACKAGE__]}::(High|Low|Middle)(\w+)$/ and grep($2 eq $_, @autogen) ) { my $sub = $dispatch{$1}; my $thing = $2; *$AUTOLOAD = sub { $sub->(thing => $thing, args => [@_]) }; goto &$AUTOLOAD; } else { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } }
$query = $ENV{QUERY_STRING}; if (defined($query) && $query ne '') { foreach (split (/&/, $query)) { #change to /[&;]/, right? y/+/ /; s/%(..)/sprintf("%c", hex($1))/ge; # unquote %-quoted #change above to chr hex $1? if (/(\S+)=(.*)/) { # change \S to [^=], I'd say $input{$1} = $2 if ($2 ne ""); #and what if it is? } else { $input{$_}++; } } }
while (<>) { push @input, lc =~ /[a-z]/g; while ( @input > 1 ) { my ($let1,$let2) = splice @input,0,2; if ($let2 eq $let1) { unshift @input, $let2; $let2 = ($let2 eq 'x') ? 'z': 'x'; } push @output, transcribe ($let1,$let2); } } if (@input) { push @output, transcribe ($input[0],($input[0] eq 'x') ? 'z': 'x') +; }
package Crash; use 5.006; use strict; use warnings; use Carp; use overload '0+' => sub {$_[0]}, '""' => sub {my $self = shift; ref ($self).' => '.$self->getPK}, eq => sub { ref $_[1] eq ref $_[0] ? $_[0] == $_[1] : "$_[0]" eq " +$_[1]" }, fallback => 1; sub new {bless {}, __PACKAGE__} sub getPK {"Fred"} 1;
% perl -MCrash -de1 Default die handler restored. Loading DB routines from perl5db.pl version 1.07 Editor support available. Enter h or `h h' for help, or `man perldebug' for more help. main::(-e:1): 1 DB<1> $a = Crash->new DB<2> $b = Crash->new DB<3> s $a eq $b main::((eval 6)[/usr/local/lib/perl5/5.6.1/perl5db.pl:1521]:3): 3: $a eq $b; DB<<4>> s Crash::CODE(0x1021d1b8)(Crash.pm:11): 11: eq => sub { ref $_[1] eq ref $_[0] ? $_[0] == $_[1] : "$_[ +0]" eq "$_[1]" }, DB<<4>> x $_ Signal BUS at /usr/local/lib/perl5/5.6.1/perl5db.pl line 1399 DB::DB called at Crash.pm line 11 Crash::__ANON__[Crash.pm:11]('Crash => Fred', 'Crash => Fred', + '') called at (eval 6)[/usr/local/lib/perl5/5.6.1/perl5db.pl:1521] l +ine 3 eval '($@, $!, $^E, $,, $/, $\\, $^W) = @saved;package main; $ +^D = $^D | $DB::db_stop; $DB::single = 1; $a eq $b; ;' called at /usr/local/lib/perl5/5.6.1/perl5db.pl line 1521 DB::eval called at /usr/local/lib/perl5/5.6.1/perl5db.pl line +1399 DB::DB called at -e line 1 Abort
Expected startup message is something like this (cribbed from here):
tulip.c:v0.91 4/14/99 <EMAIL: PROTECTED> eth0: Digital DS21140 Tulip rev 18 at 0xd000, 00:00:C0:31:35:E4, IRQ 1 +2. eth0: Old format EEPROM on `SMC9332DST` board. Using substitute media + control info. eth0: EEPROM default media type Autosense. eth0: Index #0 - Media 10baseT (#0) described by a 21140 non-MII (0) +block. eth0: Index #1 - Media 100baseTx (#3) described by a 21140 non-MII (0 +)
But what I get is this:
Linux Tulip driver version 0.9.15-pre7 (Oct 2, 2001) PCI: Enabling device 00:0e.0 (0004->0007) tulip0: Old format EEPROM on 'Asante' board. Using substitute media co +ntrol info. eth0: Digital DS21140 Tulip rev 32 at 0xcb937000, <HWADDY SUPPRESSED>, + IRQ 24.
Vital stats:
Yellow Dog Linux 2.1
Kernel 2.4.10-12a
Asante Etherfast 10/100 card (I think).
Card is known to work with this hardware (PM 7300) under MacOS 7.5.5
DB<45> T $ = XML::ValidWriter::_self called from file `site_perl/XML/ValidWrite +r.pm' line 1232 $ = XML::ValidWriter::setDoctype(ref(XML::ValidWriter), ref(XML::Docty +pe)) called from file `site_perl/XML/ValidWriter.pm' line 518 $ = XML::ValidWriter::import('XML::ValidWriter', ':all', ':dtd_tags') +called from file `scratch/validwriter_fun' line 18
sub setDoctype { my XML::ValidWriter $self = &_self ; $self->{DOCTYPE} = shift if @_ ; return ; } sub _self { ## MUST be called as C< &_self ;> ## If it's a reference to anything but a plain old hash, then the ## first param is either an XML::ValidWriter, a reference to a glob ## a reference to a SCALAR, or a reference to an IO::Handle. return shift if ( @_ && ref $_[0] && isa( $_[0], 'XML::ValidWriter' + ) ) ; my $callpkg = caller(1) ; croak "No default XML::ValidWriter declared for package '$callpkg'" unless $pkg_writers{$callpkg} ; return $pkg_writers{$callpkg} ; }
Benchmarks for method 1: total: 347 secs (315.12 usr 0.86 sys = 315.98 cpu) overhead: 0 secs ( 0.00 usr 0.00 sys = 0.00 cpu) loop: 347 secs (315.12 usr 0.86 sys = 315.98 cpu) Benchmarks for method 2: total: 178 secs (166.28 usr 0.65 sys = 166.93 cpu) overhead: 1 secs ( 0.17 usr 0.01 sys = 0.18 cpu) loop: 177 secs (166.11 usr 0.64 sys = 166.75 cpu) Benchmarks for method 3: total: 157 secs (148.77 usr 0.86 sys = 149.63 cpu) overhead: 31 secs (29.17 usr 0.36 sys = 29.53 cpu) loop: 126 secs (119.60 usr 0.50 sys = 120.10 cpu) Benchmarks for method 4: total: 95 secs (84.78 usr 0.57 sys = 85.35 cpu) overhead: 14 secs (13.68 usr 0.16 sys = 13.84 cpu) loop: 81 secs (71.10 usr 0.41 sys = 71.51 cpu)
Benchmarks for method 1: total: 64 wallclock secs (60.37 usr + 1.82 sys = 62.19 CPU) overhead: 0 wallclock secs ( 0.00 usr + 0.00 sys = 0.00 CPU) loop: 64 wallclock secs (60.37 usr + 1.82 sys = 62.19 CPU) Benchmarks for method 2: total: 45 wallclock secs (42.75 usr + 1.36 sys = 44.11 CPU) overhead: 0 wallclock secs ( 0.05 usr + 0.00 sys = 0.05 CPU) loop: 45 wallclock secs (42.70 usr + 1.36 sys = 44.06 CPU) Benchmarks for method 3: total: 56 wallclock secs (53.67 usr + 1.16 sys = 54.83 CPU) overhead: 17 wallclock secs (16.56 usr + 0.05 sys = 16.61 CPU) loop: 39 wallclock secs (37.11 usr + 1.11 sys = 38.22 CPU) Benchmarks for method 4: total: 35 wallclock secs (32.78 usr + 1.33 sys = 34.11 CPU) overhead: 8 wallclock secs ( 7.74 usr + 0.01 sys = 7.75 CPU) loop: 27 wallclock secs (25.04 usr + 1.32 sys = 26.36 CPU)
ChemBoy's bug-inducing sig:
<p><br><hr><i>If God had meant us to fly, he would *never* have given +us the railroads.<br> --Michael Flanders</i></p>