Beefy Boxes and Bandwidth Generously Provided by pair Networks
Perl Monk, Perl Meditation
 
PerlMonks  

diotalevi's scratchpad

by diotalevi (Canon)
on Jun 01, 2004 at 19:39 UTC ( [id://358464]=scratchpad: print w/replies, xml ) Need Help??


for R4jr

use strict; use warnings; my %codons; my %aas; my $previous_file = ''; while (<>) { if ( $previous_file ne $ARGV ) { open OUTPUT, '>', "$ARGV.aa" or die "Can't open $ARGV.aa for writing: $!"; $previous_file = $ARGV; } tr/t/u/; if ( exists $codons{$_} ) { my $codon = $codons{$_}; if ( exists $aas{$codon} ) { print OUTPUT $aas{$codon}; print $aas{$codon}; } } }

#!/opt/perl-5.10.0/bin/perl + + use strict; use warnings; use feature ':5.10'; use Text::Table; for ( my $width = 15; $width == 15; ++$width ) { my $table = Text::Table->new; my $nth = 0; my $total = ( $width**2 - $width ) / 2; for my $III ( 1 .. $width ) { my @row = ('.') x $III; for my $JJJ ( $III + 1 .. $width ) { my $aha = $width + .5 - sqrt( 2 * ( $total - $nth ) ); my $row = int $aha; my $col = $row + 1 + int( ( $aha - $row ) * ( $width - $ro +w ) ); push @row, "${row}x$col"; ++$nth; } $table->load( \@row ); } say "${width}x$width\n$table"; }

Produces

. 1x2 1x3 1x4 1x5 1x6 1x7 1x8 1x9 1x10 1x11 1x12 1x13 1x14 1x15 . . 2x3 2x4 2x5 2x6 2x7 2x8 2x9 2x10 2x11 2x12 2x13 2x14 2x15 . . . 3x4 3x5 3x6 3x7 3x8 3x9 3x10 3x11 3x12 3x13 3x14 3x15 . . . . 4x5 4x6 4x7 4x8 4x9 4x10 4x11 4x12 4x13 4x14 4x15 . . . . . 5x6 5x7 5x8 5x9 5x10 5x11 5x12 5x13 5x14 5x15 . . . . . . 6x7 6x8 6x9 6x10 6x11 6x12 6x13 6x14 6x15 . . . . . . . 7x8 7x9 7x10 7x11 7x12 7x13 7x14 7x15 . . . . . . . . 8x9 8x10 8x11 8x12 8x13 8x14 8x15 . . . . . . . . . 9x10 9x11 9x12 9x13 9x14 9x15 . . . . . . . . . . 10x11 10x12 10x13 10x14 10x15 . . . . . . . . . . . 11x12 11x13 11x14 11x15 . . . . . . . . . . . . 12x13 12x14 12x15 . . . . . . . . . . . . . 13x14 13x15 . . . . . . . . . . . . . . 14x15 . . . . . . . . . . . . . . .

Safe exception trapping

sub EVAL { my ( $try, $catch ) = @_; my( $ok, $e ); $ok = eval { $try->(); 1 }; $e = $@; return 1 if $ok and not( defined( blessed( $e ) ) and $e ); return unless $catch; $catch->( $e ); }

Prolog is funny.

Welcome to SWI-Prolog (Multi-threaded, Version 5.6.14) Copyright (c) 1990-2006 University of Amsterdam. SWI-Prolog comes with ABSOLUTELY NO WARRANTY. This is free software, and you are welcome to redistribute it under certain conditions. Please visit http://www.swi-prolog.org for details. For help, use ?- help(Topic). or ?- apropos(Word). ?- The_Question. % ... 1,000,000 ............ 10,000,000 years later % % >> 42 << (last release gives the question)

The pragma pragma

package pragma; use strict; use warnings; sub import { my $pragma = shift @_; $pragma = shift @_ if $pragma eq __PACKAGE__; my $value = shift @_; $^H{$pragma} = $value; return; } sub unimport { my $pragma = shift @_; $pragma = shift @_ if $pragma eq __PACKAGE__; delete $^H{$pragma} if exists $^H{$pragma}; return; } sub in_effect { my $pragma = shift @_; $pragma = shift @_ if $pragma eq __PACKAGE__; return $^H{$pragma}; } 1;

use strict; use warnings; use constant CHROMOSOMES => 30; use constant TARGET => scalar <>; use constant TARGET_BITS => 8 * length TARGET; use constant P_MUTATION => 0.5; use constant OK_ENOUGH => 1; # Too much is just enough sub say { my $say = join '', @_; $say =~ s/([^[:print:]])/sprintf '\x%02x', ord $1/ge; print "$say\n"; } # Birth. my @population = map { random_chromosome() } 1 .. CHROMOSOMES; my $result; while ( not defined $result ) { # Test the fitness of every chromosome. my @fitness; CHROMOSOME: for my $chromosome ( @population ) { my $fitness = fitness( $chromosome ); if ( $fitness >= OK_ENOUGH ) { $result = $chromosome; last CHROMOSOME; } push @fitness, $fitness; } my @order = sort { $fitness[$b] <=> $fitness[$a] } 0 .. $#fitness; say "$fitness[$order[0]]: $population[$order[0]]"; # Trial by foxes. splice @order, @order / 3; @population = @population[ @order ]; # Sex. my @children = map { sex( @population ) } 1 .. CHROMOSOMES - @population; push @population, @children; } say $result; sub sex { my @parents = @_; my $child = ''; for ( 0 .. TARGET_BITS - 1 ) { vec( $child, $_, 1 ) = vec( $parents[ rand @parents ], $_, 1 + ); } if ( P_MUTATION < rand ) { my $bit = int rand TARGET_BITS; vec( $child, $bit, 1 ) = not vec( $child, $bit, 1 ); } return $child; } sub fitness { my $chromosome = shift @_; my $matches = 0; for ( 0 .. TARGET_BITS - 1 ) { $matches++ if vec( TARGET, $_, 1 ) == vec( $chromosome, $_, 1 +); } my $fitness = $matches / TARGET_BITS; return $fitness; } sub random_chromosome { my $chromosome = ''; for ( 0 .. TARGET_BITS - 1 ) { vec( $chromosome, $_, 1 ) = rand 2; } return $chromosome; }

Emacs buffers+quining perl

What you'd load from a PERL5LIB="-MQuine::This".

INIT { # Print the code before __DATA__ and pretend nothing happened... if ( defined fileno *main::DATA ) { # Fetch code or abort... eval { my $pos = tell *main::DATA; seek *main::DATA, 0, 0 or return; my $code; read *main::DATA, $code, $pos or return; print $code or return; }; } }

What you'd have in your buffer.

while(<DATA>) { print lc; } __DATA__ server database ADD_DT ENT_ID PMT_ID PMT_AM KERMIT MISS_PIGGY Dec 22 2004 9:30AM 1304 21190 -30.81 KERMIT MISS_PIGGY Dec 22 2004 9:30AM 1314 21189 -358.4 +6 KERMIT MISS_PIGGY Jan 12 2005 3:07PM 1096 21585 -495.7 +2 KERMIT MISS_PIGGY Jan 12 2005 3:07PM 1096 21933 495.72 KERMIT MISS_PIGGY Jan 12 2005 3:07PM 1098 21586 -16.65 KERMIT MISS_PIGGY Mar 3 2005 6:34AM 985 22546 -496.36 KERMIT MISS_PIGGY Mar 3 2005 6:34AM 1003 22547 -841.1 +7 KERMIT MISS_PIGGY Mar 9 2005 9:56AM 1005 22745 -110.5 +3

Emacs code to run a buffer full of perl on another buffer.

(defun perl-other-buffer (script) (interactive "bProgram:") (let ((script-file (make-temp-file "perl-other-buffer"))) (save-excursion (set-buffer (get-buffer script)) (write-region (point-min) (point-max) script-file)) (let ((ok (zerop (shell-command-on-region (point-min) (point-max) (concat "perl -x " (shell-quote-argument script-file)))))) (delete-file script-file) ok)))

At work and elsewhere, I'm often called on to work on crapulous code. Stuff where it's difficult to see the extent of variables and whether two pieces of code have the same things tucked into them or not. I wrote an Emacs extension which marks up my source. The idea is that if $foo is used one line 10 and line 100, I'd like to be able to see that. Here's a first draft or prototype if you will. It's bare bones. Please, suggest things to me to help me make this more useful.

Sample perl source from Random Darwin Award in plain text.

use strict; use WWW::Mechanize; >> my $agent = WWW::Mechanize->new( autocheck => 1 ); > > $agent->get('http://cgi.darwinawards.com/cgi/random.pl'); > >> my $content = $agent->content( format => "text" ); | >my $cr = chr 169; > |$content =~ s/.*\d\d\s+Urban Legend//s; > |$content =~ s/.*\d\d\s+Personal Account//s; > |$content =~ s/.*Reader Submission\s+Pending Acceptance//s; > >$content =~ s/\s*DarwinAwards\.com\s*$cr.*//s; > $content =~ s/.*?\([^\)]*?\d{2}[^\)]*\) //s; > $content =~ s/.*Darwin\s?Award\s?Nominee//si; > $content =~ s/.*Confirmed \S+\s?by Darwin//si; > $content =~ s/.*Honorable Mentions//s; > $content =~ s/submitted by.*//si; > $content =~ s/109876543210.*//s; > $content =~ s/^\s+//; | > print $content;

xref.el: the real code.

(defun b-xref () (interactive) (fundamental-mode) (save-excursion (save-restriction (widen) (mapcar 'b-xref-do-jots (b-xref-buffer (current-buffer))))) nil) (defvar b-xref-bin "perl") (defvar b-xref-jot ">") (defvar b-xref-fill "|") (defvar b-xref-fill-space " ") (require 'cl) (defsubst min-list (list) (reduce 'min list)) (defsubst max-list (list) (reduce 'max list)) (defsubst line->point (line) (goto-line line) (point)) (defun b-xref-do-jots (pair) "Make space for jots and call `b-xref-jot-line' to place them." (string-rectangle (point-min) (progn (goto-char (point-max)) (beginning-of-line) (point)) b-xref-fill-space) (let ((lines (cdr pair))) (let ((min-line (min-list lines)) (max-line (max-list lines))) (delete-rectangle (line->point min-line) (+ 1 (line->point max-line))) (string-rectangle (line->point min-line) (line->point max-line) b-xref-fill) (mapcar 'b-xref-jot-line lines)))) (defun b-xref-jot-line (line) "Jot a note on LINE." (goto-char (line->point line)) (delete-char 1) (insert b-xref-jot)) (defun b-xref-buffer (buffer) "Runs a buffer through 'perl -MO=Xref,-raw' and returns the parsed d +ata." (save-excursion (save-restriction (set-buffer buffer) (widen) (goto-char (point-min)) (let ((perl (if (looking-at auto-mode-interpreter-regexp) (match-string 2) (or b-xref-bin "perl"))) (infile (if (buffer-modified-p) (error "TODO: Copy modified buffer to temp file.") (buffer-file-name))) (buffer (generate-new-buffer "*b-xref-raw*"))) (let ((rc (call-process perl infile buffer nil "-MO=Xref,-raw"))) (or (zerop rc) (error "%s exited with %d" perl rc))) (let ((xref-output (b-xref-read-raw buffer "-"))) (kill-buffer buffer) xref-output))))) (defun b-xref-list-> (a b) "Sorts a list so larger numbers go first, then shorter lists." (if (and (numberp (car a)) (numberp (car b))) (or (> (car a) (car b)) (and (= (car a) (car b)) (b-xref-list-> (cdr a) (cdr b)))) (and (null a) (not (null b))))) (defun b-xref-alist-> (a b) "Sorts the elements of an alist with `b-xref-list->'" (b-xref-list-> (cdr a) (cdr b))) (defun trim (str) (rtrim (ltrim str))) (defun ltrim (str) (replace-regexp-in-string "^ +" "" str)) (defun rtrim (str) (replace-regexp-in-string " +$" "" str)) (defun b-xref-read-raw (buffer filename) "Reads the output from 'perl -MO=Xref,-raw'." (save-excursion (save-restriction (set-buffer buffer) (widen) (goto-char (point-min)) (let ((xref-regexp (concat "^" (regexp-quote filename) (let ((pad (- 16 (length filename)))) (if (> pad 0) (make-string pad ? ) "")) " ............[^ \n]*" " \\(.....[^ \n]*\\)" " \\(............[^ \n]*\\)" " ....[^ \n]*" " \\(................[^ \n]*\\)" " \\([^\n]+\\)\n")) (xref-output ())) (while (re-search-forward xref-regexp nil t) (or (bolp) (forward-line)) (let ((line (string-to-number (trim (match-string 1)))) (pack (trim (match-string 2))) (name (trim (match-string 3)))) (if (zerop line) nil (let ((key (list pack name))) (let ((pair (assoc key xref-output))) (if pair (let ((lines (cdr pair))) (or (member line lines) (nconc lines (list line)))) (push (cons key (list line)) xref-output))))))) (sort xref-output 'b-xref-alist->)))))

Matching a number exported from an Excel spreadsheet

use Regexp::Common 'number'; my $NUMBER = "(?x: \\( \\$? (?: $RE{num}{real} | $RE{num}{int} | $RE{num}{real}{-sep => ','}{-group => 3} | $RE{num}{int} {-sep => ','}{-group => 3} ) \\) | \\$? -? (?: $RE{num}{real} | $RE{num}{int} | $RE{num}{real}{-sep => ','}{-group => 3} | $RE{num}{int} {-sep => ','}{-group => 3} ) )";

Unrolling loops allows me to cause each method call to appear to originate from some other source code.

### Installing the multi-method hook. *$method_name = sub { my ($self) = shift; if (wantarray) { return map $self->$_(@_), @$methods_to_call; } elsif ( defined wantarray ) { return join( ' ', map $_->$_(@_), @$methods_to_call ); } else { $self->$_(@_) for @$methods_to_call; return; } }; ### Installing the multi-method hook. eval 'sub $method_name { my ($self) = shift; my @results; if (wantarray) { ' . join( '', map "#line $_->{line} \"$_->{filename}\" push \@results, \$self->\$methods_to_call[$_->{index}]( \@_ ); " ) . '#line ' . __LINE__ . ' "' . __FILE__ . '" return @results; } elsif ( defined wantarray ) { ' . join( '', map "#line $_->{line} \"$_->{filename}\" push \@results, \$self->\$methods_to_call[$_->{index}]( \@_ ); " ) . '#line ' . __LINE__ . ' "' . __FILE__ .'" return join( " ", @results ); } else { ' . join( '', map "#line $_->{line} \"$_->{filename}\" \$self->\$methods_to_call[$_->{index}]( \@_ ); " ) . '#line ' . __LINE__ . ' "' . __FILE__ .'" return join( " ", @results ); } }';

Demoing Data::Postponed

sub ideal # Everything must be declared before use or at definition while INPUT $accumulator .= $obj->do_something( $_ ) return $result sub reality # Allow the use of things prior to declaring or defining them: one + pass # looks for all declarations and the next pass proceeds as normal. @input = INPUT $obj->examine( @input ) while @input $accumulator .= $obj->do_something( $_ ) return $result sub surreality # Just like reality() except that post-facto declarations might ch +ange # how previous results in $accumulator occurred. while INPUT $accumulator .= $obj->do_something( $_ ) return $result

Streaming ticker client for demerphq

use IO::Socket; my $ticker = IO::Socket::INET->new( PeerAddr => 'web6...', PeerPort => 8081 ); while ( my $msg = read_record( $ticker ) ) { print "$msg->{msgtext}\n"; } sub read_record { # Reads a single record from the streaming ticker my $sock = shift; local $/ = ""; my %record = map( /^([^=]+)=?([^\r\n]*)/ ? ( $1, $2 ) : (), readline( $sock ) =~ /([^\r\n]+)/g ); for ( values %record ) { s/\\\\/\\/g; s/\\\r/\r/g; s/\\\n/\n/g; } }

Things I've learned from British folk ballads

----------------------------------------------------------------------

Don't ignore warnings. If someone tells you to beware of Long Lankin,
bloody well beware of him. If someone tells you not to go by
Carterhaugh, stay away. Same goes for your mother asking you not to go
out hunting on a particular day. Portents about weather, particularly
when delivered by an old sailor who is not currently chatting up a
country maid, are always worth heeding.

If someone says that he's planning to kill you, believe him.

If someone says he's going to die, believe him.

Avoid navigable waterways. Don't let yourself be talked into going
down by the wild rippling water, the wan water, the salt sea shore,
the strand, the lowlands low, the Burning Thames, and any area where
the grass grows green on the banks of some pool. Cliffs overlooking
navigable waterways aren't safe either.

Broom, as in the plant, should be given a wide berth.

Stay away from the greenwood side, too.

Avoid situations where the obvious rhyme-word is "maidenhead."

If you look at the calendar and discover it's May, stay home.

The flowing bowl is best quaffed at home. Don't drink with strangers.
Don't drink alone. Don't toss the cups or pass the jar about in bars
where you haven't arranged to keep a tab. Drinks of unusual or
uncertain provenance should be viewed askance, especially if you're
offered them by charming members of the opposite sex. Finally, never
get drunk and pass out in a bar called the "Cape Horn."

Members of press gangs seldom tell the truth. Recruiting sergeants
will fib to you shamelessly. They are not your friends, even if
they're buying the drinks. Especially when they're buying the drinks.

If you're drinking toasts, mention your One True Love early and often.

If you're a young lady, dressing yourself in men's array and joining
the army or the navy has all sorts of comic possibilities, but you
yourself aren 't going to find it too darned humorous at the time.

If you are an unmarried lady and have sex, you will get pregnant. No
good will come of it.

If you are physically unable to get pregnant due to being male, the
girl you had sex with will get pregnant. No good will come of
it. You'll either kill her, or she'll kill herself, or her
husband/brother/father/uncle/cousin will kill you both. In any case
her Doleful Ghost will make sure everyone finds out. You will either
get hanged, kill yourself, or be carried off bodily by Satan. Your
last words will begin "Come all ye."

Going to sea to avoid marrying your sweetie is an option, but if she
hangs herself after your departure (and it's even money that she's
going to) her Doleful Ghost will arrive on board your ship and the
last three stanzas of your life will purely suck.

If you are a young gentleman who had sex it is possible the girl won't
get pregnant. In those rare instances you will either get Saint
Cynthia's Fire or the Great Pox instead. No good will have come of it.

New York Girls, like Liverpool Judies, like the ladies of Limehouse,
Yarmouth, Portsmouth, Gosport, and/or Baltimore, know how to show
sailors a good time, if by "good time" you mean losing all your money,
your clothes, and your dignity. Note: All of these places are near
navigable waterways.  In practical terms this means that if you're a
sailor you're screwed (and so are any young ladies you happen to
meet). See also: Great Pox; Doleful Ghost.

If you are a young lady do not allow young men into your garden. Or
let them steal your thyme. Or agree to handle their ramrods while
they're hunting the bonny brown hare. Cuckoo's nests are right
out. And never stand sae the back o' yer dress is up agin the wa' (for
if ye do ye may safely say yer thing-a-ma-jig's awa').

Never let a stranger teach you a new game. No good will come of it.

Sharing a boyfriend with your sister is a bad plan.

Having more than one True Love at a time is a non-starter.

If you're a brunette, give up.

Not that being a blonde will improve the odds much.

If your name is Janet, change it.

If you are a young lady and an amorous soldier, sailor, ploughboy,
blacksmith, cavalry officer, or other young man fails to stop the
first time you tell him he's being too bold, knock off the maidenly
protests and take more direct measures. If saying "no" the first time
didn't stop him, you've no reason to believe that twice will work any
better.

Professions to be particularly wary of: clerks, salty sailors, serving
maids, blacksmiths, highwaymen, gamblers, rank robbers, stonemasons,
soldiers, tinkers, and millers. Anyone described as "jolly," "bold,"
or "saucy." Supernatural creatures are best avoided. If they can't be
avoided, they should be addressed respectfully. If a supernatural
creature sets you a task you're well and truly screwed.

If you are a young lady and a soldier promises to "marry you in the
morn," it means he's already married. And has kids. And he's not going
to marry you anyway. Even if you're pregnant. Which you will be.

If you're a young unmarried lady with child, and your pregnancy
embarrasses or inconveniences someone else, consider yourself a
sitting duck. Don't meet with your young gentleman alone, or at odd
hours, or in isolated locations, even if he says he's taking you to be
married. Next thing you know your Doleful Ghost will be telling your
mother all about it. While he may say "Come all ye.." in the last
stanza or two this will be small comfort.

Young ladies who feel uneasy should always act on their feelings. If
in your good opinion you fear some young man (however handsome, rich,
and well-spoken) is some rake, depend upon it: He's a rake. Rakes will
protest that you have them all wrong. They'll be fibbing. Never go
anywhere with a rake, particularly to isolated spots. See above:
Doleful Ghost.

If you are a young lady and someone arrives to tell you that your
boyfriend was slain on a foreign battlefield, take it with a grain of
salt.  Especially if you're carrying a broken token.

If a former significant other turns up unexpectedly after a long
absence, don't throw yourself into his/her arms right away.

That goes double if they refuse to eat anything.

Triple if they turn up at night and want you to leave with them
immediately.

Have nothing to do with former boyfriends who turn up and say it's no
big deal that you're now married to someone else and have a child. If
their intentions are legit, that's got to be a problem. If it's not a
problem, their intentions are not legit.

You are justified in cherishing the direst suspicions of a suddenly
and unexpectedly returned significant other who mentions a long
journey, a far shore, or a narrow bed, or who's oddly skittish about
the imminent arrival of cockcrow.

If you are a young lady and you meet a young man who says his name is
"Ramble Away," don't be surprised if, by the time you know you're
pregnant, it turns out he's moved and left no forwarding address.

A fellow who's a massively accomplished flirt hasn't been spending his
time sitting around waiting for his One True Love to come
along. Furthermore, odds are poor that you'll turn out to be his One

True Love who will reform him.

If you arrange an assignation with your new sweetie, a little foot
page will be listening in and will carry the news to exactly the last
person you'd want to hear the story.

If your girlfriend insists that you go back to sleep after some odd
sound woke you, it's time to dive out the window and run for the hills

right then.

If you're hiding in the hills, don't inform anyone exactly where
you're sleeping, particularly not an attractive member of the opposite
sex.

If your girlfriend serves eels in eel broo, make sure you see her eat
some first.

Informing your current significant other that you're about to be wed
to someone else is . risky. Even if you're doing it as a joke, or to
test their love. Especially if you're doing it as a joke or to test
their love.  Testing someone's love in general isn't too bright.

Not even sending a talking goshawk to tell your significant other that
the engagement is off will help you. You're going to find yourself at
the bottom of a well full fifty fathoms deep. A Doleful Ghost may get
involved.

If, after you inform your current significant other that you're to be
wed to someone else, he or she suggests that the two of you meet in
some lonely spot for one last fling, do not go.

Inviting your old flame to your wedding is a bad idea.

If your old flame invites you to his/her wedding, leave town.

If your old flame shows up uninvited at your wedding, start eyeing the
exits. There's a chance he/she is a Doleful Ghost. Be that as it may,
no good will come of it.

If you're out hunting, make sure of your sight picture before you pull
the trigger/loose your bow. Especially so if you're near a navigable
waterway or the greenwoodside.

Do not allow the words "I wish" to pass your lips.

Avoid oaths, particularly when you're near navigable waterways or the
greenwoodside.

If the jailer indicates his willingness to take your gay gold ring to
carry a message to your sweetheart, see if he'll take that same gay
gold ring to leave the door open and look the other way for five
minutes while you or the sweetheart (as appropriate) escape.

Always use the buddy system. "Bare is brotherless back," as Grettir
the Strong put it; and if Grettir was worried about going places
alone, you'd better worry too. So bring a friend with you. Friends
keep bad things from happening. If things go badly anyway, you'll need
their help. And if things go well (hey, it could happen), it'll be
nice to have a friend along to share the laughs.

Moving to America for a minute:

Do not, for any reason, mess with a man's Stetson hat or a man who is
wearing a Stetson.

Pop quiz!

You are a beautiful young lady named Janet. On the first of May you
meet a man in a patch of broom down by the greenwoodside. He invites
you to his home on the far side of the sea, and earnestly entreats you
to keep his invitation secret from your parents. The ship is leaving
right away, this very night!

What should you do?

A) Woo hoo, sounds like fun! You'll go, have a great time, and return
home happy, healthy, and with some great gossip for your chums.

B) You blow loudly on a police whistle and run home as if
jet-propelled.  You tell mom and dad what just went down, put on a
Stetson, and load your forty-four caliber revolver with silver
bullets.

C) You decide that it would save everyone concerned a great deal of
trouble if you skipped ahead a bit and hanged yourself right now. Your
Doleful Ghost informs mom of the situation.

D) Rather than go with him you disguise yourself as a man and join the
Army.  Next time you're marching through the Lowlands Low you seduce a
beautiful young lady. She is so amazed to discover that she isn't
pregnant that she hangs herself. Her Doleful Ghost gets confused and
drives the young man you met down by the greenwoodside mad. He
delivers a long speech that begins "Come all ye wild and roving lads a
warning take by me.."

http://www.mckinley.uiuc.edu/Handouts/anklesprain/anklesprain.html

Callstack from a use()

CX=0 package=BAR filename=aaa.pl line=2 subroutine=(eval) hasargs=0 wantarray=0 evaltext=bbb.pm is_require=1 hints=0 bitmask=\000\000\000\000\000\000\000\000\000\000\000\000 CX=1 package=main filename=bbb.pm line=0 subroutine=BAR::BEGIN hasargs=1 wantarray=0 evaltext=undef is_require=undef hints=0 bitmask=\000\000\000\000\000\000\000\000\000\000\000\000 ARGS= CX=2 package=main filename=bbb.pm line=0 subroutine=(eval) hasargs=0 wantarray=0 evaltext=undef is_require=undef hints=0 bitmask=\000\000\000\000\000\000\000\000\000\000\000\000

aaa.pl

package BAR; use bbb;

bbb.pm

package bbb; use strict; use warnings; use Data::Dumper; $Data::Dumper::Indent = 0; my @params = qw( package filename line subroutine hasargs wantarray evaltext is_require hints bitmask ); for ( my $cx = 0; caller $cx; ++ $cx ) { my %caller; @caller{@params} = map +( defined() ? $_ : 'undef' ), do { package DB; # see perldebguts for this magic. caller $cx }; print( "CX=$cx\n", join( '', map " $_=$caller{$_}\n", @params ), $caller{hasargs} ? " ARGS=" . Dumper( @DB::args ) . "\n" : + () ); } 1;

package Text::Table::Squish; use strict; use warnings; use Exporter; use vars qw( @EXPORT_OK %EXPORT_TAGS ); use subs qw( transpose squishtable ); BEGIN { *import = \&Exporter::import; @EXPORT_OK = qw( squishtable squishtable_emacs squishtable_sql squ +ishtable_spaces squishtable_dwim ); %EXPORT_TAGS = ( all => \ @EXPORT_OK ); } use Algorithm::Loops qw( MapCarU Filter ); sub squishtable_dwim { # Attempts to squish on anything potentially reasonable. # 1 |22 |333 |4444 # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... squishtable $_[0], "^([^\\w\r\n])\\1+[\r\n]+", "^ +[\r\n]+"; } sub squishtable_emacs { # Squishes emacs tables. # +---+---+---+ # | | | | # +---+---+---+ # | | | | # +---+---+---+ squishtable $_[0], "^\\+(?:\\|\\+)+[\r\n]+", "^-(?: -)+[\r\n]+"; } sub squishtable_sql { # 1 |22 |333 |4444 # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... # . |.. |... |.... squishtable $_[0], "^\\|+[\r\n]+", "^ +[\r\n]+"; } sub squishtable_spaces { # Squishes to space delimited columns. Stuff that was printed in f +ixed width columns is also handled here. # 1 22 333 4444 # . .. ... .... # . .. ... .... # . .. ... .... # . .. ... .... # . .. ... .... # . .. ... .... squishtable $_[0], "^ +[\r\n]+", "^ +[\r\n]+", } my %CompiledPatterns; sub squishtable { # Removes extra trailing space at the end of columns in a # table. my ( $table, $column_separator, $empty_column ) = @_; if ( not( defined $column_separator and defined $empty_column ) ) { # If I was not given a spec to squish by, use dwimmery to get +what I want. $column_separator = "^([^\\w\r\n])\\1+[\r\n]+"; $empty_column = "^ +[\r\n]+"; } # Compile and cache this pattern. my $pattern = "(?m)(?:$empty_column)+(?=$column_separator)"; $pattern = $CompiledPatterns{$pattern} || qr/$pattern/m; return transpose Filter { s/$pattern//mg } transpose $table; } sub transpose { my ( $table ) = @_; return join( '', map join( '', @$_ ) . "\n", MapCarU( sub { [@_] }, map( [ split // ], split( /[\r\n]+/, $table ) ) ) ); } 1; __END__ =head1 NAME =head1 DESCRIPTION =head1 SYNOPSIS =head1 FUNCTIONS =over 4 =item $table = squishtable( $table ) =item $table = squishtable_dwim( $table ) =item $table = squishtable_spaces( $table ) =item $table = squishtable_sql( $table ) =item $table = squishtable_emacs( $table ) =item $table = squishtable( $table, $column_separator, $empty_column ) =back =cut

On 6/6/05, ..., Stephen <steve....@....com> wrote:
>
> The bells and ribbons on the sticks look like a good idea. This would make
> it less likely that I hold my sticks wrong way up. Maybe if we color coded
> them, I could also get them in the correct hands.

Steve,
I propose that *your* sticks be so color coded and marked. That way, we can use yours as a reference when orienting our own. I thought about this a bit this morning and was reminded how important it is that we maintain proper alignment for both long term stability and for musical aesthetics.

Consider that the wood sugar in the sap has now crystalized and formed a matrix inside the wood. If we get the up vs down orientation incorrect, we risk disturbing this through the action of gravity. I recall seeing in the archives some long thread where someone (Steve - was this you?) had worked out how long you could keep a stick upside down before the matrices began to sag and bend. No one likes a saggy crystaline matrix, certainly not me!

If enough of the wood sugar's structure has denormalized, we also run the risk of spontaneous and sudden shattering. I recall this happening to Jean's stick while outside of Smitten Kitten. I hit it and her end just came flying off! We were right by the sticks so I think she just got a new one and we finished the dance without further incident.

It could happen to you too!

There's also the tonality. If we get the right vs left confused, they'll won't be striking at the right notes. These sticks have been carefully tuned for dances in our particular key and it just wouldn't sound right. Imagine five sticks hitting at the same note but *one* being up or down a note. *shudder*!

Since I'm not a music person, I don't know what key we normally dance in, I just fake it.

Musically inclined people - what are our sticks tuned to anyway?

Denaturally yours,
  Josh


diotalevi's CSS

/* Comfortable editing regions */ textarea { width: 100%; height: 25em; } /* Form-fit everything to even-more dark than darktheme */ * { color: white !important; background-color: black !important; FONT-FAMILY: sans-serif; FONT-SIZE: 13px; FONT-WEIGHT: normal; } a { text-decoration: underline; } a:link { background-color: #000; } a:visited { background-color: #131; } form { display: inline; } pre { font-family: monospace; } tt * { font-family: monospace; color: green !important; } /* NodeReaper in small caps */ .chatfrom_52855 { font-variant: small-caps; } .borgism { font-variant: small-caps; } /* Hide all signatures - ugly things */ .pmsig { display: none; } /* Anonymize all notes */ .attribution { display: none; } /* Shun Anonymous Monk */ /* .pmnote-961 { display: none; } */ /* Shun Wassercrats */ .pmnote-152520 { display: none; } /* pmdev code */ nodelet.new-patch { font-weight: twinkling; } .diff_inserted { font-family: monospace; color: green !important; } .diff_deleted { font-family: monospace; color: green !important ; text-decoration: strikethrough !important; } .diff_match { font-family: monospace; }

#!/usr/bin/perl main( @ARGV ); exit; sub main { $DEBUG = grep /-d/, @ARGV; my $user = ( scalar grep !/^-/, @ARGV ) ? ( ( grep !/^-/, @ARGV )[0] ) : $ENV{'USER'}; my $ps = user_ps( $user ); unlink "/home/$user/.gnome/session"; my @to_kill; do { for ( [ zombies => sub { grep $_->{'status'} =~ /Z/, @_ } ], [ firefox => sub { grep $_->{'command'} =~ /firefox/, @_ + } ] ) { my ( $name, $filter ) = @$_; @to_kill = $filter->( @$ps ); killall( \ @to_kill, $ps ); } } until not @to_kill; 1; } sub killall { my @to_find = @{ shift() }; my @ps = @{ shift() }; my %pids; my %rel; for ( @ps ) { $pids{$->{'pid'}} = 1; $rel{$_->{'pid' }}{$_->{'ppid'}} = 1; $rel{$_->{'ppid'}}{$_->{'pid' }} = 1; } my %seen; my @to_kill = map $_->{pid}, @to_find; { my $changed = 0; do { my @n = grep !$seen{$_}++, grep $pids{$_}, map keys(%$_), grep ref(), delete @rel{ @to_kill }; push @to_kill, @n; $changed = scalar @n; } while $changed; } for my $sig ( qw[ INT TERM KILL ] ) { if ( @to_kill ) { my $cmd = "kill -$sig @to_kill"; if ( $DEBUG ) { print STDERR "$cmd\n"; } system $cmd; @to_kill = grep kill(0,$_), @to_kill; } if ( @to_kill ) { sleep 5; } } return 1; } sub all_user_ps { [ map { ! /(\S+)\s+(\S+)\s+(\S+)\s+(.+)/ ? () : +{ pid => $1, ppid => $2, status => $3, command => $4 } } split /[\r\n]+/, `ps a } sub user_ps { my $user = shift; [ map { ! /(\S+)\s+(\S+)\s+(\S+)\s+(.+)/ ? () : +{ pid => $1, ppid => $2, status => $3, command => $4 } } split /[\r\n]+/, `ps -U $user -o pid=,ppid=,s=,comm= --sort=pid,ppid` ]; }

THE RURAL DANCE ABOUT THE MAY-POLE - THE 
FIRST-FIGURE DANCE AT MR. YOUNG'S BALL, MAY, 1671. The 

MAY-POLE, for so the song is called in modern collections, 
is a very popular ditty at the present time. 
Come, lasses and lads, take leave of your dads,
And away to the may-pole hie;

For every he has got him a she,
And the minstrel's standing by;
For Willie has gotten his Jill,
And Johnny has got his Joan,
To jig it, jig it, jig it,
Jig it up and down.

'Strike up,' says Wat; 'Agreed,' says Kate,
'And I prithee, fiddler, play;'
'Content,' says Hodge, and so says Madge,
For this is a holiday.
Then every man did put
His hat off to his lass,
And every girl did curchy,
Curchy, curchy on the grass.

'Begin,' says Hall; 'Aye, aye,' says Mall,
'We'll lead up PACKINGTON'S POUND;'
'No, no,' says Noll, and so says Doll,
'We'll first have SELLENGER'S ROUND.'
Then every man began
To foot it round about;
And every girl did jet it,
Jet it, jet it, in and out.

'You're out,' says Dick; ''Tis a lie,' says Nick,

'The fiddler played it false;'
''Tis true,' says Hugh, and so says Sue,
And so says nimble Alice.
The fiddler then began
To play the tune again;
And every girl did trip it, trip it,
Trip it to the men.

'Let's kiss,' says Nan, 'Content,' says Pan,
And so says every she;


'How many?' says Batt; 'Why three,' says Matt,
'For that's a maiden's fee.'
But they, instead of three,
Did give them half a score,
And they in kindness gave 'em, gave 'em,
Gave 'em as many more.

Then after an hour, they went to a bower,
And played for ale and cakes;
And kisses, too; - until they were due,
The lasses kept the stakes:
The girls did then begin
To quarrel with the men;
And bid 'em take their kisses back,
And give them their own again.

Yet there they sate, until it was late,
And tired the fiddler quite,
With singing and playing, without any paying,
From morning unto night:
They told the fiddler then,
They'd pay him for his play;
And each a two-pence, two-pence,
Gave him, and went away.

'Good night,' says Harry; 'Good night,' says Mary;

'Good night,' says Dolly to John;
'Good night,' says Sue; 'Good night,' says Hugh;
'Good night,' says every one.
Some walked, and some did run,
Some loitered on the way;
And bound themselves with love-knots, love-knots,
To meet the next holiday.

#!/home/josh/perl5.8.3/bin/perl use strict; use warnings; use DBI; use MatchDB qw(add_source match); # Cam Gordon's city council campaign db add_source( name => 'camgordon', dbh => DBI->connect('DBI:CSV:'), table => 'camgordon.csv', id => sub { join( ' ', @{$_[0]}{qw( id no_sos )} ) }, map => [ [ qw[FIRST_NAME first_name] ], [ qw[LAST_NAME last_name] ], [ qw[HOUSE_NUMBER house_number] ], [ STREET_NAME => sub { join( ' ', @{$_[0]}{qw( street_name street_type street_direction )} ) } ], [ qw[CITY city] ] ] ); # Green Party of Minnesota add_source( name => 'gpm', dbh => DBI->connect('dbi:Pg:dbname=gpm'), table => 'contacts', id => 'contact_id', map => [ [ qw[FIRST_NAME first_name] ], [ qw[LAST_NAME last_name] ], [ qw[HOUSE_NUMBER house_number] ], [ qw[STREET_NAME address] ], [ qw[CITY city] ] ] ); # ACORN member roster add_source( name => 'acorn', dbh => DBI->connect('dbi:Pg:dbname=acorn'), table => 'acorn', id => 'id', map => [ [ qw[FIRST_NAME first_name] ], [ qw[LAST_NAME last_name] ], [ qw[HOUSE_NUMBER house_number] ], [ qw[STREET_NAME street_name] ], [ qw[CITY city] ] ] ); # State of Minnesota voter roster add_source( name => 'sosvr', dbh => DBI->connect('dbi:Pg:dbname=sosvr'), table => 'roster', id => 'id_gnumber', map => [ [ qw[FIRST_NAME first_gname] ], [ qw[LAST_NAME last_gname] ], [ qw[HOUSE_NUMBER house_g] ], [ qw[STREET_NAME street_gname] ], [ qw[CITY city] ] ] ); match( qw[HOUSE_NUMBER ==] );

my $keys = '(' . join( '|', map quotemata(), ( 'R&R Part', 'In Process', 'On Hand (05)', 'Loan Qty', 'Back Order Qty (14)', 'Ord Resvd', 'Min Qty' ) ) . ')'; my %matches = $input =~ /$keys.+?\e\[[\d;]*m\s*(\d+)/sig;

library(RODBC) pm <- odbcConnect("perlmonks") nodes.all <- list(Su00=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 0 AND EXTRACT('year' FROM createtime) = 2000 GROUP BY createtime::date) AS o"), Su01=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 0 AND EXTRACT('year' FROM createtime) = 2001 GROUP BY createtime::date) AS o"), Su02=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 0 AND EXTRACT('year' FROM createtime) = 2002 GROUP BY createtime::date) AS o"), Su03=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 0 AND EXTRACT('year' FROM createtime) = 2003 GROUP BY createtime::date) AS o"), Su04=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 0 AND EXTRACT('year' FROM createtime) = 2004 GROUP BY createtime::date) AS o"), Mo00=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 1 AND EXTRACT('year' FROM createtime) = 2000 GROUP BY createtime::date) AS o"), Mo01=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 1 AND EXTRACT('year' FROM createtime) = 2001 GROUP BY createtime::date) AS o"), Mo02=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 1 AND EXTRACT('year' FROM createtime) = 2002 GROUP BY createtime::date) AS o"), Mo03=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 1 AND EXTRACT('year' FROM createtime) = 2003 GROUP BY createtime::date) AS o"), Mo04=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 1 AND EXTRACT('year' FROM createtime) = 2004 GROUP BY createtime::date) AS o"), Tu00=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 2 AND EXTRACT('year' FROM createtime) = 2000 GROUP BY createtime::date) AS o"), Tu01=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 2 AND EXTRACT('year' FROM createtime) = 2001 GROUP BY createtime::date) AS o"), Tu02=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 2 AND EXTRACT('year' FROM createtime) = 2002 GROUP BY createtime::date) AS o"), Tu03=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 2 AND EXTRACT('year' FROM createtime) = 2003 GROUP BY createtime::date) AS o"), Tu04=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 2 AND EXTRACT('year' FROM createtime) = 2004 GROUP BY createtime::date) AS o"), We00=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 3 AND EXTRACT('year' FROM createtime) = 2000 GROUP BY createtime::date) AS o"), We01=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 3 AND EXTRACT('year' FROM createtime) = 2001 GROUP BY createtime::date) AS o"), We02=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 3 AND EXTRACT('year' FROM createtime) = 2002 GROUP BY createtime::date) AS o"), We03=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 3 AND EXTRACT('year' FROM createtime) = 2003 GROUP BY createtime::date) AS o"), We04=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 3 AND EXTRACT('year' FROM createtime) = 2004 GROUP BY createtime::date) AS o"), Th00=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 4 AND EXTRACT('year' FROM createtime) = 2000 GROUP BY createtime::date) AS o"), Th01=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 4 AND EXTRACT('year' FROM createtime) = 2001 GROUP BY createtime::date) AS o"), Th02=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 4 AND EXTRACT('year' FROM createtime) = 2002 GROUP BY createtime::date) AS o"), Th03=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 4 AND EXTRACT('year' FROM createtime) = 2003 GROUP BY createtime::date) AS o"), Th04=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 4 AND EXTRACT('year' FROM createtime) = 2004 GROUP BY createtime::date) AS o"), Fr00=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 5 AND EXTRACT('year' FROM createtime) = 2000 GROUP BY createtime::date) AS o"), Fr01=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 5 AND EXTRACT('year' FROM createtime) = 2001 GROUP BY createtime::date) AS o"), Fr02=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 5 AND EXTRACT('year' FROM createtime) = 2002 GROUP BY createtime::date) AS o"), Fr03=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 5 AND EXTRACT('year' FROM createtime) = 2003 GROUP BY createtime::date) AS o"), Fr04=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 5 AND EXTRACT('year' FROM createtime) = 2004 GROUP BY createtime::date) AS o"), Sa00=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 6 AND EXTRACT('year' FROM createtime) = 2000 GROUP BY createtime::date) AS o"), Sa01=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 6 AND EXTRACT('year' FROM createtime) = 2001 GROUP BY createtime::date) AS o"), Sa02=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 6 AND EXTRACT('year' FROM createtime) = 2002 GROUP BY createtime::date) AS o"), Sa03=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 6 AND EXTRACT('year' FROM createtime) = 2003 GROUP BY createtime::date) AS o"), Sa04=sqlQuery(pm,"SELECT count FROM (SELECT createtime::date, count(*) FROM node_times WHERE EXTRACT('dow' FROM createtime::date) = 6 AND EXTRACT('year' FROM createtime) = 2004 GROUP BY createtime::date) AS o")) boxplot(nodes_all)
Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others wandering the Monastery: (5)
As of 2024-03-19 07:42 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found