view release on metacpan or  search on metacpan

lib/Acme/Tie/Eleet.pm  view on Meta::CPAN

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__

=head1 NAME

Acme::Tie::Eleet - Perl extension to 5pE4k 1Ik3 4n 3l337!


=head1 SYNOPSIS

B<!!!See the BUGS section below!!!>

  use Acme::Tie::Eleet;
  print "This is eleet!\n";

  tie *OUT, 'Acme::Tie::Eleet', *OUT, case_mixer => "1/1";
  print OUT "This is eleet\n";

  Or, even, to translate instant sentences:
  perl -MAcme::Tie::Eleet -p -e ''

  tie $bar, 'Acme::Tie::Eleet', spacer => 0;
  $bar = "eleet";
  print $bar;


=head1 DESCRIPTION

Have you ever wanted to speak like an eleet? Do you feel like it's too
difficult to do your case mixin' manually? Tired of being laugh at by
your mates because your quotes don't make you look like an h4x0r?
Well, there's a solution, and you're reading the documentation of the
module specially made for u, Ye4h M4n!