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
