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

Perl Geek Code .. diffed!

by BigLug (Chaplain)
on Feb 21, 2004 at 04:46 UTC ( #330765=CUFP: print w/ replies, xml ) Need Help??

As I visited my home node this morning to update my CPAN modules I realised my Perl Geek Code would be very much out of date. I headed off to the Perl Geek Code website and went back through the survey. I got my brand-spankin-new PGC and went to post if on my home node. However as I was about to delete the old stuff I wondered what had changed. Of course, being a perl geek, any comparisons I made would have to be in perl.

After a few hours I've hacked together my diff engine for comparing two pieces of perl geek code. Here's the code:

#!/usr/bin/perl -w use strict; use CGI qw/:standard/; my $verbose=param('verbose') || 0; my $code1 = param('code1'); my $code2 = param('code2'); print header, start_html( -title => "The Perl Geek Code... diffed", -bgcolor => "#FFFFFF"), h1( "The Perl Geek Code... diffed"), hr; print p( strong ( "The Perl Geek Code - Version 0.01")); unless ($code1 and $code2) { print start_form; print "Enter your old geek code:" . br; print textarea( -name => 'code2', -rows => 5, -cols => 45, ), p; print "Enter your new geek code:" . br; print textarea( -name => 'code1', -rows => 5, -cols => 45, ), p; print "What output do you want:" . br; my %options = ( 0 => 'Only tell me what\'s changed.', 1 => 'Also tell me what hasn\'t changed', 2 => 'Even remind me what I don\'t get paid for.' ); print popup_menu( -name=>'verbose', -values=>[0..2], -labels=>\%options, ),p; print submit, endform; exit(); } $code1=~ s/^\s*-+BEGIN PERL GEEK CODE BLOCK-+\s*\n\s*Version: \d\.\d+\ +s*\n//; $code1=~ s/\s*-+END PERL GEEK CODE BLOCK-+\s*$//; $code2=~ s/^\s*-+BEGIN PERL GEEK CODE BLOCK-+\s*\n\s*Version: \d\.\d+\ +s*\n//; $code2=~ s/\s*-+END PERL GEEK CODE BLOCK-+\s*$//; open( DESC, "<./pgc_desc") or die "cannot open desc file: $!"; my %desc; #my %desc= map { split /[\t\n]/ } <DESC>; #I used to say I often try to use map, but as soon as I have a problem + in the code I replace it with a foreach but now I say I know the dif +ference between map and grep... in theory. foreach (<DESC>) { chomp; my ($key, $value) = split(/\t/,$_,2); $desc{$key} = ($key=~/\W/) ? '<i>'.$value.'</i>' : $value; } close DESC; my %code1 = parseCode( $code1 ); my %code2 = parseCode( $code2 ); # Compare common keys foreach my $key ( sort keys %code1 ) { # do individuals last next unless $code2{$key}; # dont talk if they match if ($code1{$key}{code} eq $code2{$key}{code}) { if ($verbose) { print '<h3>'.$desc{$key}."</h3>\n"; printf("Code: <tt>%s</tt>",$code2{$key}{code}); print "<br>\n"; if($code1{$key}{range}){ printf("My tendencies still range from %s to %s. ", $desc{$key.$code2{$key}{level}}, $desc{$key.$code2{$key}{range}} ); } else { print "I still say " . $desc{$key.$code1{$key}{level}} + . '. '; } my $paid = ($code1{$key}{'paid'}) ? "I get paid for it. " : ($verbose > 1) ? "I don't get paid for it. " : ''; print $paid; print "I'd like to be able to say " . $desc{$key.$code2{$key}{wannabe}} . '. ' if $code2{$ke +y}{wannabe}; } delete $code1{$key}; delete $code2{$key}; next; } # otherwise compare them print '<h3>'.$desc{$key}."</h3>\n"; printf("Old: <tt>%s</tt> New: <tt>%s</tt>",$code2{$key}{code}, $ +code1{$key}{code}); print "<br>\n"; # compare the levels unless ( $code1{$key}{range} eq $code2{$key}{range} and $code1{$key}{level} eq $code2{$key}{level} ) { if($code2{$key}{range}){ printf("My tendencies used to range from %s to %s", $desc{$key.$code2{$key}{level}}, $desc{$key.$code2{$key}{range}} ); } else { print "I used to say " . $desc{$key.$code2{$key}{level}}; } print " but now I say "; if($code1{$key}{range}){ printf("my tendencies range from %s to %s. ", $desc{$key.$code2{$key}{level}}, $desc{$key.$code2{$key}{range}} ); } else { print $desc{$key.$code1{$key}{level}} . '. '; } } elsif ($verbose) { if($code1{$key}{range}){ printf("My tendencies still range from %s to %s. ", $desc{$key.$code2{$key}{level}}, $desc{$key.$code2{$key}{range}} ); } else { print "I still say " . $desc{$key.$code1{$key}{level}} . ' +. '; } } unless ($code1{$key}{wannabe} eq $code2{$key}{wannabe}) { if ($code1{$key}{wannabe} and not $code2{$key}{wannabe}) { print "I used to attain to nothing but now I wish I could +say " . $desc{$key.$code1{$key}{wannabe}} . '. '; } elsif ($code2{$key}{wannabe} and not $code1{$key}{wannabe}) +{ if (level2num($code1{$key}{level}) > level2num($code2{$key +}{wannabe})) { print "My old ambition of being able to say " . $desc{$key.$code2{$key}{wannabe}} . " has been attained as " . $desc{$key.$code1{$key} +{level}} . '. '; } elsif (level2num($code1{$key}{level}) == level2num($code +2{$key}{wannabe})) { print "My old ambition of being able to say " . $desc{$key.$code2{$key}{wannabe}} . " has been attained. "; } else { print "I used to want to be able to say " . $desc{$key.$code2{$key}{wannabe}} . ", but I lost that ambition. "; } } else { print "I used to want to be able to say " . $desc{$key.$code2{$key}{wannabe}} . " but now I say " . $desc{$key.$code1{$key}{wannabe}} . '. '; } } elsif ($verbose and $code2{$key}{wannabe}) { print "I'd still like to be able to say " . $desc{$key.$code2{$key}{wannabe}} . '. '; } unless ($code1{$key}{paid} eq $code2{$key}{paid}) { if ($code1{$key}{paid} and not $code2{$key}{paid}) { print "I now get paid for it. " } elsif ($code2{$key}{paid} and not $code1{$key}{paid}) { print "I no longer get paid for it. " } else { printf("Something weird happened to the paid code: [%s] [% +s]. ", $code1{$key}{paid}, $code2{$key}{paid}); } } elsif ($verbose and $code1{$key}{paid}) { print "I still get paid for it." } elsif ($verbose > 1 and not $code1{$key}{paid}) { print "I still don't get paid for it." } print "<p>\n\n"; delete($code1{$key}); delete($code2{$key}); } # Report on new tags foreach my $key ( sort keys %code1 ) { next unless $code1{$key}{code}; print '<h3>'.$desc{$key}."</h3>\n"; printf("New: <tt>%s</tt>",$code1{$key}{code}); print "<br>\n"; print "I now say " . $desc{$key.$code1{$key}{level}} . '. '; print "I get paid for it. " if $code1{$key}{paid}; print "I wish I could say " . $desc{$key.$code1{$key}{wannabe}} if + $code1{$key}{wannabe}; } # Report on forgotten tags foreach my $key ( sort keys %code2 ) { next unless $code2{$key}{code}; print '<h3>'.$desc{$key}."</h3>\n"; printf("Old: <tt>%s</tt>",$code2{$key}{code}); print "<br>\n"; print "I no longer say " . $desc{$key.$code2{$key}{level}} . '. '; + print "So I no longer get paid for it. " if $code2{$key}{paid}; print "And I've stopped wishing I could say " . $desc{$key.$code2{ +$key}{wannabe}} if $code2{$key}{wannabe}; } sub parseCode { my $code = shift; return () unless $code; my %return; foreach my $segment ( $code =~ m{(\w+\W*)}g ){ $segment=~s/\s+/ /gs; $segment=~s/(\W)\s+$/$1/gs; # warn $segment; my @thiscode = $segment =~ m{((\w+) # the item + $2 ([*!? +-]+) # the level $3 (?:\>([*!? +-]+))? # optional >level $4 (?:\(([*! ?+-]+)\))? # optional (level) $5 (\@)? # optional @ $6 (\$)? ) # optional $ $7 }x; $segment =~ s/\@//g; # varies doesn't work yet die("Unable to parse $segment in $code") unless $thiscode[1]; $return{$thiscode[1]} = { level => $thiscode[2] || '', wannabe => $thiscode[3] || '', range => $thiscode[4] || '', varies => $thiscode[5] || '', paid => $thiscode[6] || '', code => $thiscode[0] || '', }; } return %return; } sub level2num { my $level = shift; return 0 if $level eq ' '; return ($level=~/\-/) ? -1 * length($level) : length ($level); }
Now, before you run off and try it, read this rule: Don't read your current perl geek code before you create a new one. That will influence how you answers and will remove the fascination. Once you have your old and your new PGC, run the above CGI. Paste the codes into the appropriate places and click Submit. Voila! there's the differences between the old and the new.

(The above code is CGI and you'll also need to download the pgc_desc file from the Perl Geek Code homepage. If you don't want to run it yourself, you can use my server at http://www.isite.net.au/perlmonks/pgc_diff.pl)


"Get real! This is a discussion group, not a helpdesk. You post something, we discuss its implications. If the discussion happens to answer a question you've asked, that's incidental." -- nobull@mail.com in clpm

Comment on Perl Geek Code .. diffed!
Download Code
Re: Perl Geek Code .. diffed!
by z3d (Scribe) on Feb 24, 2004 at 12:04 UTC
    Advanced Warning: Slightly off topic...
    Tried the link, took the time to carefully click my mouse along, and *poof* Error 414 URI too long

    Guess it's back to the mines for me.



    "I have never written bad code. There are merely unanticipated features."
Re: Perl Geek Code .. diffed!
by leedo (Novice) on Feb 24, 2004 at 15:39 UTC
    That is really neat. I just recently filled out my PGC for the first time and was thinking that I would love to see how far I progress in the next year or so.

    I'll have to run your code when the time comes. :)

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://330765]
Approved by jweed
Front-paged by jweed
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others making s'mores by the fire in the courtyard of the Monastery: (6)
As of 2014-09-18 22:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

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











    Results (125 votes), past polls