Perl Line of the Day

This is not the Obfuscated Perl Code Contest; that contest is a joke. If these examples are obfuscated, it is not because I was trying to be funny. (OK, it is not primarily because I was trying to be funny.) All code samples guaranteed authentic, usually from my own programs. Sometimes I determined that they were too obfuscated to live, and replaced them; other times they didn't make it into the final version for other reasons. All were intended seriously and were under serious consideration for at least a while.

  1 while s/[(][^()]*[)]//;

Here's another crack at the old problem of trying to write a regex to recognize strings that have balanced parentheses. It's something of a cheat, because it isn't really a single regex, and it destroys the test string.

It works by locating a (...) pair that has no parentheses inside it; this is therefore one of the maximally-nested sets of parentheses. It then removes this maximally-nested set and anything between them. The 1 while makes it into a loop that locates and removes the maximally-nested parenthesis pair repeatedly until no such pairs remain. If the resulting string contains any parentheses, they must not have been correctly matched, and so the original string was unbalanced. If the end product contains no parentheses at all, the original string must have been correctly balanced, because parentheses were only removed in matching pairs.

Here's an example. Suppose the original string was a(b(c)d(e(f)g)h)i(j(k)l(m)n)o. Then the successive iterations of the while loop will produce:

  a(b(c)d(e(f)g)h)i(j(k)l(m)n)o
  a(bd(e(f)g)h)i(j(k)l(m)n)o
  a(bd(eg)h)i(j(k)l(m)n)o
  a(bdh)i(j(k)l(m)n)o
  ai(j(k)l(m)n)o
  ai(jl(m)n)o
  ai(jln)o
  aio

The resulting string contains no parentheses, so it's correctly balanced. On the other hand, let's see what happens to a(b(c)d(e(f(g)h)i(j(k)l(m)n)o):

  a(b(c)d(e(f(g)h)i(j(k)l(m)n)o)
  a(bd(e(f(g)h)i(j(k)l(m)n)o)
  a(bd(e(fh)i(j(k)l(m)n)o)
  a(bd(ei(j(k)l(m)n)o)
  a(bd(ei(jl(m)n)o)
  a(bd(ei(jln)o)
  a(bd(eio)
  a(bd

Here it would have been easy enough to detect the imbalance because there are too many open parentheses and not enough close parentheses. Sometimes you see people suggest this expression:

  if ( tr/)// == tr /(// ) { # Balanced ... }

But this isn't correct because it says that )( is balanced, which it isn't. But the Line of the Day behaves correctly on this example, and also on more complicated examples:

  a(b(c)d(e(f)g)h)i(j)k)l(m(n)o
  a(bd(e(f)g)h)i(j)k)l(m(n)o
  a(bd(eg)h)i(j)k)l(m(n)o
  a(bdh)i(j)k)l(m(n)o
  ai(j)k)l(m(n)o
  aik)l(m(n)o
  aik)l(mo

Older Lines of the Day

• June 1999
  • ++vec($_[0], 1, 32) or ++vec($_[0], 0, 32);
  • /^(?:(?!foo$).)*$/
  • /^(|.|..|.*[^f]..|.*f[^o].|.*fo[^o])$/
  • /((?!foo)...|^.{0,2})$/
  • /^(?!.*foo$)/
  • (reverse $str) =~ /^(?!oof)/;
  • pipe(STDIN, OUT) or die "pipe: $!";
  • $lexer = '((?s)' . (join '|', map {quotemeta(pack 'S', $_) . ('..' x $opn[$_]) } (0.. $#opn)) . ')';
  • sub Rebind::TIEHASH { $_[1] }
  • my ($e, $l) = (pos($_), length $&);
  • print ((' ' x $end-$length), "^", ('-' x ($length-2)), "^ ? ");
  • s{\`([^\']*)\'}{print " $&\n"; my $r = lc <STDIN>; (substr($r,0,1) eq 'n') ? $& : "<tt>$1</tt>"}eg;
  • s{(.*?)(\`([^\']*)\')}{$pos += length $1;my $length = length $2;print ((' ' x ($pos)), "^", (' ' x ($length-2)), "^ ? ");my $r = lc <STDIN>;$pos += $length;(substr($r,0,1) eq 'n') ? $& : "$1<tt>$3</tt>"}eg;
  • print "\L\u$word";
  • grep ?foo?, @list;
  • pipe(F_IN, F_OUT) or die "pipe: $!"; write F_OUT;
• No updates April-May 1999
• March 1999
  • my @tokens = split /(\\\\(?=\\*[{}])|\\[{}]|[{}\n])/, $self->{SOURCE};
• February 1999
  • local $/ unless wantarray;
  • *{$safe->root . '::'} = \%{$package . '::'};
  • substr($permstrs[0], -1) =~ tr/-x/Ss/;
  • local *h = $h;
• No updates November 1998-January 1999
• October 1998
  • $t = $t->[$n>$a->[$t->[0]]?1:2] while ref $t;
• September 1998
  • sub untaint {(keys%{{$_[0],0}})[0]}
  • @header_lines = split /^(?!\s)/m, $HEADER;
  • defined $eq ? $eq->($a->[-$i], $b->[-$j]) : $a->[-$i] eq $b->[-$j])
  • $line =~ s/${\ quotemeta '$a'}/b/;
  • 0 + ($ao ? ($bo ? $ao * $bo * ($ao-$bo) : $ao) : $bo);
  • $selected = 'selected' if ($in{State} || $uinfo{state}) eq $state ;
• No updates May-August 1998
• April 1998
  • $top *= $top > 0;
  • my @s = (&senders(), &forwarders(), @H{'Reply-to'});
  • join $;,@_;
  • my (@q, $i) = @_; # This line is solemnly dedicated to \mjd.
  • @tokens = split(/([\(\[\{<>\}\]\)\s])/, $input);
  • sprintf(split(/$;/o, shift());
  • $suffix++ while $userdb->get_data("$u$suffix");
  • length($_[0] = $out);
  • @tokens = split(/(:=|\*\*|[-()+*\/;]|[A-Za-z_]\w*|(?:\d+(?:\.\d+)?))/, $str);
  • local $" = ')(';
  • @ftype = split /[. ]+/, '. p c ? d ? b ? - ? l ? s ? ? ?';
  • unless (x = new(ELEMENT)) die("Out of memory");
  • <<EOM;
  • $setuid = $setuid * 2 + ($perm =~ s/([st])$/($1 eq lc $1)?'x':'-'/ie);
• March 1998
  • @ADDRS = (@{+shift}, @EXTRA_ADDRS);
  • [map {[$first,@$_],['',@$_]} @$pow];
  • my $pow2 = [map {[@$_]} @$pow];
• February 1998
  • while ... die ... next .. chomp ... last
  • $revmemotable{$wrapper} = "$cref"; # Ha ha, Tom.
  • my @c = ("\0" x (3*$X)) x $Y;

Return to: Universe of Discourse main page | What's new page | Perl Paraphernalia

mjd-perl-lotd@plover.com