File Coverage

blib/lib/Catalyst/Plugin/Acme/Scramble.pm

Criterion	Covered	Total	%
statement	3	32	9.3
branch	0	14	0.0
condition	0	11	0.0
subroutine	1	5	20.0
pod	0	2	0.0
total	4	64	6.2

package Catalyst::Plugin::Acme::Scramble;

use strict;

=head1 NAME

Catalyst::Plugin::Acme::Scramble - tset the budnos of lieibiglty and dstraneotme how we pcvreiee wdors wtih yuor Ctyslaat apicapltion

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

=head1 SYNOPSIS

 use Catalyst qw/
                 Your::Regular::Plugins
                 Acme::Scramble
                /;

 # And observe the corrected output of your application

Implements a potent meme about how easily we can read scrambled text
if the first and last letters remain constant. Operates on text/plain
and text/html served by your Catalyst application.

=cut

my $skip = qr/script|style|map|area/;

sub finalize {
    my $c = shift;

    return $c->NEXT::finalize unless $c->response->body
        and
        $c->response->content_type =~ m,^text/(plain|html),;

    if ( $1 eq 'plain' )
    {
        _scramble_block( \$c->response->{body} );
    }
    else
    {
        require HTML::TokeParser;
        my $p = HTML::TokeParser->new( \$c->response->{body} );
        my $repaired = '';
        my @queue;

        while ( my $t = $p->get_token() )
        {
            push @queue, $t->[1] if $t->[0] eq 'S'; # assumes well-formed
            pop @queue if $t->[0] eq 'E';
            if (
                 $t->[0] eq 'T'
                 and
                 not $t->[2]
                 and
                 not grep /$skip/, @queue )
            {
                my $txt = $t->[1];
                _scramble_block(\$txt);
                $repaired .= $txt;
            }
            else
            {
                $repaired .= ( $t->[0] eq 'T' ) ? $t->[1] : $t->[-1];
            }
        }
        $c->response->{body} = $repaired;
    }

    $c->NEXT::finalize;
}

sub _scramble_block {
    my $text = shift;

    ${$text} =~ s{
                                    ( (?:(?<=[^[:alpha:]])|(?<=\A))
                                        (?<!&)(?-x)(?<!&#)(?x)
                                        (?:
                                              ['[:alpha:]]+ | (?<!-)-(?!-)
                                          )+
                                        (?=[^[:alpha:]]|\z)
                                      )
                                    }
                                  {_scramble_word($1)}gex;
}

sub _scramble_word {
    my $word = shift || return '';
    my @piece = split //, $word;
    shuffle(@piece[1..$#piece-1])
        if @piece > 2;
    join('', @piece);
}

sub shuffle {
    for ( my $i = @_; --$i; ) {
        my $j = int(rand($i+1));
        @_[$i,$j] = @_[$j,$i];
    }
}

=head1 AUTHOR

Ashley Pond V, ashley at cpan.org.

=head1 BUGS

I love bugs! Hymenoptera, dictyoptera, coleoptera, all of them.

Expects valid nesting. May sometimes interfere with tags that should
be literal, like E<lt>scriptE<gt> and E<lt>styleE<gt>, when it's not
present.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Catalyst::Plugin::Acme::Scramble

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Catalyst-Plugin-Acme-Scramble>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Catalyst-Plugin-Acme-Scramble>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Plugin-Acme-Scramble>

=item * Search CPAN

L<http://search.cpan.org/dist/Catalyst-Plugin-Acme-Scramble>

=back

=head1 TODO

Support application/xhtml+xml? If it's served that way, or even as any
XML, we could use an XML parser and just scramble the #text parts.

=head1 SEE ALSO

L<Catalyst>, L<Catalyst::Runtime>.

=head1 COPYRIGHT & LICENSE

Copyright 2006 Ashley Pond V, all rights reserved.

This program is free software; you can redistribute it and modify it
under the same terms as Perl itself.

=cut

1; # End of Catalyst::Plugin::Acme::Scramble