File Coverage

blib/lib/Acme/Tie/Eleet.pm

Criterion	Covered	Total	%
statement	119	123	96.7
branch	71	86	82.5
condition	30	39	76.9
subroutine	17	18	94.4
pod			n/a
total	237	266	89.1

#
# This file is part of Acme::Tie::Eleet.
# Copyright (c) 2001-2007 Jerome Quelin, all rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
#

package Acme::Tie::Eleet;

use strict;
use warnings;

use Carp;
use IO::Handle;

our $VERSION = '1.0.2';


# Our to allow user to hack/overwrite it.
our @beg = ( "hey man, ", "hey dude, ", "cool, ", '$#$!#!$ ', "sure, ", "hey, ",
	     "yeah, ", "yeah man, ", "yeah dude, ", "listen, ", "listen pal, " );
our @end = ( ", fear us.", ", d'ya think so?",  ' $#$!#!$!' );
our @sentences = ( "Fear us!", "All your base are belong to us!",
		   "Resistance is futile; you will be assimilated.",
		   "Resistance is futile.", "Whololo!" );
our %words  =
    ( apps      => "appz",
      are       => "r",
      awesome   => "awesum",
      because   => "cuz",
      capital   => "capitull",
      cool      => [ "kool", "kewl" ], # Anon arrays accepted.
      dude      => "dood",
      elite     => "eleet",
      every     => "evry",
      everybody => "evry budy",
      freak     => "phreak",
      games     => "gamez",
      hacker    => "haxor",
      hackers   => "haxors",
      letter    => "lettr",
      letters   => "lettrs",
      phone     => "fone",
      rule      => "rulez",
      see       => "c",
      the       => "da",
      wares     => "warez",
      you       => "u",
);


# Populate the hash.
my %letter =
    ( a => [ "4", "@" ],
      c => "(",
      e => "3",
      g => "6",
      h => [ "|-|", "]-[" ],
      k => [ "|<", "]{" ],
      i => "!",
      l => [ "1", "|" ],
      m => [ "|V|", "|\\/|" ],
      n => "|\\|",
      o => "0",
      s => [ "5", "Z" ],
      t => [ "7", "+"],
      u => "\\_/",
      v => "\\/",
      w => [ "vv", "\\/\\/" ],
      'y' => "j",
      z => "2",
      );


#--
# Constructor

sub _new {
    # Create object.
    my $self = {
	letters    => 25,    # transform o to 0, l to 1, etc.
	spacer     => "1/0", # %age 0=no extra spaces, 'm/n'=m extra+n noextra, 60=3/5 at random
	case_mixer => 50,    # %age 0=nothing, 'm/n'=m ucase+n lcase, 25=1/4 at random
	words      => 1,     # transform cool to kewl or kool, etc.
	add_before => 15,    # add comments before sentence.
	add_after  => 15,    # add comments after sentences.
	extra_sent => 10,    # extra sentences.
	@_,                  # overwrite with user values.
	# internals, do not modify.
	_space    => "m0",
	_case_mix => "m0"
    };

    # Check patterns.
    $self->{spacer} =~ m!^(((\d+)/(\d+))|(\d+))$!
	or  croak "spacer: wrong pattern $self->{spacer}";
    $self->{spacer} =~ m!^(\d+)/(\d+)$! && $1+$2 == 0
	and croak "spacer: illegal pattern $self->{spacer}";
    $self->{case_mixer} =~ m!^(((\d+)/(\d+))|(\d+))$!
	or  croak "case_mixer: wrong pattern $self->{case_mixer}";
    $self->{case_mixer} =~ m!^(\d+)/(\d+)$! && $1+$2 == 0
	and croak "case_mixer: illegal pattern $self->{case_mixer}";

    # Init internals.
    $self->{spacer}      =~ m!^(\d+)/(\d+)$! && $1 == 0
	and $self->{_space}    = "n0";
    $self->{case_mixer} =~ m!^(\d+)/(\d+)$! && $1 == 0
	and $self->{_case_mix} = "n0";

    # Return the hash ref.
    return $self;
}


sub TIEHANDLE {
    # Process args.
    my $pkg = shift;
    my $fh  = shift;
    ref $pkg and croak "Not an instance method";

    $fh or croak "Filehandle is not an optional paramater";
    $fh->autoflush(1);

    my $self  = &_new; # magic call.
    $self->{FH} = $fh;

    # Return it.
    return bless( $self, $pkg );
}


sub TIESCALAR {
    # Process args.
    my $pkg = shift;
    ref $pkg and croak "Not an instance method";

    my $self  = &_new; # magic call.
    $self->{value} = undef;

    # Return it.
    return bless( $self, $pkg );
}


#--
# Handlers.

# Catch scalar fetching.
sub FETCH {
    my $self = shift;
    return $self->_transform( $self->{value} );
}

# Catch calls to print.
sub PRINT {
    my $self = shift;
    my $fh = $self->{FH};
    $_[0] or return;
    print $fh $self->_transform(join "", @_);
}

# Catch scalar storing.
sub STORE {
    $_[0]{value} = $_[1];
}


#--
# Modification plugins.

#
# All plugins will get (not counting the object that will always be
# the first argument) a string to modify. Each string will contain one
# and only one sentence.
#

# Add preambles randomly.
sub _apply_add_before {
    my ($self, $target) = @_;
    if ( rand(100) < $self->{add_before} ) {
	my $before = $beg[ rand( int(@beg) ) ];
	$target = $before.$target;
    }
    return $target;
}

# Add end of sentences randomly.
sub _apply_add_after {
    my ($self, $target) = @_;
    if ( rand(100) < $self->{add_after} ) {
	my $after = $end[ rand( int(@end) ) ];
	$target  .= $after;
    }
    return $target;
}

# Mix case as wanted.
sub _apply_case_mixer {
    my ($self, $target) = @_;

    if ( $self->{case_mixer} =~ m!^(\d+)/(\d+)$! ) {
	# Fixed pattern.
	my $what = "";
	my ($m, $n) = ( $1, $2 );
	for my $c (split //, $target) {
	    $self->{_case_mix} =~ m/^([mn])(\d+)$/;
	    $what .= ($1 eq "m") ? uc($c) : $c;
	    my $new;
	    my $count = $2 + 1;
	    if ( $1 eq "m" ) {
		$2+1 != $m            and $new = "m$count";
		$2+1 == $m && $n == 0 and $new = "m0";
		$2+1 == $m && $n != 0 and $new = "n0";
	    } else {
		$2+1 != $n            and $new = "n$count";
		$2+1 == $n && $m == 0 and $new = "n0";
		$2+1 == $n && $m != 0 and $new = "m0";
	    }
	    $self->{_case_mix} = $new;
	}
	$target = $what;
    } else {
	# Put extra space at random.
	$target =~ s/(.)/rand(100)<$self->{case_mixer}?uc($1):$1/eg;
    }
    return $target;
}

# Add whole sentences randomly.
sub _apply_extra_sent {
    my $self = shift;
    if ( rand(100) < $self->{extra_sent} ) {
	return $sentences[rand( @sentences ) ];
    }
    return undef;
}

# Transform o to 0, l to 1, etc. That's 31337!
sub _apply_letters {
    my ($self, $target) = @_;

    return join "", map { rand(100) < $self->{letters} && exists $letter{$_} ?
			      ( ref($letter{$_}) eq ref([]) ) ?
				  $letter{$_}[rand( @{$letter{$_}} ) ] :
				      $letter{$_}
			  : $_ } split //, $target;
}

# Put extra space between chars.
sub _apply_spacer {
    my ($self, $target) = @_;

    if ( $self->{spacer} =~ m!^(\d+)/(\d+)$! ) {
	# Fixed pattern.
	my $what = "";
	my ($m, $n) = ( $1, $2 );
	for my $c (split //, $target) {
	    $self->{_space} =~ m/^([mn])(\d+)$/;
	    $what .= ($1 eq "m") ? "$c " : $c;
	    my $new;
	    my $count = $2 + 1;
	    if ( $1 eq "m" ) {
		$2+1 != $m            and $new = "m$count";
		$2+1 == $m && $n == 0 and $new = "m0";
		$2+1 == $m && $n != 0 and $new = "n0";
	    } else {
		$2+1 != $n            and $new = "n$count";
		$2+1 == $n && $m == 0 and $new = "n0";
		$2+1 == $n && $m != 0 and $new = "m0";
	    }
	    $self->{_space} = $new;
	}
	$target = $what;
    } else {
	# Put extra space at random.
	$target =~ s/(.)/rand(100)<$self->{spacer}?"$1 ":$1/eg;
    }
    return $target;
}

# Transform words according to %words.
sub _apply_words {
    my ($self, $target) = @_;
    my @what = ();
    for my $word ( split / /, $target ) {
	if ( exists( $words{$word} ) ) {
	    my $subst = $words{$word};
	    $word = ref($subst) eq ref([]) ?
		$subst->[ rand( int(@$subst) ) ]
	      : $subst;
	}
	push @what, $word;
    }
    return join " ", @what;
}

# Main entry point for string transformation.
sub _transform {
    my ($self, $line) = @_;

    $line or return; # Case undef.
    my $sentence;
    my @what = split "([.?!\n])", lc $line;
    while ( my ($what, $punc) = splice @what, 0, 2 ) {
	# Build the sentence.
	$self->{add_before} and $what = $self->_apply_add_before($what);
	$self->{add_after}  and $what = $self->_apply_add_after($what);

	defined($punc) and $what .= $punc;

	my $extra = $self->_apply_extra_sent();
	$extra and $what .= " $extra";

	# Transform chars.
	foreach my $plugin ( qw( words spacer letters case_mixer ) ) {
	    my $meth = "_apply_$plugin";
	    $self->{$plugin} and $what = $self->$meth($what);
	}
	$sentence .= $what;
    }
    return $sentence;
}

# By default, tie standard filedescriptors.
# tie *STDOUT, __PACKAGE__, *STDOUT;
# tie *STDERR, __PACKAGE__, *STDERR;


1;
__END__