File Coverage

blib/lib/Text/Bastardize.pm

Criterion	Covered	Total	%
statement	118	122	96.7
branch	20	28	71.4
condition	4	6	66.6
subroutine	13	13	100.0
pod	11	11	100.0
total	166	180	92.2

## -*- Cperl -*-
package Text::Bastardize;
$VERSION = 0.08;
use strict;
use warnings;

# ----------------------------------------------------------------------
# Copyright (C) 1999-2006 Julian Fondren
# Licensed as with perl itself.
# ----------------------------------------------------------------------

sub new {
  my $proto = shift;
  my $class = ref($proto) || $proto;
  my $self = [];
  bless($self, $class)
}

sub peek { @{+shift} }
sub charge {
  my $self = shift;
  @{$self} = @_;
  $self
}

sub disemvowel {
  my @d = shift->peek;
  s/\B[aeiou]\B//ig for @d;
  @d
}

sub rot13 {
  my $self = shift;
  map { tr/a-zA-Z/n-za-mN-ZA-M/; $_ } $self->peek
}

sub k3wlt0k {
  # a slightly modified version of Fmh's t0k.pl
  my $self = shift;
  my @k = $self->peek;
  for (@k) {
    y/A-Z/a-z/;
    s/\bth/d/sg;
    s/ck\b/x0r/sg;
    s/cking\b/x0ring/sg;
    s/cked\b/x0red/sg;
    s/cker/x0r/sg;
    s/or/er/sg;
    s/ing/in/sg;
    s/cause/cus/sg;
    s/fu/f00/sg;
    s/word/werd/sg;
    s/oo/ew/sg;
    s/for/4/sg;
    s/ate/8/sg;
    y/uaes itz clo/v34z 17s s10/;
    s/\'//sg;
    s/\./.../sg;
    s/!/!!!/sg;
    s/\?/???/sg;
    s/\bc/k/sg;
    s/00/o0/sg;
    s/0rk/r0k/sg;
    s/y0v/j00/sg;
    s/[ck]o01/k3wl/sg;
    s/741k/t0k/sg;
    s/j00\B/j3r/sg;
    s/3z/z3/sg;
    s/3r/ur/sg;
    y/a-z/A-Z/;
  }
  @k
}

sub rdct {
  my $self = shift;
  my @r = $self->peek;
  for (@r) {
    y/A-Z/a-z/;
    y/!#.,?\'\";//;
    s/of/uv/sg;
    s/one/1/sg;
    s/\b(?:a|e)//sg;
    s/a?n?ks/x/sg;
    s/you/u/sg;
    s/are/r/sg;
    s/youre?/ur/sg;
    s/\B(?:a|e|i|o|u)\B//sg;
  }
  @r
}

# 7Oct2006: I don't care about this right now;
# presumably it works.  Will look it over for the
# next release.
sub pig {
  my $self = shift;
  my @pig;         # what is to be returned, the final result
  my @piggie;      # a word-by-word splitting of each element
  my $allupper;
  my $firstupper;
  my $i = 0;
  for my $v ($self->peek()) {   # by line
    @piggie = split(/ /, $v);
    for my $w (@piggie) {       # by word
      "\U$w" eq $w ? $allupper = 1 : $allupper = 0;

      # append "way" if word starts with an un'y' vowel
      if (substr($w, 0, 1) =~ /a|e|i|o|u/i) {
        $allupper ? $w .= "WAY" : $w .= "way";
      }
      "\u\L$w" eq $w ? $firstupper = 1 : $firstupper = 0;
      $w =lc $w unless $allupper;

      # copy leading consonants to the end of the word,
      # not counting "qu"
      until (substr($w, 0, 1) =~ /a|e|i|o|u|y/i) {
        unless (substr($w, 0, 2) eq "qu") {
          $w = join '', reverse unpack ('aa*', $w);
        }
      }
      $w .= "ay" unless substr($w,-2,2) eq "ay";

      # sickness.
      if ($w =~ /[.!?,%]/s) {
        $w =~ s/([,.!?])//s;
        $w .= $1 if $1;
      }
      if ($w =~ /[\$]/s) {
        $w =~ s/([\$])//s;
        $w .= $1 if $1;
      }

      $w = ucfirst $w if $firstupper;
      $piggie[$i++] = $w;
    }
    push(@pig, join(' ', @piggie));
  }
  return @pig;
}

sub rev {
  my $self = shift;
  map { scalar reverse $_ } $self->peek;
}

sub censor {
  my $self = shift;
  my @censor;
 LINE: foreach my $l ($self->peek()) {
    my @w;
  WORD: foreach my $w (split / /, $l) {
      $w =~ y/aeiouAEIOU/**********/
        unless (length $w > 10  or  length $w < 4);
      push @w, $w;
    }
    push @censor, (join ' ', @w);
  }
  @censor;
}

sub n20e {
  # numerical_abbreviation
  my $self = shift;
  my @n20e;
 LINE: foreach my $l ($self->peek()) {
    my @w;
  WORD: foreach my $w (split / /, $l) {
      my $chars = length $w;
      if ($chars <= 6) {
        push @w, $w;
        next WORD;
      }
      my @chars = (substr($w, 0, 1), substr($w, -1, 1));
      push @w, ($chars[0] . ($chars - 2) . $chars[1]);
    }
    push @n20e, (join ' ', @w);
  }
  @n20e;
}

1;

__END__