Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight
 
PerlMonks  

Limbic~Region's scratchpad

by Limbic~Region (Chancellor)
on Jun 01, 2004 at 14:35 UTC ( #358097=scratchpad: print w/ replies, xml ) Need Help??

Would prefer to make this a single regular expression but avoid (?{ code }) if possible but have no issue with /e

sub format_string { my ($str) = @_; return $str if ! $str; my $new_str = ''; for my $chr (split '', $str) { my $ord = ord($chr); if ($ord < 255) { $new_str .= $chr; next; } $new_str .= '&#x' . sprintf("%x", $ord) . ';'; } return $new_str; }

For BrowserUk:
When I do alt+space and hit any arrow key, I can then use my mouse alone to re-position the window. I think the following might work for moving a window to a desired X,Y.

my $wid = WaitWindow('Notepad', 5); # Paranoia - make sure we are affecting the desired window SetActiveWindow($wid); SetFocus($wid); SetForegroundWindow($wid); # Used to determine where to move the mouse later my ($left, $top, $right, $bottom) = GetWindowRect($wid); # Enable moving the mouse to move the window # I *THINK* this will work SendKeys("%{SPACE}M{DOWN}"); my ($x, $y) = calculate_position_from($left, $top, $right, $bottom); MouseMoveAbsPix($x,$y); SendKeys("{ENTER}");

From BrowserUk:

## Shared the array of select ids my @id :shared; ## Select them while (my $rec = $sth->fetchrow_hashref) { push @id, $rec->{unique_id} if desired_rec($rec); } ## Set the number of threads--start with 1 per core our $T //= 4; ## break up the array into non-overlapping ranges my( $step, $s, @ranges ) = ( int @id / $T, 0 ); push( @ranges, [ $s, $s + $step -1 ] ), $s += $step for 1 ..$T; $ranges[ -1][1] = scalar @id; my @threads; ## Loop over those ranges for my $range ( @ranges ) { ##starting a new thread for each push @threads, async { ## Create a new handle in each thread my $dbh = DBI->connect( ... ) or die ..; my $del_sth = $dbh->prepare("DELETE FROM TBL WHERE unique_id = + ?"); ## process the subrange one at a time for( @id[ @$range ] ) { eval { $del_sth->execute($_); }; $logger->write("Failed to remove '$_'") if $@; } ## till done $dbh->disconnect; }; } ## Wait for them $_->join for @threads;

For moritz/BrowserUk/ambrus/bart/blokhead
Here is the abstracted code I was trying to convert from recursion to iteration through a @stack. While iterative versions of the red/black tree are fairly straight forward, they require an additional slot for the parent. I want both fast and compact. Function calls in perl are slow and I am hoping to get a speedup by converting the call stack into a user stack. I finally figured it out - see below:

sub _insert { my ($node, $cmp, $key, $val) = @_; return [RED, $key, $val, undef, undef] if ! $node; # Do foo with $node my $result = $key cmp $node->[KEY]; if ($result == EQUAL) { $node->[VALUE] = $val; } elsif ($result == MORE) { $node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val); } else { $node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val); } # Do bar with $node # Do blah with $node return $node; }
Not thoroughly tested for dup inserts, but appears to be working
sub _insert { my ($node, $cmp, $key, $val) = @_; my ($found, @stack); while ($node) { _colorFlip($node) if _isRed($node->[RIGHT]) && _isRed($node->[ +LEFT]); push @stack, [$node, undef]; my $result = $cmp->($key, $node->[KEY]); # Dup key, replace value if ($result == EQUAL) { ($found, $node->[VALUE]) = (1, $val); $node = undef; } # Descend right elsif ($result == MORE) { $stack[LAST][DIR] = RIGHT; $node = $node->[RIGHT]; } # Descend right else { $stack[LAST][DIR] = LEFT; $node = $node->[LEFT]; } } push @stack, [[RED, $key, $val, undef, undef], undef] if ! $found; my $assign; while (@stack) { my $unwind = pop @stack; my ($item, $dir) = @{$unwind}[NODE, DIR]; if ($assign || $found) { $item->[$dir] = $assign->[NODE] if $assign; $item = _rotateLeft($item) if _isRed($item->[RIGHT]) && ! + _isRed($item->[LEFT]); $item = _rotateRight($item) if _isRed($item->[LEFT]) && + _isRed($item->[LEFT][LEFT]); } $assign = [$item, undef]; } return $assign->[NODE]; }
And below, is the current work in progress.
package Tree::Binary::RedBlack; require Exporter; @ISA = 'Exporter'; @EXPORT = qw/ deleteKey deleteMax deleteMin insert key_exists lookup max min new_rb node_count /; our $VERSION = '0.01'; # Tree definition use constant ROOT => 0; use constant COUNT => 1; use constant COMPARE => 2; # Node definition use constant COLOR => 0; use constant KEY => 1; use constant VALUE => 2; use constant RIGHT => 3; use constant LEFT => 4; # Color definition use constant BLACK => 0; use constant RED => 1; # Comparison definition use constant LESS => -1; use constant EQUAL => 0; use constant MORE => 1; # Truth definition use constant TRUE => 1; use constant FALSE => undef; # Stack definition use constant LAST => -1; use constant NODE => 0; use constant DIR => 1; use strict; use warnings; use Carp; use UNIVERSAL 'isa'; # Public sub new_rb { croak "Incorrect number of parameters" if @_ % 2; my %opt = @_; my $cmp = delete $opt{compare} || 'cmp'; if (isa($cmp, 'CODE')) { *_insert = *_insert_custom; } elsif($cmp eq 'cmp') { #*_insert = *_insert_ascii; *_insert = *_insert_cmp; } else { croak "The '$cmp' comparison is not supported"; } carp "The '$_' parameter is not supported\n" for keys %opt; return [undef, 0, $cmp]; } # Public sub insert { my ($tree, $key, $val) = @_; $tree->[ROOT] = _insert($tree->[ROOT], $tree->[COMPARE], $key, $va +l); $tree->[COUNT]++; $tree->[ROOT][COLOR] = BLACK; } # Private sub _insert_custom { my ($node, $cmp, $key, $val) = @_; return [RED, $key, $val, undef, undef] if ! $node; if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $n +ode->[LEFT][COLOR]) { $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } my $result = $cmp->($key, $node->[KEY]); if ($result == EQUAL) { $node->[VALUE] = $val; } elsif ($result == MORE) { $node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val); } else { $node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val); } if ($node->[RIGHT] && $node->[RIGHT][COLOR] && ! ($node->[LEFT] && + $node->[LEFT][COLOR])) { my $temp = $node->[RIGHT]; $node->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] & +& $node->[LEFT][LEFT][COLOR]) { my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } return $node; } sub _insert_cmp { my ($node, $cmp, $key, $val) = @_; return [RED, $key, $val, undef, undef] if ! $node; if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] && $n +ode->[LEFT][COLOR]) { $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } my $result = $key cmp $node->[KEY]; if ($result == EQUAL) { $node->[VALUE] = $val; } elsif ($result == MORE) { $node->[RIGHT] = _insert($node->[RIGHT], $cmp, $key, $val); } else { $node->[LEFT] = _insert($node->[LEFT], $cmp, $key, $val); } if ($node->[RIGHT] && $node->[RIGHT][COLOR] && ! ($node->[LEFT] && + $node->[LEFT][COLOR])) { my $temp = $node->[RIGHT]; $node->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT][LEFT] & +& $node->[LEFT][LEFT][COLOR]) { my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } return $node; } sub _insert_ascii { my ($node, $cmp, $key, $val) = @_; my ($found, @stack); while ($node) { if ($node->[RIGHT] && $node->[RIGHT][COLOR] && $node->[LEFT] & +& $node->[LEFT][COLOR]) { $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } my $result = $key cmp $node->[KEY]; # Descend right if ($result == LESS) { push @stack, [$node, LEFT]; $node = $node->[LEFT]; } # Descend right elsif ($result == MORE) { push @stack, [$node, RIGHT]; $node = $node->[RIGHT]; } # Dup key, replace value else { push @stack, [$node]; ($found, $node->[VALUE]) = (1, $val); $node = undef; } } push @stack, [[RED, $key, $val, undef, undef]] if ! $found; my $idx = @stack; my $assign; while ($idx--) { my ($item, $dir) = @{$stack[$idx]}[NODE, DIR]; if ($assign || $found) { $item->[$dir] = $assign->[NODE] if $assign; if ($item->[RIGHT] && $item->[RIGHT][COLOR] && ! ($item->[ +LEFT] && $item->[LEFT][COLOR])) { my $temp = $item->[RIGHT]; $item->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $item; $temp->[COLOR] = $item->[COLOR]; $item->[COLOR] = RED; $item = $temp; } if ($node->[LEFT] && $node->[LEFT][COLOR] && $node->[LEFT] +[LEFT] && $node->[LEFT][LEFT][COLOR]) { my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; $node = $temp; } } $assign = [$item]; } return $assign->[NODE]; } sub lookup { my ($tree, $key) = @_; return FALSE if ! defined $key; my ($root, $cmp) = ($tree->[ROOT], $tree->[COMPARE]); while ($root) { my $result = $cmp->($key, $root->[KEY]); return $root->[VALUE] if $result == EQUAL; $root = $result == LESS ? $root->[LEFT] : $root->[RIGHT]; } return FALSE; } sub key_exists { my ($tree, $key) = @_; return FALSE if ! defined $key; my ($root, $cmp) = ($tree->[ROOT], $tree->[COMPARE]); while ($root) { my $result = $cmp->($key, $root->[KEY]); return TRUE if $result == EQUAL; $root = $result == LESS ? $root->[LEFT] : $root->[RIGHT]; } return FALSE; } sub node_count { my ($tree) = @_; return $tree->[COUNT]; } sub deleteMin { my ($tree) = @_; $tree->[ROOT] = _deleteMin($tree->[ROOT]); $tree->[COUNT]-- if $tree->[COUNT]; $tree->[ROOT][COLOR] = BLACK; } sub deleteKey { my ($tree, $key) = @_; $tree->[ROOT] = _deleteKey($tree->[ROOT], $tree->[COMPARE], $key); $tree->[COUNT]-- if $tree->[COUNT]; $tree->[ROOT][COLOR] = BLACK; } sub max { my ($tree, $key) = @_; return FALSE if ! $tree->[ROOT]; return _max($tree->[ROOT]); } sub min { my ($tree, $key) = @_; return FALSE if ! $tree->[ROOT]; return _min($tree->[ROOT]); } sub deleteMax { my ($tree) = @_; $tree->[ROOT] = _deleteMax($tree->[ROOT]); $tree->[COUNT]-- if $tree->[COUNT]; $tree->[ROOT][COLOR] = BLACK; } # Private sub _deleteMax { my ($node) = @_; $node = _rotateRight($node) if _isRed($node->[LEFT]); return FALSE if ! $node->[RIGHT]; $node = _moveRedRight($node) if ! _isRed($node->[RIGHT]) && ! _isR +ed($node->[RIGHT][LEFT]); $node->[RIGHT] = _deleteMax($node->[RIGHT]); return _fixUp($node); } sub _deleteKey { my ($node, $cmp, $key) = @_; if ($cmp->($key, $node->[KEY]) == LESS) { $node = _moveRedLeft($node) if ! _isRed($node->[LEFT]) && ! _i +sRed($node->[LEFT][LEFT]); $node->[LEFT] = _deleteKey($node->[LEFT], $cmp, $key); } else { $node = _rotateRight($node) if _isRed($node->[LEFT]); return FALSE if $cmp->($key, $node->[KEY]) == EQUAL && ! $node +->[RIGHT]; $node = _moveRedRight($node) if ! _isRed($node->[RIGHT]) && ! +_isRed($node->[RIGHT][LEFT]); if ($cmp->($key, $node->[KEY]) == EQUAL) { # Opportunity to return key/val together $node->[VALUE] = _get($node->[RIGHT], $cmp, _min($node->[R +IGHT])); $node->[KEY] = _min($node->[RIGHT]); $node->[RIGHT] = _deleteMin($node->[RIGHT]); } else { $node->[RIGHT] = _deleteKey($node->[RIGHT], $key); } } return _fixUp($node); } sub _get { my ($node, $cmp, $key) = @_; return FALSE if ! $node; my $result = $cmp->($key, $node->[KEY]); return $node->[VALUE] if $result == EQUAL; return _get($node->[LEFT], $cmp, $key) if $result == LESS; return _get($node->[RIGHT], $cmp, $key); } sub _min { my ($node) = @_; return $node->[KEY] if ! $node->[LEFT]; return _min($node->[LEFT]); } sub _max { my ($node) = @_; return $node->[KEY] if ! $node->[RIGHT]; return _max($node->[RIGHT]); } sub _deleteMin { my ($node) = @_; return FALSE if ! $node->[LEFT]; $node = _moveRedLeft($node) if ! _isRed($node->[LEFT]) && ! _isRed +($node->[LEFT][LEFT]); $node->[LEFT] = _deleteMin($node->[LEFT]); return _fixUp($node); } sub _moveRedLeft { my ($node) = @_; _colorFlip($node); if (_isRed($node->[RIGHT][LEFT])) { $node->[RIGHT] = _rotateRight($node->[RIGHT]); $node = _rotateLeft($node); _colorFlip($node); } return $node; } sub _moveRedRight { my ($node) = @_; _colorFlip($node); if (_isRed($node->[LEFT][LEFT])) { $node = _rotateRight($node); _colorFlip($node); } return $node; } sub _rotateLeft { my ($node) = @_; my $temp = $node->[RIGHT]; $node->[RIGHT] = $temp->[LEFT]; $temp->[LEFT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; return $temp; } sub _rotateRight { my ($node) = @_; my $temp = $node->[LEFT]; $node->[LEFT] = $temp->[RIGHT]; $temp->[RIGHT] = $node; $temp->[COLOR] = $node->[COLOR]; $node->[COLOR] = RED; return $temp; } sub _isRed { my ($node) = @_; return FALSE if ! $node; return $node->[COLOR] == RED; } sub _colorFlip { my ($node) = @_; $node->[COLOR] = ! $node->[COLOR] || BLACK; $node->[LEFT][COLOR] = ! $node->[LEFT][COLOR] || BLACK; $node->[RIGHT][COLOR] = ! $node->[RIGHT][COLOR] || BLACK; } sub _fixUp { my ($node) = @_; $node = _rotateLeft($node) if _isRed($node->[RIGHT]); $node = _rotateRight($node) if _isRed($node->[LEFT]) && _isRed($no +de->[LEFT][LEFT]); _colorFlip($node) if _isRed($node->[LEFT]) && _isRed($no +de->[RIGHT]); return $node; } 'This statement is false.'; __END__ OPTIMIZATIONS 1. Inline some subs 2. Turn recursion into a stack 3. Allow predefined comparison subs and then *foo = in order to not pa +y penalty - ascii, numerical, coderef sub {$_[0] cmp $_[1]} 4. Add get_min_kv and get_max_kv (see _deleteKey) 5. Turn the things that make sense from recursion to iteration (but fr +ustratingly, not insert) 6. Consider XS 7. As a configurable option, allow not storing values to reduce memory FEATURES 1. Add val_defined 2. Iterator for going over the tree GENERAL 1. Consistency in sub names REFERENCE 1. http://www.cs.princeton.edu/~rs/talks/LLRB/08Dagstuhl/RedBlack.pdf 2. http://www.cs.princeton.edu/~rs/talks/LLRB/RedBlack.pdf 3. http://www.cs.princeton.edu/~rs/talks/LLRB/08Penn.pdf

How to fix tables pointing to race

UPDATE table t SET race_id = ( SELECT pkey_id FROM race r, (SELECT * from race where pkey_id = t.race_id) x WHERE r.track_id = 41 AND r.raceday = x.race_day AND r.race = x.race ) WHERE race_id in (select pkey_id from race where track_id = 37)
This seems logically sound to me (which is freaking scare) - but will it work.

How to fix race table

table event pkey_id = serial event_id = integer event_date = date(YYYY-MM-DD) event_num = integer UPDATE event e SET event_id = 41 WHERE event_id = 37 AND NOT EXISTS ( SELECT 1 FROM event WHERE event_id = 41 AND event_date = e.event_date AND event_num = e.event_num )

For biohisham
I don't have a computer science degree (actually, I almost flunked out of high school and never went to college). While I like to think of myself as having above average intelligence, I am not one of those scary smart types that doesn't need to go to college because they already read all those books in high school. I say this to put things in perspective - I think most folks that regularly frequent this site have the quality necessary to expand their own abilities on their own. I have an incredibly inquisitive nature and am willing to spend lots of my own time learning about things that don't have an immediate practical value. It comes in handy in the long run. If you are interested in a reading list, might I recommend Recommended Reading and some of the links from here.

One approach to learning to think about a problem from different angles is to follow the advice I gave at Necessity is the mother of invention. It probably sounds like a load of bull, but the easiest way to solve a really tough problem in a new way is to break it down into smaller pieces stating your assumptions along the way and then challenging those assumptions. For instance, if you have ever read How many words does it take? - I took an NP Complete problem and turned it into O(1). Now, that was only possible because I didn't work under the same constraints (assumptions) as the original problem. In the original problem you have an arbitrarily large alphabet and dictionary but I chose English (26 letters) and a specific dictionary (around 61K words). I then started challenging my own assumptions (that every word need be considered for instance).

I guess what I am saying is knowing lots of algorithms and data structures and being able to determine the order of complexity of your own algorithm by itself is not enough. I don't know nearly what I should if I had a CS degree. All of those things are a great help but if you don't even attempt to solve a problem because you already know it will be hard - how would anything get done? Sometimes the key to the toppling over the entire impossible tower is by changing or challenging 1 key assumption.

I hope this helps.

For bart
Step 1 is to enable whatever secure session capability the database supports (SSL) so your credentials are not going over the wire in the clear.
Step 2 is to use a symetric encryption routine that is compiled into native bytecode (a la C or whatnot). The routine can be used to generate the encrypted password when you want to change the password (stored in a file) but its primary role is to decrypt the password in memory when appropriate
Step 3 is to modify DBI such that instead of passing in a user/pass for authentication, you tell it to use the routine above with the encrypted password. It is designed such that it writes directly to the SSL socket. Getting it to give back the password to the user would require modifying and recompiling DBI and potentially the compiled routine as well.
It is still sketchy in a few areas. For instance, it is in the clear in memory so you need to come up with a good routine for scrubbing that. A user who has permission to execute the compiled routine, can read the file with the stored encrypted passwords, and can execute perl can get access to the DB (even though they don't know what the password is), etc. I think it may be worth it in some cases though.

For blokhead and tye

print solve( holes => 33, empty => 17, towin => 17, valid => [ [1, 2, 3], [1, 4, 9], [2, 5, 10], [3, 6, 11], [4, 5, 6], [4, 9, 16], [5, 10, 17], [6, 11, 18], [7, 8, 9], [7, 14, 21], [8, 9, 10], [8, 15, 22], [9, 10, 11], [9, 16, 23], [10, 11, 12], [10, 17, 24], [11, 12, 13], [11, 18, 25], [12, 19, 26], [13, 20, 27], [14, 15, 16], [15, 16, 17], [16, 17, 18], [16, 23, 28], [17, 18, 19], [17, 24, 29], [18, 19, 20], [18, 25, 30], [21, 22, 23], [22, 23, 24], [23, 24, 25], [23, 28, 21], [24, 25, 26], [24, 29, 32], [25, 26, 27], [25, 30, 33], [28, 29, 30], [31, 32, 33], ], );

For blokhead
I have been doing some analysis of base-n counting as it relates to identifying combinations. Specifically, I am counting in base-n up to 0..base - 1 which is the largest combination set for size of base-n. Next, I mark all the values that meet the combination criteria (all positions must increase from left to right) and measure the distance in between.

Believe it or not, predictable patterns do emerge but they are quite interesting - at least initially. See for yourself:

#!/usr/bin/perl use strict; use warnings; for my $base (3 .. 9) { print "\tBASE $base\n"; my $next = count_base($base); my $n = 0; while (my @dig = $next->()) { my $num = join '', @dig; if (restricted(@dig)) { print "$n\n" if $n; $n = 0; #print "\t$num\n"; } else { ++$n; #print "$num\n"; } } print "\n\n"; } sub restricted { my @dig = @_; my $i = 0; while (! $dig[$i]) { shift @dig; } for (1 .. $#dig) { return 0 if $dig[$_] <= $dig[$_ - 1]; } return 1; } sub count_base { my $base = shift @_; my @dig = (0) x $base; my @end = 0 .. $base - 1; return sub { return () if "@dig" eq "@end"; my $pos = @dig; while ($pos--) { if (++$dig[$pos] < $base) { @dig[$pos + 1 .. $#dig] = (0) x ($#dig - $pos); return @dig; } } }; }
Basically, the sequences come in a handful of forms:
  • X .. N - 1 (where X = some number less than N)
  • XN + X (where X = some number less than N)
  • N^P - 1 for P = 1 .. X (where X = some number less than N)
  • N^P - 1 * X / N (where P & X = some number less than N)
X and P are also predictable but vary.

WTF Over?
I got a new machine at work and have been cleaning up 2 1/2 years of stuff to keep it shiny. In a directory called "Chomp" I found a file called "blah.pl", the contents of which are:

#! /usr/bin/perl use strict; use warnings; use Quantum::Superpositions; my @array_1 = (1 .. 4); my @array_2 = qw{1 2 2 3 3 3 4 4 4 4 7 6 5}; my @array_3 = eigenstates( any(@array_2) != all(@array_1) ); my @array_4 = Quantum::Superpositions::eigenstates( any(@array_2) != a +ll(@array_1) ); print "Ordered:\n"; print "$_\n" for @array_3; print "Hash:\n"; print "$_\n" for @array_4; { no warnings 'redefine'; *eigenstates = *main::eigenstates; sub eigenstates ($) { my @uniq; my %seen; for ( Quantum::Superpositions::collapse( $_[0] ) ) { push @uniq , $_ if ! $seen{$_}; $seen{$_}++; } return @uniq; } }
It took me a second to realize that I had overridden eigenstates to guarantee ordering. WTF was I thinking when I picked the dir/file name?

For injunjoel
If I were going to do it without the use of modules, this is how I would have done it.

package Some::Object; use strict; use warnings; use Carp; our $VERSION = '0.01'; sub new { my $class = shift; my $self = bless {}, $class; croak "Incorrect number of parameters" if @_ % 2; $self->_init(@_); return $self; } sub _init { my $self = shift; my %default = ( foo => 'bar', blah => 'asdf', ); my %user = @_; for ( keys %user ) { delete $user{$_} if ! exists $default{$_}; } for ( keys %default ) { $user{$_} = $default{$_} if ! exists $user{$_}; } $self->{OPT} = \%user; }

For spartan
The thing that took me so long was remembering to add the signal handlers so that when you hit ctrl-c or what not, the children died too

#!/usr/bin/perl use strict; use warnings; use Parallel::ForkManager; use constant MAX_PROCS => 1; use constant MAX_TIME => 10; my ($pid, $ident, $start); my $pm = new Parallel::ForkManager( MAX_PROCS ); @SIG{ qw(ABRT STOP TERM INT) } = (sub { kill 9, $pid; exit }) x 4; $pm->run_on_start ( sub { ($pid, $ident)= @_; $start = time; print "$ident started at ", scalar localtime($start), " with p +id: $pid\n"; } ); $pm->run_on_wait ( sub { if ( time - $start > MAX_TIME ) { print "Killing $pid - taking too long to run\n"; kill 9, $pid; } }, 1 ); $pm->run_on_finish ( sub { ($pid, my $exit_code, $ident) = @_; print "$ident ($pid) just completed with : $exit_code\n"; } ); while ( 1 ) { $pid = $pm->start( 'health check' ) and next; # We are in child process for ( 1 .. rand 15 ) { print "I am the child doing work\n"; sleep 1; } $pm->finish; # We are in parent process }

Users, as of 2004-10-15, that have a homenode length of 500 and either have greater than 200 XP or have been a member for more than a year and logged in within 45 days.

 

 

Previously Recent:
2005-01-01 : My primary and official New Year's resolution is to try and be a better husband. My secondary and unofficial resolution is to try and find an acceptable weight and stop fluctuating.
2004-09-20 : Have decided to take a programming sabbatical. Still here, just not coding much. As it turned out this didn't turn out to be much of a sabbatical. A few weeks off was all it took to get inspired again
2004-06-12 : I got married to Jean in Maine.
2004-06-01 : Decided to start keeping track of my latest news
2003-10-06 : I am working for TSA, but don't hold the fact that I work for the Government against me!
2003-09-11 : Uploaded Tie::Hash::Sorted to CPAN
2003-05-30 : Became the 198th Saint

This is the end

Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (8)
As of 2014-09-18 08:27 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (109 votes), past polls