lib/Acme/Tie/Eleet.pm

   1 #
   2 # Copyright (c) 2001-2003 Jerome Quelin <jquelin@cpan.org>
   3 # All rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the same terms as Perl itself.
   7 #
   8
   9 #-----------------------------------#
  10 #          Initialization.          #
  11 #-----------------------------------#
  12
  13 package Acme::Tie::Eleet;
  14
  15 # A little anal retention :-)
  16 use strict;
  17 use warnings;
  18
  19 # Modules we relied upon.
  20 use Carp;
  21 use IO::Handle;
  22
  23 # Variables of the modules.
  24 our $VERSION = '1.0.0';
  25 my %letter;
  26
  27 # Our to allow user to hack/overwrite it.
  28 our @beg = ( "hey man, ", "hey dude, ", "cool, ", '$#$!#!$ ', "sure, ", "hey, ",
  29              "yeah, ", "yeah man, ", "yeah dude, ", "listen, ", "listen pal, " );
  30 our @end = ( ", fear us.", ", d'ya think so?",  ' $#$!#!$!' );
  31 our @sentences = ( "Fear us!", "All your base are belong to us!",
  32                    "Resistance is futile; you will be assimilated.",
  33                    "Resistance is futile.", "Whololo!" );
  34 our %words  =
  35     ( apps      => "appz",
  36       are       => "r",
  37       awesome   => "awesum",
  38       because   => "cuz",
  39       capital   => "capitull",
  40       cool      => [ "kool", "kewl" ], # Anon arrays accepted.
  41       dude      => "dood",
  42       elite     => "eleet",
  43       every     => "evry",
  44       everybody => "evry budy",
  45       freak     => "phreak",
  46       games     => "gamez",
  47       hacker    => "haxor",
  48       hackers   => "haxors",
  49       letter    => "lettr",
  50       letters   => "lettrs",
  51       phone     => "fone",
  52       rule      => "rulez",
  53       see       => "c",
  54       the       => "da",
  55       wares     => "warez",
  56       you       => "u",
  57 );
  58
  59
  60 # Populate the hash.
  61 %letter =
  62     ( a => [ "4", "@" ],
  63       c => "(",
  64       e => "3",
  65       g => "6",
  66       h => [ "|-|", "]-[" ],
  67       k => [ "|<", "]{" ],
  68       i => "!",
  69       l => [ "1", "|" ],
  70       m => [ "|V|", "|\\/|" ],
  71       n => "|\\|",
  72       o => "0",
  73       s => [ "5", "Z" ],
  74       t => [ "7", "+"],
  75       u => "\\_/",
  76       v => "\\/",
  77       w => [ "vv", "\\/\\/" ],
  78       'y' => "j",
  79       z => "2",
  80       );
  81
  82 #--------------------------------#
  83 #          Constructor.          #
  84 #--------------------------------#
  85
  86 sub _new {
  87     # Create object.
  88     my $self = {
  89         letters    => 25,    # transform o to 0, l to 1, etc.
  90         spacer     => "1/0", # %age 0=no extra spaces, 'm/n'=m extra+n noextra, 60=3/5 at random
  91         case_mixer => 50,    # %age 0=nothing, 'm/n'=m ucase+n lcase, 25=1/4 at random
  92         words      => 1,     # transform cool to kewl or kool, etc.
  93         add_before => 15,    # add comments before sentence.
  94         add_after  => 15,    # add comments after sentences.
  95         extra_sent => 10,    # extra sentences.
  96         @_,                  # overwrite with user values.
  97         # internals, do not modify.
  98         _space    => "m0",
  99         _case_mix => "m0"
 100     };
 101
 102     # Check patterns.
 103     $self->{spacer} =~ m!^(((\d+)/(\d+))|(\d+))$!
 104         or  croak "spacer: wrong pattern $self->{spacer}";
 105     $self->{spacer} =~ m!^(\d+)/(\d+)$! && $1+$2 == 0
 106         and croak "spacer: illegal pattern $self->{spacer}";
 107     $self->{case_mixer} =~ m!^(((\d+)/(\d+))|(\d+))$!
 108         or  croak "case_mixer: wrong pattern $self->{case_mixer}";
 109     $self->{case_mixer} =~ m!^(\d+)/(\d+)$! && $1+$2 == 0
 110         and croak "case_mixer: illegal pattern $self->{case_mixer}";
 111
 112     # Init internals.
 113     $self->{spacer}      =~ m!^(\d+)/(\d+)$! && $1 == 0
 114         and $self->{_space}    = "n0";
 115     $self->{case_mixer} =~ m!^(\d+)/(\d+)$! && $1 == 0
 116         and $self->{_case_mix} = "n0";
 117
 118     # Return the hash ref.
 119     return $self;
 120 }
 121
 122 sub TIEHANDLE {
 123     # Process args.
 124     my $pkg = shift;
 125     my $fh  = shift;
 126     ref $pkg and croak "Not an instance method";
 127
 128     $fh or croak "Filehandle is not an optional paramater";
 129     $fh->autoflush(1);
 130
 131     my $self  = &_new; # magic call.
 132     $self->{FH} = $fh;
 133
 134     # Return it.
 135     return bless( $self, $pkg );
 136 }
 137
 138 sub TIESCALAR {
 139     # Process args.
 140     my $pkg = shift;
 141     ref $pkg and croak "Not an instance method";
 142
 143     my $self  = &_new; # magic call.
 144     $self->{value} = undef;
 145
 146     # Return it.
 147     return bless( $self, $pkg );
 148 }
 149
 150
 151 #-----------------------------#
 152 #          Handlers.          #
 153 #-----------------------------#
 154
 155 # Catch scalar fetching.
 156 sub FETCH {
 157     my $self = shift;
 158     return $self->_transform( $self->{value} );
 159 }
 160
 161 # Catch calls to print.
 162 sub PRINT {
 163     my $self = shift;
 164     my $fh = $self->{FH};
 165     $_[0] or return;
 166     print $fh $self->_transform(join "", @_);
 167 }
 168
 169 # Catch scalar storing.
 170 sub STORE {
 171     $_[0]{value} = $_[1];
 172 }
 173
 174
 175 #-----------------------------------------#
 176 #          Modification plugins.          #
 177 #-----------------------------------------#
 178
 179 #
 180 # All plugins will get (not counting the object that will always be
 181 # the first argument) a string to modify. Each string will contain one
 182 # and only one sentence.
 183 #
 184
 185 # Add preambles randomly.
 186 sub _apply_add_before {
 187     my ($self, $target) = @_;
 188     if ( rand(100) < $self->{add_before} ) {
 189         my $before = $beg[ rand( int(@beg) ) ];
 190         $target = $before.$target;
 191     }
 192     return $target;
 193 }
 194
 195 # Add end of sentences randomly.
 196 sub _apply_add_after {
 197     my ($self, $target) = @_;
 198     if ( rand(100) < $self->{add_after} ) {
 199         my $after = $end[ rand( int(@end) ) ];
 200         $target  .= $after;
 201     }
 202     return $target;
 203 }
 204
 205 # Mix case as wanted.
 206 sub _apply_case_mixer {
 207     my ($self, $target) = @_;
 208
 209     if ( $self->{case_mixer} =~ m!^(\d+)/(\d+)$! ) {
 210         # Fixed pattern.
 211         my $what = "";
 212         my ($m, $n) = ( $1, $2 );
 213         for my $c (split //, $target) {
 214             $self->{_case_mix} =~ m/^([mn])(\d+)$/;
 215             $what .= ($1 eq "m") ? uc($c) : $c;
 216             my $new;
 217             my $count = $2 + 1;
 218             if ( $1 eq "m" ) {
 219                 $2+1 != $m            and $new = "m$count";
 220                 $2+1 == $m && $n == 0 and $new = "m0";
 221                 $2+1 == $m && $n != 0 and $new = "n0";
 222             } else {
 223                 $2+1 != $n            and $new = "n$count";
 224                 $2+1 == $n && $m == 0 and $new = "n0";
 225                 $2+1 == $n && $m != 0 and $new = "m0";
 226             }
 227             $self->{_case_mix} = $new;
 228         }
 229         $target = $what;
 230     } else {
 231         # Put extra space at random.
 232         $target =~ s/(.)/rand(100)<$self->{case_mixer}?uc($1):$1/eg;
 233     }
 234     return $target;
 235 }
 236
 237 # Add whole sentences randomly.
 238 sub _apply_extra_sent {
 239     my $self = shift;
 240     if ( rand(100) < $self->{extra_sent} ) {
 241         return $sentences[rand( @sentences ) ];
 242     }
 243     return undef;
 244 }
 245
 246 # Transform o to 0, l to 1, etc. That's 31337!
 247 sub _apply_letters {
 248     my ($self, $target) = @_;
 249
 250     return join "", map { rand(100) < $self->{letters} && exists $letter{$_} ?
 251                               ( ref($letter{$_}) eq ref([]) ) ?
 252                                   $letter{$_}[rand( @{$letter{$_}} ) ] :
 253                                       $letter{$_}
 254                           : $_ } split //, $target;
 255 }
 256
 257 # Put extra space between chars.
 258 sub _apply_spacer {
 259     my ($self, $target) = @_;
 260
 261     if ( $self->{spacer} =~ m!^(\d+)/(\d+)$! ) {
 262         # Fixed pattern.
 263         my $what = "";
 264         my ($m, $n) = ( $1, $2 );
 265         for my $c (split //, $target) {
 266             $self->{_space} =~ m/^([mn])(\d+)$/;
 267             $what .= ($1 eq "m") ? "$c " : $c;
 268             my $new;
 269             my $count = $2 + 1;
 270             if ( $1 eq "m" ) {
 271                 $2+1 != $m            and $new = "m$count";
 272                 $2+1 == $m && $n == 0 and $new = "m0";
 273                 $2+1 == $m && $n != 0 and $new = "n0";
 274             } else {
 275                 $2+1 != $n            and $new = "n$count";
 276                 $2+1 == $n && $m == 0 and $new = "n0";
 277                 $2+1 == $n && $m != 0 and $new = "m0";
 278             }
 279             $self->{_space} = $new;
 280         }
 281         $target = $what;
 282     } else {
 283         # Put extra space at random.
 284         $target =~ s/(.)/rand(100)<$self->{spacer}?"$1 ":$1/eg;
 285     }
 286     return $target;
 287 }
 288
 289 # Transform words according to %words.
 290 sub _apply_words {
 291     my ($self, $target) = @_;
 292     my @what = ();
 293     for my $word ( split / /, $target ) {
 294         if ( exists( $words{$word} ) ) {
 295             my $subst = $words{$word};
 296             $word = ref($subst) eq ref([]) ?
 297                 $subst->[ rand( int(@$subst) ) ]
 298               : $subst;
 299         }
 300         push @what, $word;
 301     }
 302     return join " ", @what;
 303 }
 304
 305 # Main entry point for string transformation.
 306 sub _transform {
 307     my ($self, $line) = @_;
 308
 309     $line or return; # Case undef.
 310     my $sentence;
 311     my @what = split "([.?!\n])", lc $line;
 312     while ( my ($what, $punc) = splice @what, 0, 2 ) {
 313         # Build the sentence.
 314         $self->{add_before} and $what = $self->_apply_add_before($what);
 315         $self->{add_after}  and $what = $self->_apply_add_after($what);
 316
 317         defined($punc) and $what .= $punc;
 318
 319         my $extra = $self->_apply_extra_sent();
 320         $extra and $what .= " $extra";
 321
 322         # Transform chars.
 323         foreach my $plugin ( qw( words spacer letters case_mixer ) ) {
 324             my $meth = "_apply_$plugin";
 325             $self->{$plugin} and $what = $self->$meth($what);
 326         }
 327         $sentence .= $what;
 328     }
 329     return $sentence;
 330 }
 331
 332 # By default, tie standard filedescriptors.
 333 # tie *STDOUT, __PACKAGE__, *STDOUT;
 334 # tie *STDERR, __PACKAGE__, *STDERR;
 335
 336
 337 1;
 338 __END__
 339
 340 =head1 NAME
 341
 342 Acme::Tie::Eleet - Perl extension to 5pE4k 1Ik3 4n 3l337!
 343
 344
 345 =head1 SYNOPSIS
 346
 347 B<!!!See the BUGS section below!!!>
 348
 349   use Acme::Tie::Eleet;
 350   print "This is eleet!\n";
 351
 352   tie *OUT, 'Acme::Tie::Eleet', *OUT, case_mixer => "1/1";
 353   print OUT "This is eleet\n";
 354
 355   Or, even, to translate instant sentences:
 356   perl -MAcme::Tie::Eleet -p -e ''
 357
 358   tie $bar, 'Acme::Tie::Eleet', spacer => 0;
 359   $bar = "eleet";
 360   $foo = $bar;
 361
 362
 363 =head1 DESCRIPTION
 364
 365 Have you ever wanted to speak like an eleet? Do you feel like it's too
 366 difficult to do your case mixin' manually? Tired of being laugh at by
 367 your mates because your quotes don't make you look like an h4x0r?
 368 Well, there's a solution, and you're reading the documentation of the
 369 module specially made for u, Ye4h M4n!
 370
 371 This module basically allows you to perform a tie on filehandles,
 372 converting text written to it; or a tie on scalars, converting text
 373 they holds.
 374
 375 And since it's quite difficult to do urself a tie, the module will
 376 also tie the 2 (no, not the letter 'S', the figure, u b4st4rd)
 377 standard output file descriptors perl comes with (aka, STDOUT and
 378 STDERR). A simple use of the module and you're ready to go! Fe4R u5!
 379
 380 =head2 Parameters supported by tie (both TIEHANDLE and TIESCALAR)
 381
 382 =over 4
 383
 384 =item o letters    => <percentage>
 385
 386 The parameter allow you to transform letters to corresponding number
 387 (ie, transform l to 1, e to 3, etc.) with a given percentage. Default
 388 is 25 (1 char out of 4 being translitterate - if possible). That's 31337!
 389
 390 =item o spacer     => <percentage>|<pattern>
 391
 392 Add extra spaces between chars. You can tell it to add random spaces
 393 with a given percentage. Eg, 'spacer => 50' will add about 1 space
 394 every two chars, whereas 'spacer => 0' will add no extra spaces. Or
 395 you can provide a pattern of the form "m/n" which will be understood
 396 as 'add an extra space after each of the m next chars, then do not add
 397 extra space after the n next chars'. For example, 'spacer => "1/1"'
 398 will add an extra space after one char out of two, whereas 'spacer =>
 399 "1/0" will add extra spaces after each char. Default is 0 (no extra
 400 space). T h a t   r o c k s !
 401
 402 =item o case_mixer => <percentage>|<pattern>
 403
 404 Put some chars into uppercase. You can tell it to convert random chars
 405 with a given percentage. Eg, 'case_mixer => 50' will convert a mean of
 406 1 char every two chars, whereas 'case_mixer => 100' will convert every
 407 character. Or you can provide a pattern of the form "m/n" which will
 408 be understood as 'uppercase m chars, then do not uppercase the n next
 409 chars'. For example, 'case_mixer => "2/1"' will convert two chars,
 410 then left one char unchanged; whereas 'case_mixer => "0/1"' won't
 411 convert any chars. Default is 50 (random 1 out of 2). CaSE mIxIng
 412 RUleZ!
 413
 414 =item o words      => <true>|<false>
 415
 416 Transform words given a dictionnary. For exampe, transform 'hacker' to
 417 'haxor', and so on... Either true or false, default to false. Kewl stuff!
 418
 419 =item o add_before => <percentage>
 420
 421 Add some preamble randomly with a given percentage. For example, it
 422 could transform "this is my sentence." to "Yeah man, this is my
 423 sentence.". Default to 15.
 424
 425 =item o add_after  => <percentage>
 426
 427 Terminate a sentence randomly with an hacker expression according to a
 428 given percentage. For example, it could transform "this is my
 429 sentence." to "this is my sentence, fear us.". Default to 15.
 430
 431 =item o extra_sent => <percentage>
 432
 433 Add randomly whole sentences to the filehandle. If filehandle is read
 434 from, it won't return the next chunk of text, but rather a leave it
 435 where it stands and return a sentence of its own. Default to 10. All
 436 your base are belong to us!
 437
 438 =back
 439
 440
 441 =head1 BUGS
 442
 443 B</!\ WARNING>: as of Perl 5.8.0, TIEHANDLE seems to be B<broken>. So,
 444 I decided to remove ties on STDOUT and STDERR, and commented the
 445 relevant parts in the test suite.
 446
 447 Don't try to tie a filehandle if you're running a Perl version greater
 448 or equal to 5.8.0, because you will start a I<deep recursion loop> as
 449 says Perl... I'll try to fix it when I'll find some time.
 450
 451
 452 =head1 TODO
 453
 454 =over 4
 455
 456 =item o
 457
 458 Find more h4x0R quotes to add.
 459
 460 =item o
 461
 462 Allow user to provide a dictionnary for words. Backward compatibility
 463 would be ok since a ref to a hash evaluates to true.
 464
 465 =item o
 466
 467 Allow user to provide a hash of quotes for both add_before /
 468 add_after. Backward compatibility would be ok since a ref to a hash
 469 evaluates to true.
 470
 471 =item o
 472
 473 Allow user to provide an array of quotes to add. Backward
 474 compatibility would be ok since a ref to a hash evaluates to true.
 475
 476 =item o
 477
 478 Allow tie-ing for input filehandle.
 479
 480 =back
 481
 482
 483 =head1 AUTHOR
 484
 485 Jerome Quelin, E<lt>jquelin@cpan.orgE<gt>
 486
 487
 488 =head1 SEE ALSO
 489
 490 L<perl>, the L<news://alt.2600> newsgroup, L<http://www.google.com/intl/xx-hacker/>.
 491
 492 =cut