Public Scratchpad | Download, Select Code To D/L |
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)