Perl Code from Hell

Maddingue on 2007-09-11T13:17:25

I just finished a strange project (provide a JSON/HTTP API to manage serial barcodes printers), and now must start a new one. This time it's about "improving" a CGI program that does network stuff.

What it does isn't as interesting as the current state of the program.

First, it has the classical strange things of old programs made by people learning Perl as they were writing it: it uses CGI.pm with the infamous :standard import, and yet has its own function for parsing CGI parameters. Funny fact: 10% of the program lines are print() with HTML tags.

The really funny thing is the parts of the program that update, store and retrieve data in a big structure. An exerpt looks like this:

%{${$PCSSDUMP{CSSS}}{$css}}=%{${$CSSDUMP{CSSS}}{$css}} if ( eval { $css =~ /$var/i } );
		foreach my $owner ( keys ( %{${${$CSSDUMP{CSSS}}{$css}}{OWNERS}} ) )
		{
			%{${${${$PCSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}=%{${${${$CSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}} if ( eval { $owner =~ /$var/i } );
			foreach my $content ( keys ( %{${${${${$CSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}{CONTENTS}} ) )
			{
				my $vip = ${${${${${${$CSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}{CONTENTS}}{$content}}{IPADDRESS};
				%{${${${${${$PCSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}{CONTENTS}}{$content}}=%{${${${${${$CSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}{CONTENTS}}{$content}} if ( eval { $content =~ /$var/i } );
				%{${${${${${$PCSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}{CONTENTS}}{$content}}=%{${${${${${$CSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}{CONTENTS}}{$content}} if ( eval { $vip =~ /$var/i } );

(Here you can insert a rant about how the textarea to write journal entries really is too small.)

Well, I don't think I need to comment this, but there's a more than a few chunks like this one, with up to four nested foreach().

Maybe this is just proof that I did something really nasty in a previous life.


you must be joking

duff on 2007-09-11T13:52:05

That is real, actual, in production code?

I'm sorry you have to deal with it. That looks even worse than the PHP I have to maintain at $work.

Re: you must be joking

Maddingue on 2007-09-11T14:00:13

I swear this is real, actual, in production code. My problem here will be to understand that code, and rewrite it from scratch in standard Perl. The next two months will be fun...

Re: you must be joking

steph on 2007-09-12T07:48:28

Pfoouh. my head still hurts from looking at one line. Must have been some kind of generated code, even writing that would be painful.

Maybe it's worth to try to write some preprocessor to transform the code into something a bit more decent. Also can Perl::Tidy do something? if not, send to the author some tests ;)

cheers --stephan p.s seems to me you'll be cleaning "les écuries d'Augias", but don't use brute force ;)

Re: you must be joking

Maddingue on 2007-09-12T09:03:43

I don't think it's generated code. It's just handwritten code with cargo-cult gone wrong and too much copy&paste.

I've tried Perl::Tidy and PPI, but they're not helpful in such case. I've also looked at how I could preprocess this, but didn't find a way, so I'm doing this by hand. I'll post the result soon for the fun of comparison.

Representative expression

Aristotle on 2007-09-11T16:16:11

I think you can send this to DailyWTF for their “representative line” feature. Just this line would be enough:

%{${${${$PCSSDUMP{CSSS}}{$css}}{OWNERS}}{$owner}}=%{${${${$CSSDUMP{CSSS}}{$css}} {OWNERS}}{$owner}} if ( eval { $owner =~ /$var/i } );

As an exercise, consider what it might say about the rest of the system that a mere pattern match is wrapped in an eval.

Re: Representative expression

Maddingue on 2007-09-11T17:12:05

No need to shout too widely about such code. I've heard people already know how bad Perl is ;-)

All the eval { $value =~ /$var/i } bits are because they use Perl regexps to find elements. Yes, it means $var comes straight from user input, but it's an internal program, not accessible outside our network. I'll just remove these eval and replace them with one $regexp = eval { qr/$var/i } and return early if eval fails.