Re: regex for l33t speak

[Randy W. Sims]

Oops, I forgot to detab before inlining that, and there was some loose ends. Here it is again inlined and attached. It's not optimized in any way, opting instead for a quick straightforward implementation. Incomplete, possibly buggy, completely undocumented. I didn't write it as a patch for Casey's module because of the requirement for a dictionary file which is fairly standard on unixish, but must be obtained for other OS.

package Leetspeak;

use strict;
use warnings;

our $DEBUG = 0;

sub new {
    my $package = shift;
    my %args = @_;

    my $dict =
        (grep defined && -e, ( $args{dict}, '/usr/share/dict/words' ))[0];

    my %data = ( dict => $dict );
    my $self = bless( \%data, $package );

    $self->_read_dict();

    return $self;
}

{
    my %trans_tbl = (
      '@' =>     [ 'A' ],
      '$' =>     [ 'S' ],
      '+' =>     [ 'T' ],
      '0' => {
        '0'  =>  [ 'O' ],
        '0r' =>  [ 'ER' ],
      },
      '1' =>     [ 'I', 'L' ],
      '2' =>     [ 'Z' ],
      '3' => {
        '3'   => [ 'E' ],
        '3y3' => [ 'I' ],
      },
      '4' =>     [ 'A' ],
      '5' =>     [ 'S', 'Z' ],
      '6' =>     [ 'B', 'G' ],
      '7' =>     [ 'T' ],
      '8' =>     [ 'B' ],
      '9' =>     [ 'P', 'Q' ],
      'l' =>     [ 'I' ],
      'p' => {
        'p'   => [ 'O' ],
        'ph'  => [ 'F' ],
      },
      'x' =>     [ 'CK', 'CKS' ],
      'z' =>     [ 'S' ],
    );

    sub translate {
        my $self = shift;
        my $word = shift;
        my $start = shift || 0;

        print "translate( $word, $start )\n" if $DEBUG;

        return $word if $self->_has_word( $word );

        for my $i ( $start .. length( $word ) - 1 ) {
            my $ch = substr( $word, $i, 1 );
            next unless exists( $trans_tbl{$ch} );
            my $trans = ( ref( $trans_tbl{$ch} ) eq 'HASH' ) ?
                          $trans_tbl{$ch} : { $ch => $trans_tbl{$ch} };

            foreach my $key ( keys( %$trans ) ) {
                my $key_len = length( $key );
                if ( substr( $word, $i, $key_len ) eq $key ) {
                    foreach my $tr ( @{ $trans->{$key} } ) {
                        print "substr( $word, $i, $key_len ) = $tr\n"
                            if $DEBUG;
                        my $new_word = $word;
                        substr( $new_word, $i, $key_len ) = lc( $tr );
                        my $offset = $key_len - length( $tr );
                        $offset ||= 1;
                        my $result =
                            $self->translate( $new_word, $i + $offset );
                        return $result if $result;
                    }
                }
            }
        }

        return undef;

    }

}

sub dict { return $_[0]->{dict} }

sub _read_dict {
    my $self = shift;
    my %words;

    open( my $fh, '<', $self->{dict} ) or die $!;
    while (defined( my $word = <$fh> )) {
        chomp( $word );
        $words{$word} = 1;
    }
    close( $fh );

    $self->{words} = \%words;
    return scalar %words;
}

sub _has_word {
    my $self = shift;
    my $word = shift;
    $word = lc( $word );
    return 1 if exists( $self->{words}{$word} );
}

1;

Leetspeak.pm
Description: Perl program

-- 
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
<http://learn.perl.org/> <http://learn.perl.org/first-response>