comment on

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);
}
[download]

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

In reply to Perl Geek Code .. diffed! by BigLug

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		`&`
	<		`<`
	>		`>`
	[		`[`
	]		`]`

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.