HTML-Truncate-0.20/0000755000076500000240000000000011226750572014064 5ustar jinxstaff00000000000000HTML-Truncate-0.20/Changes0000644000076500000240000001471611226750560015365 0ustar jinxstaff00000000000000Revision history for HTML-Truncate 0.20 20090713 - Normalized test names to hyphen from underscore. - Patch from the omnipresent t0m to fix TT2 recipe. 0.19 20090512 - Fixed Pod typos. 0.18 20090509 - Fixed broken README. 0.17 20090509 - Really been a year...? - Typo in Pod. - Autogenerate README. - Bug in Pod showing utf8 => 1 setting. - Fixed bad optimization in filter recipe. - Fixed char counting problem I discovered while testing. - Fixed standalone tag -- e.g., br -- close bug with repair. - Might have made visual spacing counting more robust. 0.16 20080529 - Updated Pod a bit. 0.15 20080529 - Was considering trying to work around 5.6's utf8 issues but it's not in the cards right now and I'd rather have a module passing all its tests so, 5.8 or better required now. Leaving skips in truncate_html.t in case I ever do it. 0.14 20080529 - Put in skips for tests involving utf8_mode and perl less than 5.8. - Put Encode into test reqs and put File::Spec version. 0.13 20080529 - Fixed my build to remove META.yml, 0.12 had the file from 0.11. - Reorganized tests with /xt; pod-coverage, perlcritic, etc. - Cleaned up Pod. - Put license in Makefile explicitly. 0.12 20080528 - Discoered it didn't work nearly as well (regarding counting of "visible" output as I thought so I rewrote it. Three times actually but ended up with something similar to the original in the end, mostly because, bizarrely, HTML::TreeBuilder does not make text into nodes. This makes the module half useless. If it only did that, it would simple to have redone this module with it in a bombproof way. I considered redoing it with XML::LibXML to achieve the same thing and might add that in eventually with an "eval require" kind of check. - Added some accounting for 
 tags to be taken literally.
        - Lorenzo Iannuzzi suggested a way to clip to word-ish
          boundaries instead of truncating leaving hanging space. I
          already do something similar in TT2 so I kept his as
          on_space() and mine as cleanly(), which can accept a regex
          if you know how you want to handle it better than the
          default.
        - Took out style setting, it was pointless, goofy, and
          antithetical to the point of the module.
        - Was going to take out "beta" notice - but rewrote too much
          of it to do so.
        - Moved to Module::Install.
        - Noticed the utf8 ellipsis is tripping up perl 5.6. But I
          don't want to put a prereq in... maybe skip that test for
          that version.
        - Several new tests.
        - Pod clean up, mild reorg.

0.11    200607
        - kevinr: Added the 'repair' option, allowing you to tell
          HTML::Truncate to close unmatched open tags and discard
          unmatched close tags, with Pod and tests.
        - Added HTML::Tagset to prereqs; it's not used directly but
          caused an error on my clean perl install.
        - Fixed a couple of Pod spelling errors and typos.

0.10    20060304 1750
        - Updated "alpha" --> "beta" in README.
        - Removed .cvsignore from MANIFEST and put in MANIFEST.skip.
        - Added TT recipe to Pod.

0.09    20060304 1247
        - Ryo Okamoto reported two bugs (object needs its renewed text
          reset per truncate call and pointed out that the chars vs
          percent wasn't clear enough or bomb-proof). Also suggested
          different behavior for dropping trailing tags if they've
          lost their content (i.e., dropping the \Z instead of
          doing ...).
        - So calls to chars() now clears the percent() and vice versa.
        - New test file "countdown" from Ryo Okamoto added.
        - Pod updates to reflect changes.
        - Took out defined check on chars. Zero should not be allowed.
        - Added an "if" clause to the length padding check.
        - Returning undef if percent() is called when it's unset and
          not being set.

0.08    20060228 1622
        - Fixed year in Change entry below (from 2003).
        - Fixed percent to not allow a 0%.
        - Fixed percent bug -- if it was loaded up front instead of in
          the truncate() call, it was being silently dropped for the
          default 100 chars.
        - Made test path agnostic with File::Spec. Added to build
          prereqs.
        - Fixed bug with default percent being English instead of
          decimal; shouldn't be there at all.
        - Calling it beta now that the known bugs are out; couple
          other Pod tweaks.

0.07    20060228 1130
        - Added embed to skip tags.

0.06    20060101 0152
        - Moved the 'ellipsis' to the end of the close tags; it's a
          compromise but t'is for the best.
        - And moved it back out. Bad compromise. Needs to have a tree
          logic to decide if it should go inside the last block level
          tag or not at all.
        - Added  to stand alone tags.
        - Put in a more helpful " closed by  near 'LAST
          15 CHARS IN WHAT'S BEEN CLEANED'" for the malformed croak().
        - Snip trailing whitespace off cleaned text; gets "This..."
          instead of "That ..."

0.05    20051228 0050
        - No surface changes.
        - Added 'object' to default skip tags.
        - _count_visual_chars.
        - Put in a few points of attention for installing callbacks
          over skip tags and a dummy sub{} for img tags.

0.04    20051222
        - Couple Pod typos/sync-problems fixed.
        - Another Pod typo in Synopsis fixed per Terrence Brannon.
        - Added synopsis.t to avoid the same type of problem creeping back.
        
0.03    20051222 1532
        - Added dont_skip_tags and add_skip_tags (not in tests yet).
        - Built out Pod a bit more.
        - Corrected a couple typos below in this document.

0.02    20051222 1325
        - Took out the non-functional functional part at the sober
          suggestion of Mark Stosberg.
        - Built up Pod a bit; note about XHTML-esque input requirement.
        - Moved stand alone and skip tags into object.

0.01    20051222 0114
        - Alpha release; missing functionality, documentation, and tests.
        - Basic OO interface seems to be working correctly.

HTML-Truncate-0.20/inc/0000755000076500000240000000000011226750572014635 5ustar  jinxstaff00000000000000HTML-Truncate-0.20/inc/Module/0000755000076500000240000000000011226750572016062 5ustar  jinxstaff00000000000000HTML-Truncate-0.20/inc/Module/AutoInstall.pm0000644000076500000240000005330611226750564020667 0ustar  jinxstaff00000000000000#line 1
package Module::AutoInstall;

use strict;
use Cwd                 ();
use ExtUtils::MakeMaker ();

use vars qw{$VERSION};
BEGIN {
	$VERSION = '1.03';
}

# special map on pre-defined feature sets
my %FeatureMap = (
    ''      => 'Core Features',    # XXX: deprecated
    '-core' => 'Core Features',
);

# various lexical flags
my ( @Missing, @Existing,  %DisabledTests, $UnderCPAN,     $HasCPANPLUS );
my (
    $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps
);
my ( $PostambleActions, $PostambleUsed );

# See if it's a testing or non-interactive session
_accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN ); 
_init();

sub _accept_default {
    $AcceptDefault = shift;
}

sub missing_modules {
    return @Missing;
}

sub do_install {
    __PACKAGE__->install(
        [
            $Config
            ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
            : ()
        ],
        @Missing,
    );
}

# initialize various flags, and/or perform install
sub _init {
    foreach my $arg (
        @ARGV,
        split(
            /[\s\t]+/,
            $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
        )
      )
    {
        if ( $arg =~ /^--config=(.*)$/ ) {
            $Config = [ split( ',', $1 ) ];
        }
        elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
            __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
            exit 0;
        }
        elsif ( $arg =~ /^--default(?:deps)?$/ ) {
            $AcceptDefault = 1;
        }
        elsif ( $arg =~ /^--check(?:deps)?$/ ) {
            $CheckOnly = 1;
        }
        elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
            $SkipInstall = 1;
        }
        elsif ( $arg =~ /^--test(?:only)?$/ ) {
            $TestOnly = 1;
        }
        elsif ( $arg =~ /^--all(?:deps)?$/ ) {
            $AllDeps = 1;
        }
    }
}

# overrides MakeMaker's prompt() to automatically accept the default choice
sub _prompt {
    goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;

    my ( $prompt, $default ) = @_;
    my $y = ( $default =~ /^[Yy]/ );

    print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
    print "$default\n";
    return $default;
}

# the workhorse
sub import {
    my $class = shift;
    my @args  = @_ or return;
    my $core_all;

    print "*** $class version " . $class->VERSION . "\n";
    print "*** Checking for Perl dependencies...\n";

    my $cwd = Cwd::cwd();

    $Config = [];

    my $maxlen = length(
        (
            sort   { length($b) <=> length($a) }
              grep { /^[^\-]/ }
              map  {
                ref($_)
                  ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
                  : ''
              }
              map { +{@args}->{$_} }
              grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
        )[0]
    );

    # We want to know if we're under CPAN early to avoid prompting, but
    # if we aren't going to try and install anything anyway then skip the
    # check entirely since we don't want to have to load (and configure)
    # an old CPAN just for a cosmetic message

    $UnderCPAN = _check_lock(1) unless $SkipInstall;

    while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
        my ( @required, @tests, @skiptests );
        my $default  = 1;
        my $conflict = 0;

        if ( $feature =~ m/^-(\w+)$/ ) {
            my $option = lc($1);

            # check for a newer version of myself
            _update_to( $modules, @_ ) and return if $option eq 'version';

            # sets CPAN configuration options
            $Config = $modules if $option eq 'config';

            # promote every features to core status
            $core_all = ( $modules =~ /^all$/i ) and next
              if $option eq 'core';

            next unless $option eq 'core';
        }

        print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";

        $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );

        unshift @$modules, -default => &{ shift(@$modules) }
          if ( ref( $modules->[0] ) eq 'CODE' );    # XXX: bugward combatability

        while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
            if ( $mod =~ m/^-(\w+)$/ ) {
                my $option = lc($1);

                $default   = $arg    if ( $option eq 'default' );
                $conflict  = $arg    if ( $option eq 'conflict' );
                @tests     = @{$arg} if ( $option eq 'tests' );
                @skiptests = @{$arg} if ( $option eq 'skiptests' );

                next;
            }

            printf( "- %-${maxlen}s ...", $mod );

            if ( $arg and $arg =~ /^\D/ ) {
                unshift @$modules, $arg;
                $arg = 0;
            }

            # XXX: check for conflicts and uninstalls(!) them.
            my $cur = _load($mod);
            if (_version_cmp ($cur, $arg) >= 0)
            {
                print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
                push @Existing, $mod => $arg;
                $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
            }
            else {
                if (not defined $cur)   # indeed missing
                {
                    print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
                }
                else
                {
                    # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
                    print "too old. ($cur < $arg)\n";
                }

                push @required, $mod => $arg;
            }
        }

        next unless @required;

        my $mandatory = ( $feature eq '-core' or $core_all );

        if (
            !$SkipInstall
            and (
                $CheckOnly
                or ($mandatory and $UnderCPAN)
                or $AllDeps
                or _prompt(
                    qq{==> Auto-install the }
                      . ( @required / 2 )
                      . ( $mandatory ? ' mandatory' : ' optional' )
                      . qq{ module(s) from CPAN?},
                    $default ? 'y' : 'n',
                ) =~ /^[Yy]/
            )
          )
        {
            push( @Missing, @required );
            $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
        }

        elsif ( !$SkipInstall
            and $default
            and $mandatory
            and
            _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
            =~ /^[Nn]/ )
        {
            push( @Missing, @required );
            $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
        }

        else {
            $DisabledTests{$_} = 1 for map { glob($_) } @tests;
        }
    }

    if ( @Missing and not( $CheckOnly or $UnderCPAN ) ) {
        require Config;
        print
"*** Dependencies will be installed the next time you type '$Config::Config{make}'.\n";

        # make an educated guess of whether we'll need root permission.
        print "    (You may need to do that as the 'root' user.)\n"
          if eval '$>';
    }
    print "*** $class configuration finished.\n";

    chdir $cwd;

    # import to main::
    no strict 'refs';
    *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
}

sub _running_under {
    my $thing = shift;
    print <<"END_MESSAGE";
*** Since we're running under ${thing}, I'll just let it take care
    of the dependency's installation later.
END_MESSAGE
    return 1;
}

# Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
# if we are, then we simply let it taking care of our dependencies
sub _check_lock {
    return unless @Missing or @_;

    my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};

    if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
        return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
    }

    require CPAN;

    if ($CPAN::VERSION > '1.89') {
        if ($cpan_env) {
            return _running_under('CPAN');
        }
        return; # CPAN.pm new enough, don't need to check further
    }

    # last ditch attempt, this -will- configure CPAN, very sorry

    _load_cpan(1); # force initialize even though it's already loaded

    # Find the CPAN lock-file
    my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
    return unless -f $lock;

    # Check the lock
    local *LOCK;
    return unless open(LOCK, $lock);

    if (
            ( $^O eq 'MSWin32' ? _under_cpan() :  == getppid() )
        and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
    ) {
        print <<'END_MESSAGE';

*** Since we're running under CPAN, I'll just let it take care
    of the dependency's installation later.
END_MESSAGE
        return 1;
    }

    close LOCK;
    return;
}

sub install {
    my $class = shift;

    my $i;    # used below to strip leading '-' from config keys
    my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );

    my ( @modules, @installed );
    while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {

        # grep out those already installed
        if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
            push @installed, $pkg;
        }
        else {
            push @modules, $pkg, $ver;
        }
    }

    return @installed unless @modules;  # nothing to do
    return @installed if _check_lock(); # defer to the CPAN shell

    print "*** Installing dependencies...\n";

    return unless _connected_to('cpan.org');

    my %args = @config;
    my %failed;
    local *FAILED;
    if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
        while () { chomp; $failed{$_}++ }
        close FAILED;

        my @newmod;
        while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
            push @newmod, ( $k => $v ) unless $failed{$k};
        }
        @modules = @newmod;
    }

    if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) {
        _install_cpanplus( \@modules, \@config );
    } else {
        _install_cpan( \@modules, \@config );
    }

    print "*** $class installation finished.\n";

    # see if we have successfully installed them
    while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
        if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
            push @installed, $pkg;
        }
        elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
            print FAILED "$pkg\n";
        }
    }

    close FAILED if $args{do_once};

    return @installed;
}

sub _install_cpanplus {
    my @modules   = @{ +shift };
    my @config    = _cpanplus_config( @{ +shift } );
    my $installed = 0;

    require CPANPLUS::Backend;
    my $cp   = CPANPLUS::Backend->new;
    my $conf = $cp->configure_object;

    return unless $conf->can('conf') # 0.05x+ with "sudo" support
               or _can_write($conf->_get_build('base'));  # 0.04x

    # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
    my $makeflags = $conf->get_conf('makeflags') || '';
    if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
        # 0.03+ uses a hashref here
        $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};

    } else {
        # 0.02 and below uses a scalar
        $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
          if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );

    }
    $conf->set_conf( makeflags => $makeflags );
    $conf->set_conf( prereqs   => 1 );

    

    while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
        $conf->set_conf( $key, $val );
    }

    my $modtree = $cp->module_tree;
    while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
        print "*** Installing $pkg...\n";

        MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;

        my $success;
        my $obj = $modtree->{$pkg};

        if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
            my $pathname = $pkg;
            $pathname =~ s/::/\\W/;

            foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
                delete $INC{$inc};
            }

            my $rv = $cp->install( modules => [ $obj->{module} ] );

            if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
                print "*** $pkg successfully installed.\n";
                $success = 1;
            } else {
                print "*** $pkg installation cancelled.\n";
                $success = 0;
            }

            $installed += $success;
        } else {
            print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
        }

        MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
    }

    return $installed;
}

sub _cpanplus_config {
	my @config = ();
	while ( @_ ) {
		my ($key, $value) = (shift(), shift());
		if ( $key eq 'prerequisites_policy' ) {
			if ( $value eq 'follow' ) {
				$value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
			} elsif ( $value eq 'ask' ) {
				$value = CPANPLUS::Internals::Constants::PREREQ_ASK();
			} elsif ( $value eq 'ignore' ) {
				$value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
			} else {
				die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
			}
		} else {
			die "*** Cannot convert option $key to CPANPLUS version.\n";
		}
	}
	return @config;
}

sub _install_cpan {
    my @modules   = @{ +shift };
    my @config    = @{ +shift };
    my $installed = 0;
    my %args;

    _load_cpan();
    require Config;

    if (CPAN->VERSION < 1.80) {
        # no "sudo" support, probe for writableness
        return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
                  and _can_write( $Config::Config{sitelib} );
    }

    # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
    my $makeflags = $CPAN::Config->{make_install_arg} || '';
    $CPAN::Config->{make_install_arg} =
      join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
      if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );

    # don't show start-up info
    $CPAN::Config->{inhibit_startup_message} = 1;

    # set additional options
    while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
        ( $args{$opt} = $arg, next )
          if $opt =~ /^force$/;    # pseudo-option
        $CPAN::Config->{$opt} = $arg;
    }

    local $CPAN::Config->{prerequisites_policy} = 'follow';

    while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
        MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;

        print "*** Installing $pkg...\n";

        my $obj     = CPAN::Shell->expand( Module => $pkg );
        my $success = 0;

        if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
            my $pathname = $pkg;
            $pathname =~ s/::/\\W/;

            foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
                delete $INC{$inc};
            }

            my $rv = $args{force} ? CPAN::Shell->force( install => $pkg )
                                  : CPAN::Shell->install($pkg);
            $rv ||= eval {
                $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
                  ->{install}
                  if $CPAN::META;
            };

            if ( $rv eq 'YES' ) {
                print "*** $pkg successfully installed.\n";
                $success = 1;
            }
            else {
                print "*** $pkg installation failed.\n";
                $success = 0;
            }

            $installed += $success;
        }
        else {
            print << ".";
*** Could not find a version $ver or above for $pkg; skipping.
.
        }

        MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
    }

    return $installed;
}

sub _has_cpanplus {
    return (
        $HasCPANPLUS = (
            $INC{'CPANPLUS/Config.pm'}
              or _load('CPANPLUS::Shell::Default')
        )
    );
}

# make guesses on whether we're under the CPAN installation directory
sub _under_cpan {
    require Cwd;
    require File::Spec;

    my $cwd  = File::Spec->canonpath( Cwd::cwd() );
    my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );

    return ( index( $cwd, $cpan ) > -1 );
}

sub _update_to {
    my $class = __PACKAGE__;
    my $ver   = shift;

    return
      if _version_cmp( _load($class), $ver ) >= 0;  # no need to upgrade

    if (
        _prompt( "==> A newer version of $class ($ver) is required. Install?",
            'y' ) =~ /^[Nn]/
      )
    {
        die "*** Please install $class $ver manually.\n";
    }

    print << ".";
*** Trying to fetch it from CPAN...
.

    # install ourselves
    _load($class) and return $class->import(@_)
      if $class->install( [], $class, $ver );

    print << '.'; exit 1;

*** Cannot bootstrap myself. :-( Installation terminated.
.
}

# check if we're connected to some host, using inet_aton
sub _connected_to {
    my $site = shift;

    return (
        ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
            qq(
*** Your host cannot resolve the domain name '$site', which
    probably means the Internet connections are unavailable.
==> Should we try to install the required module(s) anyway?), 'n'
          ) =~ /^[Yy]/
    );
}

# check if a directory is writable; may create it on demand
sub _can_write {
    my $path = shift;
    mkdir( $path, 0755 ) unless -e $path;

    return 1 if -w $path;

    print << ".";
*** You are not allowed to write to the directory '$path';
    the installation may fail due to insufficient permissions.
.

    if (
        eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
            qq(
==> Should we try to re-execute the autoinstall process with 'sudo'?),
            ((-t STDIN) ? 'y' : 'n')
        ) =~ /^[Yy]/
      )
    {

        # try to bootstrap ourselves from sudo
        print << ".";
*** Trying to re-execute the autoinstall process with 'sudo'...
.
        my $missing = join( ',', @Missing );
        my $config = join( ',',
            UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
          if $Config;

        return
          unless system( 'sudo', $^X, $0, "--config=$config",
            "--installdeps=$missing" );

        print << ".";
*** The 'sudo' command exited with error!  Resuming...
.
    }

    return _prompt(
        qq(
==> Should we try to install the required module(s) anyway?), 'n'
    ) =~ /^[Yy]/;
}

# load a module and return the version it reports
sub _load {
    my $mod  = pop;    # class/instance doesn't matter
    my $file = $mod;

    $file =~ s|::|/|g;
    $file .= '.pm';

    local $@;
    return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
}

# Load CPAN.pm and it's configuration
sub _load_cpan {
    return if $CPAN::VERSION and $CPAN::Config and not @_;
    require CPAN;
    if ( $CPAN::HandleConfig::VERSION ) {
        # Newer versions of CPAN have a HandleConfig module
        CPAN::HandleConfig->load;
    } else {
    	# Older versions had the load method in Config directly
        CPAN::Config->load;
    }
}

# compare two versions, either use Sort::Versions or plain comparison
# return values same as <=>
sub _version_cmp {
    my ( $cur, $min ) = @_;
    return -1 unless defined $cur;  # if 0 keep comparing
    return 1 unless $min;

    $cur =~ s/\s+$//;

    # check for version numbers that are not in decimal format
    if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
        if ( ( $version::VERSION or defined( _load('version') )) and
             version->can('new') 
            ) {

            # use version.pm if it is installed.
            return version->new($cur) <=> version->new($min);
        }
        elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
        {

            # use Sort::Versions as the sorting algorithm for a.b.c versions
            return Sort::Versions::versioncmp( $cur, $min );
        }

        warn "Cannot reliably compare non-decimal formatted versions.\n"
          . "Please install version.pm or Sort::Versions.\n";
    }

    # plain comparison
    local $^W = 0;    # shuts off 'not numeric' bugs
    return $cur <=> $min;
}

# nothing; this usage is deprecated.
sub main::PREREQ_PM { return {}; }

sub _make_args {
    my %args = @_;

    $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
      if $UnderCPAN or $TestOnly;

    if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
        require ExtUtils::Manifest;
        my $manifest = ExtUtils::Manifest::maniread('MANIFEST');

        $args{EXE_FILES} =
          [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
    }

    $args{test}{TESTS} ||= 't/*.t';
    $args{test}{TESTS} = join( ' ',
        grep { !exists( $DisabledTests{$_} ) }
          map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );

    my $missing = join( ',', @Missing );
    my $config =
      join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
      if $Config;

    $PostambleActions = (
        ($missing and not $UnderCPAN)
        ? "\$(PERL) $0 --config=$config --installdeps=$missing"
        : "\$(NOECHO) \$(NOOP)"
    );

    return %args;
}

# a wrapper to ExtUtils::MakeMaker::WriteMakefile
sub Write {
    require Carp;
    Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;

    if ($CheckOnly) {
        print << ".";
*** Makefile not written in check-only mode.
.
        return;
    }

    my %args = _make_args(@_);

    no strict 'refs';

    $PostambleUsed = 0;
    local *MY::postamble = \&postamble unless defined &MY::postamble;
    ExtUtils::MakeMaker::WriteMakefile(%args);

    print << "." unless $PostambleUsed;
*** WARNING: Makefile written with customized MY::postamble() without
    including contents from Module::AutoInstall::postamble() --
    auto installation features disabled.  Please contact the author.
.

    return 1;
}

sub postamble {
    $PostambleUsed = 1;

    return <<"END_MAKE";

config :: installdeps
\t\$(NOECHO) \$(NOOP)

checkdeps ::
\t\$(PERL) $0 --checkdeps

installdeps ::
\t$PostambleActions

END_MAKE

}

1;

__END__

#line 1056
HTML-Truncate-0.20/inc/Module/Install/0000755000076500000240000000000011226750572017470 5ustar  jinxstaff00000000000000HTML-Truncate-0.20/inc/Module/Install/AutoInstall.pm0000644000076500000240000000227311226750564022272 0ustar  jinxstaff00000000000000#line 1
package Module::Install::AutoInstall;

use strict;
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';
	@ISA     = 'Module::Install::Base';
	$ISCORE  = 1;
}

sub AutoInstall { $_[0] }

sub run {
    my $self = shift;
    $self->auto_install_now(@_);
}

sub write {
    my $self = shift;
    $self->auto_install(@_);
}

sub auto_install {
    my $self = shift;
    return if $self->{done}++;

    # Flatten array of arrays into a single array
    my @core = map @$_, map @$_, grep ref,
               $self->build_requires, $self->requires;

    my @config = @_;

    # We'll need Module::AutoInstall
    $self->include('Module::AutoInstall');
    require Module::AutoInstall;

    Module::AutoInstall->import(
        (@config ? (-config => \@config) : ()),
        (@core   ? (-core   => \@core)   : ()),
        $self->features,
    );

    $self->makemaker_args( Module::AutoInstall::_make_args() );

    my $class = ref($self);
    $self->postamble(
        "# --- $class section:\n" .
        Module::AutoInstall::postamble()
    );
}

sub auto_install_now {
    my $self = shift;
    $self->auto_install(@_);
    Module::AutoInstall::do_install();
}

1;
HTML-Truncate-0.20/inc/Module/Install/Base.pm0000644000076500000240000000176611226750563020712 0ustar  jinxstaff00000000000000#line 1
package Module::Install::Base;

use strict 'vars';
use vars qw{$VERSION};
BEGIN {
	$VERSION = '0.91';
}

# Suspend handler for "redefined" warnings
BEGIN {
	my $w = $SIG{__WARN__};
	$SIG{__WARN__} = sub { $w };
}

#line 42

sub new {
	my $class = shift;
	unless ( defined &{"${class}::call"} ) {
		*{"${class}::call"} = sub { shift->_top->call(@_) };
	}
	unless ( defined &{"${class}::load"} ) {
		*{"${class}::load"} = sub { shift->_top->load(@_) };
	}
	bless { @_ }, $class;
}

#line 61

sub AUTOLOAD {
	local $@;
	my $func = eval { shift->_top->autoload } or return;
	goto &$func;
}

#line 75

sub _top {
	$_[0]->{_top};
}

#line 90

sub admin {
	$_[0]->_top->{admin}
	or
	Module::Install::Base::FakeAdmin->new;
}

#line 106

sub is_admin {
	$_[0]->admin->VERSION;
}

sub DESTROY {}

package Module::Install::Base::FakeAdmin;

my $fake;

sub new {
	$fake ||= bless(\@_, $_[0]);
}

sub AUTOLOAD {}

sub DESTROY {}

# Restore warning handler
BEGIN {
	$SIG{__WARN__} = $SIG{__WARN__}->();
}

1;

#line 154
HTML-Truncate-0.20/inc/Module/Install/Can.pm0000644000076500000240000000333311226750565020533 0ustar  jinxstaff00000000000000#line 1
package Module::Install::Can;

use strict;
use Config                ();
use File::Spec            ();
use ExtUtils::MakeMaker   ();
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';
	@ISA     = 'Module::Install::Base';
	$ISCORE  = 1;
}

# check if we can load some module
### Upgrade this to not have to load the module if possible
sub can_use {
	my ($self, $mod, $ver) = @_;
	$mod =~ s{::|\\}{/}g;
	$mod .= '.pm' unless $mod =~ /\.pm$/i;

	my $pkg = $mod;
	$pkg =~ s{/}{::}g;
	$pkg =~ s{\.pm$}{}i;

	local $@;
	eval { require $mod; $pkg->VERSION($ver || 0); 1 };
}

# check if we can run some command
sub can_run {
	my ($self, $cmd) = @_;

	my $_cmd = $cmd;
	return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));

	for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
		next if $dir eq '';
		my $abs = File::Spec->catfile($dir, $_[1]);
		return $abs if (-x $abs or $abs = MM->maybe_command($abs));
	}

	return;
}

# can we locate a (the) C compiler
sub can_cc {
	my $self   = shift;
	my @chunks = split(/ /, $Config::Config{cc}) or return;

	# $Config{cc} may contain args; try to find out the program part
	while (@chunks) {
		return $self->can_run("@chunks") || (pop(@chunks), next);
	}

	return;
}

# Fix Cygwin bug on maybe_command();
if ( $^O eq 'cygwin' ) {
	require ExtUtils::MM_Cygwin;
	require ExtUtils::MM_Win32;
	if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
		*ExtUtils::MM_Cygwin::maybe_command = sub {
			my ($self, $file) = @_;
			if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
				ExtUtils::MM_Win32->maybe_command($file);
			} else {
				ExtUtils::MM_Unix->maybe_command($file);
			}
		}
	}
}

1;

__END__

#line 156
HTML-Truncate-0.20/inc/Module/Install/Fetch.pm0000644000076500000240000000462711226750565021072 0ustar  jinxstaff00000000000000#line 1
package Module::Install::Fetch;

use strict;
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';
	@ISA     = 'Module::Install::Base';
	$ISCORE  = 1;
}

sub get_file {
    my ($self, %args) = @_;
    my ($scheme, $host, $path, $file) =
        $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;

    if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
        $args{url} = $args{ftp_url}
            or (warn("LWP support unavailable!\n"), return);
        ($scheme, $host, $path, $file) =
            $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
    }

    $|++;
    print "Fetching '$file' from $host... ";

    unless (eval { require Socket; Socket::inet_aton($host) }) {
        warn "'$host' resolve failed!\n";
        return;
    }

    return unless $scheme eq 'ftp' or $scheme eq 'http';

    require Cwd;
    my $dir = Cwd::getcwd();
    chdir $args{local_dir} or return if exists $args{local_dir};

    if (eval { require LWP::Simple; 1 }) {
        LWP::Simple::mirror($args{url}, $file);
    }
    elsif (eval { require Net::FTP; 1 }) { eval {
        # use Net::FTP to get past firewall
        my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
        $ftp->login("anonymous", 'anonymous@example.com');
        $ftp->cwd($path);
        $ftp->binary;
        $ftp->get($file) or (warn("$!\n"), return);
        $ftp->quit;
    } }
    elsif (my $ftp = $self->can_run('ftp')) { eval {
        # no Net::FTP, fallback to ftp.exe
        require FileHandle;
        my $fh = FileHandle->new;

        local $SIG{CHLD} = 'IGNORE';
        unless ($fh->open("|$ftp -n")) {
            warn "Couldn't open ftp: $!\n";
            chdir $dir; return;
        }

        my @dialog = split(/\n/, <<"END_FTP");
open $host
user anonymous anonymous\@example.com
cd $path
binary
get $file $file
quit
END_FTP
        foreach (@dialog) { $fh->print("$_\n") }
        $fh->close;
    } }
    else {
        warn "No working 'ftp' program available!\n";
        chdir $dir; return;
    }

    unless (-f $file) {
        warn "Fetching failed: $@\n";
        chdir $dir; return;
    }

    return if exists $args{size} and -s $file != $args{size};
    system($args{run}) if exists $args{run};
    unlink($file) if $args{remove};

    print(((!exists $args{check_for} or -e $args{check_for})
        ? "done!" : "failed! ($!)"), "\n");
    chdir $dir; return !$?;
}

1;
HTML-Truncate-0.20/inc/Module/Install/Include.pm0000644000076500000240000000101511226750564021407 0ustar  jinxstaff00000000000000#line 1
package Module::Install::Include;

use strict;
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';
	@ISA     = 'Module::Install::Base';
	$ISCORE  = 1;
}

sub include {
	shift()->admin->include(@_);
}

sub include_deps {
	shift()->admin->include_deps(@_);
}

sub auto_include {
	shift()->admin->auto_include(@_);
}

sub auto_include_deps {
	shift()->admin->auto_include_deps(@_);
}

sub auto_include_dependent_dists {
	shift()->admin->auto_include_dependent_dists(@_);
}

1;
HTML-Truncate-0.20/inc/Module/Install/Makefile.pm0000644000076500000240000001600311226750564021544 0ustar  jinxstaff00000000000000#line 1
package Module::Install::Makefile;

use strict 'vars';
use ExtUtils::MakeMaker   ();
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';
	@ISA     = 'Module::Install::Base';
	$ISCORE  = 1;
}

sub Makefile { $_[0] }

my %seen = ();

sub prompt {
	shift;

	# Infinite loop protection
	my @c = caller();
	if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
		die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
	}

	# In automated testing, always use defaults
	if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) {
		local $ENV{PERL_MM_USE_DEFAULT} = 1;
		goto &ExtUtils::MakeMaker::prompt;
	} else {
		goto &ExtUtils::MakeMaker::prompt;
	}
}

sub makemaker_args {
	my $self = shift;
	my $args = ( $self->{makemaker_args} ||= {} );
	%$args = ( %$args, @_ );
	return $args;
}

# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
	my $self = sShift;
	my $name = shift;
	my $args = $self->makemaker_args;
	$args->{name} = defined $args->{$name}
		? join( ' ', $args->{name}, @_ )
		: join( ' ', @_ );
}

sub build_subdirs {
	my $self    = shift;
	my $subdirs = $self->makemaker_args->{DIR} ||= [];
	for my $subdir (@_) {
		push @$subdirs, $subdir;
	}
}

sub clean_files {
	my $self  = shift;
	my $clean = $self->makemaker_args->{clean} ||= {};
	  %$clean = (
		%$clean,
		FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
	);
}

sub realclean_files {
	my $self      = shift;
	my $realclean = $self->makemaker_args->{realclean} ||= {};
	  %$realclean = (
		%$realclean,
		FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
	);
}

sub libs {
	my $self = shift;
	my $libs = ref $_[0] ? shift : [ shift ];
	$self->makemaker_args( LIBS => $libs );
}

sub inc {
	my $self = shift;
	$self->makemaker_args( INC => shift );
}

my %test_dir = ();

sub _wanted_t {
	/\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1;
}

sub tests_recursive {
	my $self = shift;
	if ( $self->tests ) {
		die "tests_recursive will not work if tests are already defined";
	}
	my $dir = shift || 't';
	unless ( -d $dir ) {
		die "tests_recursive dir '$dir' does not exist";
	}
	%test_dir = ();
	require File::Find;
	File::Find::find( \&_wanted_t, $dir );
	$self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir );
}

sub write {
	my $self = shift;
	die "&Makefile->write() takes no arguments\n" if @_;

	# Check the current Perl version
	my $perl_version = $self->perl_version;
	if ( $perl_version ) {
		eval "use $perl_version; 1"
			or die "ERROR: perl: Version $] is installed, "
			. "but we need version >= $perl_version";
	}

	# Make sure we have a new enough MakeMaker
	require ExtUtils::MakeMaker;

	if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
		# MakeMaker can complain about module versions that include
		# an underscore, even though its own version may contain one!
		# Hence the funny regexp to get rid of it.  See RT #35800
		# for details.
		$self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
		$self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
	} else {
		# Allow legacy-compatibility with 5.005 by depending on the
		# most recent EU:MM that supported 5.005.
		$self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
		$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
	}

	# Generate the MakeMaker params
	my $args = $self->makemaker_args;
	$args->{DISTNAME} = $self->name;
	$args->{NAME}     = $self->module_name || $self->name;
	$args->{VERSION}  = $self->version;
	$args->{NAME}     =~ s/-/::/g;
	if ( $self->tests ) {
		$args->{test} = { TESTS => $self->tests };
	}
	if ( $] >= 5.005 ) {
		$args->{ABSTRACT} = $self->abstract;
		$args->{AUTHOR}   = $self->author;
	}
	if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
		$args->{NO_META} = 1;
	}
	if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
		$args->{SIGN} = 1;
	}
	unless ( $self->is_admin ) {
		delete $args->{SIGN};
	}

	# Merge both kinds of requires into prereq_pm
	my $prereq = ($args->{PREREQ_PM} ||= {});
	%$prereq = ( %$prereq,
		map { @$_ }
		map { @$_ }
		grep $_,
		($self->configure_requires, $self->build_requires, $self->requires)
	);

	# Remove any reference to perl, PREREQ_PM doesn't support it
	delete $args->{PREREQ_PM}->{perl};

	# merge both kinds of requires into prereq_pm
	my $subdirs = ($args->{DIR} ||= []);
	if ($self->bundles) {
		foreach my $bundle (@{ $self->bundles }) {
			my ($file, $dir) = @$bundle;
			push @$subdirs, $dir if -d $dir;
			delete $prereq->{$file};
		}
	}

	if ( my $perl_version = $self->perl_version ) {
		eval "use $perl_version; 1"
			or die "ERROR: perl: Version $] is installed, "
			. "but we need version >= $perl_version";
	}

	$args->{INSTALLDIRS} = $self->installdirs;

	my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;

	my $user_preop = delete $args{dist}->{PREOP};
	if (my $preop = $self->admin->preop($user_preop)) {
		foreach my $key ( keys %$preop ) {
			$args{dist}->{$key} = $preop->{$key};
		}
	}

	my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
	$self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
}

sub fix_up_makefile {
	my $self          = shift;
	my $makefile_name = shift;
	my $top_class     = ref($self->_top) || '';
	my $top_version   = $self->_top->VERSION || '';

	my $preamble = $self->preamble
		? "# Preamble by $top_class $top_version\n"
			. $self->preamble
		: '';
	my $postamble = "# Postamble by $top_class $top_version\n"
		. ($self->postamble || '');

	local *MAKEFILE;
	open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	my $makefile = do { local $/;  };
	close MAKEFILE or die $!;

	$makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
	$makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
	$makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
	$makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
	$makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;

	# Module::Install will never be used to build the Core Perl
	# Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
	# PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
	$makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
	#$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;

	# Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
	$makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;

	# XXX - This is currently unused; not sure if it breaks other MM-users
	# $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;

	open  MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
	print MAKEFILE  "$preamble$makefile$postamble" or die $!;
	close MAKEFILE  or die $!;

	1;
}

sub preamble {
	my ($self, $text) = @_;
	$self->{preamble} = $text . $self->{preamble} if defined $text;
	$self->{preamble};
}

sub postamble {
	my ($self, $text) = @_;
	$self->{postamble} ||= $self->admin->postamble;
	$self->{postamble} .= $text if defined $text;
	$self->{postamble}
}

1;

__END__

#line 394
HTML-Truncate-0.20/inc/Module/Install/Metadata.pm0000644000076500000240000003530411226750563021553 0ustar  jinxstaff00000000000000#line 1
package Module::Install::Metadata;

use strict 'vars';
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';
	@ISA     = 'Module::Install::Base';
	$ISCORE  = 1;
}

my @boolean_keys = qw{
	sign
};

my @scalar_keys = qw{
	name
	module_name
	abstract
	author
	version
	distribution_type
	tests
	installdirs
};

my @tuple_keys = qw{
	configure_requires
	build_requires
	requires
	recommends
	bundles
	resources
};

my @resource_keys = qw{
	homepage
	bugtracker
	repository
};

my @array_keys = qw{
	keywords
};

sub Meta              { shift          }
sub Meta_BooleanKeys  { @boolean_keys  }
sub Meta_ScalarKeys   { @scalar_keys   }
sub Meta_TupleKeys    { @tuple_keys    }
sub Meta_ResourceKeys { @resource_keys }
sub Meta_ArrayKeys    { @array_keys    }

foreach my $key ( @boolean_keys ) {
	*$key = sub {
		my $self = shift;
		if ( defined wantarray and not @_ ) {
			return $self->{values}->{$key};
		}
		$self->{values}->{$key} = ( @_ ? $_[0] : 1 );
		return $self;
	};
}

foreach my $key ( @scalar_keys ) {
	*$key = sub {
		my $self = shift;
		return $self->{values}->{$key} if defined wantarray and !@_;
		$self->{values}->{$key} = shift;
		return $self;
	};
}

foreach my $key ( @array_keys ) {
	*$key = sub {
		my $self = shift;
		return $self->{values}->{$key} if defined wantarray and !@_;
		$self->{values}->{$key} ||= [];
		push @{$self->{values}->{$key}}, @_;
		return $self;
	};
}

foreach my $key ( @resource_keys ) {
	*$key = sub {
		my $self = shift;
		unless ( @_ ) {
			return () unless $self->{values}->{resources};
			return map  { $_->[1] }
			       grep { $_->[0] eq $key }
			       @{ $self->{values}->{resources} };
		}
		return $self->{values}->{resources}->{$key} unless @_;
		my $uri = shift or die(
			"Did not provide a value to $key()"
		);
		$self->resources( $key => $uri );
		return 1;
	};
}

foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
	*$key = sub {
		my $self = shift;
		return $self->{values}->{$key} unless @_;
		my @added;
		while ( @_ ) {
			my $module  = shift or last;
			my $version = shift || 0;
			push @added, [ $module, $version ];
		}
		push @{ $self->{values}->{$key} }, @added;
		return map {@$_} @added;
	};
}

# Resource handling
my %lc_resource = map { $_ => 1 } qw{
	homepage
	license
	bugtracker
	repository
};

sub resources {
	my $self = shift;
	while ( @_ ) {
		my $name  = shift or last;
		my $value = shift or next;
		if ( $name eq lc $name and ! $lc_resource{$name} ) {
			die("Unsupported reserved lowercase resource '$name'");
		}
		$self->{values}->{resources} ||= [];
		push @{ $self->{values}->{resources} }, [ $name, $value ];
	}
	$self->{values}->{resources};
}

# Aliases for build_requires that will have alternative
# meanings in some future version of META.yml.
sub test_requires     { shift->build_requires(@_) }
sub install_requires  { shift->build_requires(@_) }

# Aliases for installdirs options
sub install_as_core   { $_[0]->installdirs('perl')   }
sub install_as_cpan   { $_[0]->installdirs('site')   }
sub install_as_site   { $_[0]->installdirs('site')   }
sub install_as_vendor { $_[0]->installdirs('vendor') }

sub dynamic_config {
	my $self = shift;
	unless ( @_ ) {
		warn "You MUST provide an explicit true/false value to dynamic_config\n";
		return $self;
	}
	$self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
	return 1;
}

sub perl_version {
	my $self = shift;
	return $self->{values}->{perl_version} unless @_;
	my $version = shift or die(
		"Did not provide a value to perl_version()"
	);

	# Normalize the version
	$version = $self->_perl_version($version);

	# We don't support the reall old versions
	unless ( $version >= 5.005 ) {
		die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
	}

	$self->{values}->{perl_version} = $version;
}

#Stolen from M::B
my %license_urls = (
    perl         => 'http://dev.perl.org/licenses/',
    apache       => 'http://apache.org/licenses/LICENSE-2.0',
    artistic     => 'http://opensource.org/licenses/artistic-license.php',
    artistic_2   => 'http://opensource.org/licenses/artistic-license-2.0.php',
    lgpl         => 'http://opensource.org/licenses/lgpl-license.php',
    lgpl2        => 'http://opensource.org/licenses/lgpl-2.1.php',
    lgpl3        => 'http://opensource.org/licenses/lgpl-3.0.html',
    bsd          => 'http://opensource.org/licenses/bsd-license.php',
    gpl          => 'http://opensource.org/licenses/gpl-license.php',
    gpl2         => 'http://opensource.org/licenses/gpl-2.0.php',
    gpl3         => 'http://opensource.org/licenses/gpl-3.0.html',
    mit          => 'http://opensource.org/licenses/mit-license.php',
    mozilla      => 'http://opensource.org/licenses/mozilla1.1.php',
    open_source  => undef,
    unrestricted => undef,
    restrictive  => undef,
    unknown      => undef,
);

sub license {
	my $self = shift;
	return $self->{values}->{license} unless @_;
	my $license = shift or die(
		'Did not provide a value to license()'
	);
	$self->{values}->{license} = $license;

	# Automatically fill in license URLs
	if ( $license_urls{$license} ) {
		$self->resources( license => $license_urls{$license} );
	}

	return 1;
}

sub all_from {
	my ( $self, $file ) = @_;

	unless ( defined($file) ) {
		my $name = $self->name or die(
			"all_from called with no args without setting name() first"
		);
		$file = join('/', 'lib', split(/-/, $name)) . '.pm';
		$file =~ s{.*/}{} unless -e $file;
		unless ( -e $file ) {
			die("all_from cannot find $file from $name");
		}
	}
	unless ( -f $file ) {
		die("The path '$file' does not exist, or is not a file");
	}

	# Some methods pull from POD instead of code.
	# If there is a matching .pod, use that instead
	my $pod = $file;
	$pod =~ s/\.pm$/.pod/i;
	$pod = $file unless -e $pod;

	# Pull the different values
	$self->name_from($file)         unless $self->name;
	$self->version_from($file)      unless $self->version;
	$self->perl_version_from($file) unless $self->perl_version;
	$self->author_from($pod)        unless $self->author;
	$self->license_from($pod)       unless $self->license;
	$self->abstract_from($pod)      unless $self->abstract;

	return 1;
}

sub provides {
	my $self     = shift;
	my $provides = ( $self->{values}->{provides} ||= {} );
	%$provides = (%$provides, @_) if @_;
	return $provides;
}

sub auto_provides {
	my $self = shift;
	return $self unless $self->is_admin;
	unless (-e 'MANIFEST') {
		warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
		return $self;
	}
	# Avoid spurious warnings as we are not checking manifest here.
	local $SIG{__WARN__} = sub {1};
	require ExtUtils::Manifest;
	local *ExtUtils::Manifest::manicheck = sub { return };

	require Module::Build;
	my $build = Module::Build->new(
		dist_name    => $self->name,
		dist_version => $self->version,
		license      => $self->license,
	);
	$self->provides( %{ $build->find_dist_packages || {} } );
}

sub feature {
	my $self     = shift;
	my $name     = shift;
	my $features = ( $self->{values}->{features} ||= [] );
	my $mods;

	if ( @_ == 1 and ref( $_[0] ) ) {
		# The user used ->feature like ->features by passing in the second
		# argument as a reference.  Accomodate for that.
		$mods = $_[0];
	} else {
		$mods = \@_;
	}

	my $count = 0;
	push @$features, (
		$name => [
			map {
				ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
			} @$mods
		]
	);

	return @$features;
}

sub features {
	my $self = shift;
	while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
		$self->feature( $name, @$mods );
	}
	return $self->{values}->{features}
		? @{ $self->{values}->{features} }
		: ();
}

sub no_index {
	my $self = shift;
	my $type = shift;
	push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
	return $self->{values}->{no_index};
}

sub read {
	my $self = shift;
	$self->include_deps( 'YAML::Tiny', 0 );

	require YAML::Tiny;
	my $data = YAML::Tiny::LoadFile('META.yml');

	# Call methods explicitly in case user has already set some values.
	while ( my ( $key, $value ) = each %$data ) {
		next unless $self->can($key);
		if ( ref $value eq 'HASH' ) {
			while ( my ( $module, $version ) = each %$value ) {
				$self->can($key)->($self, $module => $version );
			}
		} else {
			$self->can($key)->($self, $value);
		}
	}
	return $self;
}

sub write {
	my $self = shift;
	return $self unless $self->is_admin;
	$self->admin->write_meta;
	return $self;
}

sub version_from {
	require ExtUtils::MM_Unix;
	my ( $self, $file ) = @_;
	$self->version( ExtUtils::MM_Unix->parse_version($file) );
}

sub abstract_from {
	require ExtUtils::MM_Unix;
	my ( $self, $file ) = @_;
	$self->abstract(
		bless(
			{ DISTNAME => $self->name },
			'ExtUtils::MM_Unix'
		)->parse_abstract($file)
	 );
}

# Add both distribution and module name
sub name_from {
	my ($self, $file) = @_;
	if (
		Module::Install::_read($file) =~ m/
		^ \s*
		package \s*
		([\w:]+)
		\s* ;
		/ixms
	) {
		my ($name, $module_name) = ($1, $1);
		$name =~ s{::}{-}g;
		$self->name($name);
		unless ( $self->module_name ) {
			$self->module_name($module_name);
		}
	} else {
		die("Cannot determine name from $file\n");
	}
}

sub perl_version_from {
	my $self = shift;
	if (
		Module::Install::_read($_[0]) =~ m/
		^
		(?:use|require) \s*
		v?
		([\d_\.]+)
		\s* ;
		/ixms
	) {
		my $perl_version = $1;
		$perl_version =~ s{_}{}g;
		$self->perl_version($perl_version);
	} else {
		warn "Cannot determine perl version info from $_[0]\n";
		return;
	}
}

sub author_from {
	my $self    = shift;
	my $content = Module::Install::_read($_[0]);
	if ($content =~ m/
		=head \d \s+ (?:authors?)\b \s*
		([^\n]*)
		|
		=head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
		.*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
		([^\n]*)
	/ixms) {
		my $author = $1 || $2;
		$author =~ s{E}{<}g;
		$author =~ s{E}{>}g;
		$self->author($author);
	} else {
		warn "Cannot determine author info from $_[0]\n";
	}
}

sub license_from {
	my $self = shift;
	if (
		Module::Install::_read($_[0]) =~ m/
		(
			=head \d \s+
			(?:licen[cs]e|licensing|copyright|legal)\b
			.*?
		)
		(=head\\d.*|=cut.*|)
		\z
	/ixms ) {
		my $license_text = $1;
		my @phrases      = (
			'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
			'GNU general public license'         => 'gpl',         1,
			'GNU public license'                 => 'gpl',         1,
			'GNU lesser general public license'  => 'lgpl',        1,
			'GNU lesser public license'          => 'lgpl',        1,
			'GNU library general public license' => 'lgpl',        1,
			'GNU library public license'         => 'lgpl',        1,
			'BSD license'                        => 'bsd',         1,
			'Artistic license'                   => 'artistic',    1,
			'GPL'                                => 'gpl',         1,
			'LGPL'                               => 'lgpl',        1,
			'BSD'                                => 'bsd',         1,
			'Artistic'                           => 'artistic',    1,
			'MIT'                                => 'mit',         1,
			'proprietary'                        => 'proprietary', 0,
		);
		while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
			$pattern =~ s{\s+}{\\s+}g;
			if ( $license_text =~ /\b$pattern\b/i ) {
				$self->license($license);
				return 1;
			}
		}
	}

	warn "Cannot determine license info from $_[0]\n";
	return 'unknown';
}

sub _extract_bugtracker {
	my @links   = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
	my %links;
	@links{@links}=();
	@links=keys %links;
	return @links;
}

sub bugtracker_from {
	my $self    = shift;
	my $content = Module::Install::_read($_[0]);
	my @links   = _extract_bugtracker($content);
	unless ( @links ) {
		warn "Cannot determine bugtracker info from $_[0]\n";
		return 0;
	}
	if ( @links > 1 ) {
		warn "Found more than on rt.cpan.org link in $_[0]\n";
		return 0;
	}

	# Set the bugtracker
	bugtracker( $links[0] );
	return 1;
}

sub requires_from {
	my $self     = shift;
	my $content  = Module::Install::_readperl($_[0]);
	my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
	while ( @requires ) {
		my $module  = shift @requires;
		my $version = shift @requires;
		$self->requires( $module => $version );
	}
}

sub test_requires_from {
	my $self     = shift;
	my $content  = Module::Install::_readperl($_[0]);
	my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
	while ( @requires ) {
		my $module  = shift @requires;
		my $version = shift @requires;
		$self->test_requires( $module => $version );
	}
}

# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
	my $v = $_[-1];
	$v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
	$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
	$v =~ s/(\.\d\d\d)000$/$1/;
	$v =~ s/_.+$//;
	if ( ref($v) ) {
		# Numify
		$v = $v + 0;
	}
	return $v;
}





######################################################################
# MYMETA Support

sub WriteMyMeta {
	die "WriteMyMeta has been deprecated";
}

sub write_mymeta_yaml {
	my $self = shift;

	# We need YAML::Tiny to write the MYMETA.yml file
	unless ( eval { require YAML::Tiny; 1; } ) {
		return 1;
	}

	# Generate the data
	my $meta = $self->_write_mymeta_data or return 1;

	# Save as the MYMETA.yml file
	print "Writing MYMETA.yml\n";
	YAML::Tiny::DumpFile('MYMETA.yml', $meta);
}

sub write_mymeta_json {
	my $self = shift;

	# We need JSON to write the MYMETA.json file
	unless ( eval { require JSON; 1; } ) {
		return 1;
	}

	# Generate the data
	my $meta = $self->_write_mymeta_data or return 1;

	# Save as the MYMETA.yml file
	print "Writing MYMETA.json\n";
	Module::Install::_write(
		'MYMETA.json',
		JSON->new->pretty(1)->canonical->encode($meta),
	);
}

sub _write_mymeta_data {
	my $self = shift;

	# If there's no existing META.yml there is nothing we can do
	return undef unless -f 'META.yml';

	# We need Parse::CPAN::Meta to load the file
	unless ( eval { require Parse::CPAN::Meta; 1; } ) {
		return undef;
	}

	# Merge the perl version into the dependencies
	my $val  = $self->Meta->{values};
	my $perl = delete $val->{perl_version};
	if ( $perl ) {
		$val->{requires} ||= [];
		my $requires = $val->{requires};

		# Canonize to three-dot version after Perl 5.6
		if ( $perl >= 5.006 ) {
			$perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
		}
		unshift @$requires, [ perl => $perl ];
	}

	# Load the advisory META.yml file
	my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
	my $meta = $yaml[0];

	# Overwrite the non-configure dependency hashs
	delete $meta->{requires};
	delete $meta->{build_requires};
	delete $meta->{recommends};
	if ( exists $val->{requires} ) {
		$meta->{requires} = { map { @$_ } @{ $val->{requires} } };
	}
	if ( exists $val->{build_requires} ) {
		$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
	}

	return $meta;
}

1;
HTML-Truncate-0.20/inc/Module/Install/Win32.pm0000644000076500000240000000340311226750565020732 0ustar  jinxstaff00000000000000#line 1
package Module::Install::Win32;

use strict;
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';
	@ISA     = 'Module::Install::Base';
	$ISCORE  = 1;
}

# determine if the user needs nmake, and download it if needed
sub check_nmake {
	my $self = shift;
	$self->load('can_run');
	$self->load('get_file');

	require Config;
	return unless (
		$^O eq 'MSWin32'                     and
		$Config::Config{make}                and
		$Config::Config{make} =~ /^nmake\b/i and
		! $self->can_run('nmake')
	);

	print "The required 'nmake' executable not found, fetching it...\n";

	require File::Basename;
	my $rv = $self->get_file(
		url       => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
		ftp_url   => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
		local_dir => File::Basename::dirname($^X),
		size      => 51928,
		run       => 'Nmake15.exe /o > nul',
		check_for => 'Nmake.exe',
		remove    => 1,
	);

	die <<'END_MESSAGE' unless $rv;

-------------------------------------------------------------------------------

Since you are using Microsoft Windows, you will need the 'nmake' utility
before installation. It's available at:

  http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
      or
  ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe

Please download the file manually, save it to a directory in %PATH% (e.g.
C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
that directory, and run "Nmake15.exe" from there; that will create the
'nmake.exe' file needed by this module.

You may then resume the installation process described in README.

-------------------------------------------------------------------------------
END_MESSAGE

}

1;
HTML-Truncate-0.20/inc/Module/Install/WriteAll.pm0000644000076500000240000000222211226750565021551 0ustar  jinxstaff00000000000000#line 1
package Module::Install::WriteAll;

use strict;
use Module::Install::Base ();

use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
	$VERSION = '0.91';;
	@ISA     = qw{Module::Install::Base};
	$ISCORE  = 1;
}

sub WriteAll {
	my $self = shift;
	my %args = (
		meta        => 1,
		sign        => 0,
		inline      => 0,
		check_nmake => 1,
		@_,
	);

	$self->sign(1)                if $args{sign};
	$self->admin->WriteAll(%args) if $self->is_admin;

	$self->check_nmake if $args{check_nmake};
	unless ( $self->makemaker_args->{PL_FILES} ) {
		$self->makemaker_args( PL_FILES => {} );
	}

	# Until ExtUtils::MakeMaker support MYMETA.yml, make sure
	# we clean it up properly ourself.
	$self->realclean_files('MYMETA.yml');

	if ( $args{inline} ) {
		$self->Inline->write;
	} else {
		$self->Makefile->write;
	}

	# The Makefile write process adds a couple of dependencies,
	# so write the META.yml files after the Makefile.
	if ( $args{meta} ) {
		$self->Meta->write;
	}

	# Experimental support for MYMETA
	if ( $ENV{X_MYMETA} ) {
		if ( $ENV{X_MYMETA} eq 'JSON' ) {
			$self->Meta->write_mymeta_json;
		} else {
			$self->Meta->write_mymeta_yaml;
		}
	}

	return 1;
}

1;
HTML-Truncate-0.20/inc/Module/Install.pm0000644000076500000240000002411411226750563020030 0ustar  jinxstaff00000000000000#line 1
package Module::Install;

# For any maintainers:
# The load order for Module::Install is a bit magic.
# It goes something like this...
#
# IF ( host has Module::Install installed, creating author mode ) {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
#     3. The installed version of inc::Module::Install loads
#     4. inc::Module::Install calls "require Module::Install"
#     5. The ./inc/ version of Module::Install loads
# } ELSE {
#     1. Makefile.PL calls "use inc::Module::Install"
#     2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
#     3. The ./inc/ version of Module::Install loads
# }

use 5.005;
use strict 'vars';

use vars qw{$VERSION $MAIN};
BEGIN {
	# All Module::Install core packages now require synchronised versions.
	# This will be used to ensure we don't accidentally load old or
	# different versions of modules.
	# This is not enforced yet, but will be some time in the next few
	# releases once we can make sure it won't clash with custom
	# Module::Install extensions.
	$VERSION = '0.91';

	# Storage for the pseudo-singleton
	$MAIN    = undef;

	*inc::Module::Install::VERSION = *VERSION;
	@inc::Module::Install::ISA     = __PACKAGE__;

}





# Whether or not inc::Module::Install is actually loaded, the
# $INC{inc/Module/Install.pm} is what will still get set as long as
# the caller loaded module this in the documented manner.
# If not set, the caller may NOT have loaded the bundled version, and thus
# they may not have a MI version that works with the Makefile.PL. This would
# result in false errors or unexpected behaviour. And we don't want that.
my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
unless ( $INC{$file} ) { die <<"END_DIE" }

Please invoke ${\__PACKAGE__} with:

	use inc::${\__PACKAGE__};

not:

	use ${\__PACKAGE__};

END_DIE





# If the script that is loading Module::Install is from the future,
# then make will detect this and cause it to re-run over and over
# again. This is bad. Rather than taking action to touch it (which
# is unreliable on some platforms and requires write permissions)
# for now we should catch this and refuse to run.
if ( -f $0 ) {
	my $s = (stat($0))[9];

	# If the modification time is only slightly in the future,
	# sleep briefly to remove the problem.
	my $a = $s - time;
	if ( $a > 0 and $a < 5 ) { sleep 5 }

	# Too far in the future, throw an error.
	my $t = time;
	if ( $s > $t ) { die <<"END_DIE" }

Your installer $0 has a modification time in the future ($s > $t).

This is known to create infinite loops in make.

Please correct this, then run $0 again.

END_DIE
}





# Build.PL was formerly supported, but no longer is due to excessive
# difficulty in implementing every single feature twice.
if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }

Module::Install no longer supports Build.PL.

It was impossible to maintain duel backends, and has been deprecated.

Please remove all Build.PL files and only use the Makefile.PL installer.

END_DIE





# To save some more typing in Module::Install installers, every...
# use inc::Module::Install
# ...also acts as an implicit use strict.
$^H |= strict::bits(qw(refs subs vars));





use Cwd        ();
use File::Find ();
use File::Path ();
use FindBin;

sub autoload {
	my $self = shift;
	my $who  = $self->_caller;
	my $cwd  = Cwd::cwd();
	my $sym  = "${who}::AUTOLOAD";
	$sym->{$cwd} = sub {
		my $pwd = Cwd::cwd();
		if ( my $code = $sym->{$pwd} ) {
			# Delegate back to parent dirs
			goto &$code unless $cwd eq $pwd;
		}
		$$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym";
		my $method = $1;
		if ( uc($method) eq $method ) {
			# Do nothing
			return;
		} elsif ( $method =~ /^_/ and $self->can($method) ) {
			# Dispatch to the root M:I class
			return $self->$method(@_);
		}

		# Dispatch to the appropriate plugin
		unshift @_, ( $self, $1 );
		goto &{$self->can('call')};
	};
}

sub import {
	my $class = shift;
	my $self  = $class->new(@_);
	my $who   = $self->_caller;

	unless ( -f $self->{file} ) {
		require "$self->{path}/$self->{dispatch}.pm";
		File::Path::mkpath("$self->{prefix}/$self->{author}");
		$self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
		$self->{admin}->init;
		@_ = ($class, _self => $self);
		goto &{"$self->{name}::import"};
	}

	*{"${who}::AUTOLOAD"} = $self->autoload;
	$self->preload;

	# Unregister loader and worker packages so subdirs can use them again
	delete $INC{"$self->{file}"};
	delete $INC{"$self->{path}.pm"};

	# Save to the singleton
	$MAIN = $self;

	return 1;
}

sub preload {
	my $self = shift;
	unless ( $self->{extensions} ) {
		$self->load_extensions(
			"$self->{prefix}/$self->{path}", $self
		);
	}

	my @exts = @{$self->{extensions}};
	unless ( @exts ) {
		@exts = $self->{admin}->load_all_extensions;
	}

	my %seen;
	foreach my $obj ( @exts ) {
		while (my ($method, $glob) = each %{ref($obj) . '::'}) {
			next unless $obj->can($method);
			next if $method =~ /^_/;
			next if $method eq uc($method);
			$seen{$method}++;
		}
	}

	my $who = $self->_caller;
	foreach my $name ( sort keys %seen ) {
		*{"${who}::$name"} = sub {
			${"${who}::AUTOLOAD"} = "${who}::$name";
			goto &{"${who}::AUTOLOAD"};
		};
	}
}

sub new {
	my ($class, %args) = @_;

	# ignore the prefix on extension modules built from top level.
	my $base_path = Cwd::abs_path($FindBin::Bin);
	unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
		delete $args{prefix};
	}

	return $args{_self} if $args{_self};

	$args{dispatch} ||= 'Admin';
	$args{prefix}   ||= 'inc';
	$args{author}   ||= ($^O eq 'VMS' ? '_author' : '.author');
	$args{bundle}   ||= 'inc/BUNDLES';
	$args{base}     ||= $base_path;
	$class =~ s/^\Q$args{prefix}\E:://;
	$args{name}     ||= $class;
	$args{version}  ||= $class->VERSION;
	unless ( $args{path} ) {
		$args{path}  = $args{name};
		$args{path}  =~ s!::!/!g;
	}
	$args{file}     ||= "$args{base}/$args{prefix}/$args{path}.pm";
	$args{wrote}      = 0;

	bless( \%args, $class );
}

sub call {
	my ($self, $method) = @_;
	my $obj = $self->load($method) or return;
        splice(@_, 0, 2, $obj);
	goto &{$obj->can($method)};
}

sub load {
	my ($self, $method) = @_;

	$self->load_extensions(
		"$self->{prefix}/$self->{path}", $self
	) unless $self->{extensions};

	foreach my $obj (@{$self->{extensions}}) {
		return $obj if $obj->can($method);
	}

	my $admin = $self->{admin} or die <<"END_DIE";
The '$method' method does not exist in the '$self->{prefix}' path!
Please remove the '$self->{prefix}' directory and run $0 again to load it.
END_DIE

	my $obj = $admin->load($method, 1);
	push @{$self->{extensions}}, $obj;

	$obj;
}

sub load_extensions {
	my ($self, $path, $top) = @_;

	unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
		unshift @INC, $self->{prefix};
	}

	foreach my $rv ( $self->find_extensions($path) ) {
		my ($file, $pkg) = @{$rv};
		next if $self->{pathnames}{$pkg};

		local $@;
		my $new = eval { require $file; $pkg->can('new') };
		unless ( $new ) {
			warn $@ if $@;
			next;
		}
		$self->{pathnames}{$pkg} = delete $INC{$file};
		push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
	}

	$self->{extensions} ||= [];
}

sub find_extensions {
	my ($self, $path) = @_;

	my @found;
	File::Find::find( sub {
		my $file = $File::Find::name;
		return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
		my $subpath = $1;
		return if lc($subpath) eq lc($self->{dispatch});

		$file = "$self->{path}/$subpath.pm";
		my $pkg = "$self->{name}::$subpath";
		$pkg =~ s!/!::!g;

		# If we have a mixed-case package name, assume case has been preserved
		# correctly.  Otherwise, root through the file to locate the case-preserved
		# version of the package name.
		if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
			my $content = Module::Install::_read($subpath . '.pm');
			my $in_pod  = 0;
			foreach ( split //, $content ) {
				$in_pod = 1 if /^=\w/;
				$in_pod = 0 if /^=cut/;
				next if ($in_pod || /^=cut/);  # skip pod text
				next if /^\s*#/;               # and comments
				if ( m/^\s*package\s+($pkg)\s*;/i ) {
					$pkg = $1;
					last;
				}
			}
		}

		push @found, [ $file, $pkg ];
	}, $path ) if -d $path;

	@found;
}





#####################################################################
# Common Utility Functions

sub _caller {
	my $depth = 0;
	my $call  = caller($depth);
	while ( $call eq __PACKAGE__ ) {
		$depth++;
		$call = caller($depth);
	}
	return $call;
}

sub _read {
	local *FH;
	if ( $] >= 5.006 ) {
		open( FH, '<', $_[0] ) or die "open($_[0]): $!";
	} else {
		open( FH, "< $_[0]"  ) or die "open($_[0]): $!";
	}
	my $string = do { local $/;  };
	close FH or die "close($_[0]): $!";
	return $string;
}

sub _readperl {
	my $string = Module::Install::_read($_[0]);
	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
	$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
	$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
	return $string;
}

sub _readpod {
	my $string = Module::Install::_read($_[0]);
	$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
	return $string if $_[0] =~ /\.pod\z/;
	$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
	$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
	$string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
	$string =~ s/^\n+//s;
	return $string;
}

sub _write {
	local *FH;
	if ( $] >= 5.006 ) {
		open( FH, '>', $_[0] ) or die "open($_[0]): $!";
	} else {
		open( FH, "> $_[0]"  ) or die "open($_[0]): $!";
	}
	foreach ( 1 .. $#_ ) {
		print FH $_[$_] or die "print($_[0]): $!";
	}
	close FH or die "close($_[0]): $!";
}

# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
	my $s = shift || 0;
	my $d =()= $s =~ /(\.)/g;
	if ( $d >= 2 ) {
		# Normalise multipart versions
		$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
	}
	$s =~ s/^(\d+)\.?//;
	my $l = $1 || 0;
	my @v = map {
		$_ . '0' x (3 - length $_)
	} $s =~ /(\d{1,3})\D?/g;
	$l = $l . '.' . join '', @v if @v;
	return $l + 0;
}

sub _cmp ($$) {
	_version($_[0]) <=> _version($_[1]);
}

# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
	(
		defined $_[0]
		and
		! ref $_[0]
		and
		$_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
	) ? $_[0] : undef;
}

1;

# Copyright 2008 - 2009 Adam Kennedy.
HTML-Truncate-0.20/lib/0000755000076500000240000000000011226750572014632 5ustar  jinxstaff00000000000000HTML-Truncate-0.20/lib/HTML/0000755000076500000240000000000011226750572015376 5ustar  jinxstaff00000000000000HTML-Truncate-0.20/lib/HTML/Truncate.pm0000644000076500000000000004731311226750362017521 0ustar  jinxwheel00000000000000package HTML::Truncate;

use 5.008;
use strict;
use warnings;
no warnings "uninitialized";

use HTML::TokeParser;
use HTML::Tagset ();
use HTML::Entities ();
use Carp;
use List::Util qw( first );

=head1 NAME

HTML::Truncate - (beta software) truncate HTML by percentage or character count while preserving well-formedness.

=head1 VERSION

0.20

=cut

our $VERSION = "0.20";

=head1 ABSTRACT

When working with text it is common to want to truncate strings to make them fit a desired context. E.g., you might have a menu that is only 100px wide and prefer text doesn't wrap so you'd truncate it around 15-30 characters, depending on preference and typeface size. This is trivial with plain text using L but with HTML it is somewhat difficult because whitespace has fluid significance and open tags that are not properly closed destroy well-formedness and can wreck an entire layout.

L attempts to account for those two problems by padding truncation for spacing and entities and closing any tags that remain open at the point of truncation.

=head1 SYNOPSIS

 use strict;
 use HTML::Truncate;

 my $html = '
We have to test something.
';
 my $readmore = '... [readmore]';

 my $html_truncate = HTML::Truncate->new();
 $html_truncate->chars(20);
 $html_truncate->ellipsis($readmore);
 print $html_truncate->truncate($html);

 # or

 use Encode;
 my $ht = HTML::Truncate->new( utf8_mode => 1,
                               chars => 1_000,
                              );
 print Encode::encode_utf8( $ht->truncate($html) );

=head1 XHTML

This module is designed to work with XHTML-style nested tags. More
below.

=head1 WHITESPACE AND ENTITIES

Repeated natural whitespace (i.e., "\s+" and not "   ") in HTML
-- with rare exception (pre tags or user defined styles) -- is not
meaningful. Therefore it is normalized when truncating. Entities are
also normalized. The following is only counted 14 chars long.

  \n
\nthis     is   ‘text’\n\n

  ^^^^^^^12345----678--9------01234------^^^^^^^^

=head1 METHODS

=over 4

=item B

Can take all the methods as hash style args. "percent" and "chars" are
incompatible so don't use them both. Whichever is set most recently
will erase the other.

 my $ht = HTML::Truncate->new(utf8_mode => 1,
                              chars => 500, # default is 100
                              );

=cut

our %skip = ( head => 1,
              script => 1,
              form => 1,
              iframe => 1,
              object => 1,
              embed => 1,
              title => 1,
              style => 1,
              base => 1,
              link => 1,
              meta => 1,
            );


sub new {
    my $class = shift;

    my $self = bless
    {
        _chars     => 100,
        _percent   => undef,
        _cleanly   => qr/[\s[:punct:]]+\z/,
        _on_space  => undef,
        _utf8_mode => undef,
        _ellipsis  => '…',
        _raw_html  => '',
        _repair    => undef,
        _skip_tags => \%skip,
    }, $class;

    while ( my ( $k, $v ) = splice(@_, 0, 2) )
    {
        croak "No such method or attribute '$k'" unless exists $self->{"_$k"};
        $self->$k($v);
    }
    return $self;
}

=item B

Set/get, true/false. If C is set, C is also
set in the underlying L, entities will be transformed
with L and the default ellipsis will be a
literal ellipsis and not the default of C<…>.

=cut

sub utf8_mode {
    my $self = shift;
    if ( @_ )
    {
        $self->{_utf8_mode} = shift;
        return 1; # say we did it, even if setting untrue value
    }
    else
    {
        return $self->{_utf8_mode};
    }
}

=item B

Set/get. The number of characters remaining after truncation,
B the L.

Entities are counted as single characters. E.g., C<©> is one
character for truncation counts.

Default is "100." Side-effect: clears any L that has been
set.

=cut

sub chars {
    my ( $self, $chars ) = @_;
    return $self->{_chars} unless defined $chars;
    $chars > 0 or croak "You must truncate to at least 1 character";
    $chars =~ /^(?:[1-9][_\d]*|0)$/
        or croak "Specified chars must be a number";
    $self->{_percent} = undef; # no conflict allowed
    $self->{_chars} = $chars;
}

=item B

Set/get. A percentage to keep while truncating the rest. For a
document of 1,000 chars, percent('15%') and chars(150) would be
equivalent. The actual amount of character that the percent represents
cannot be known until the given HTML is parsed.

Side-effect: clears any L that has been set.

=cut

sub percent {
    my ( $self, $percent ) = @_;

    return unless $self->{_percent} or $percent;

    return sprintf("%d%%", 100 * $self->{_percent})
        unless $percent;

    my ( $temp_percent ) = $percent =~ /^(100|[1-9]?[0-9])\%$/;

    $temp_percent and $temp_percent != 0
        or croak "Specified percent is invalid '$percent' -- 1\% - 100\%";

    $self->{_chars} = undef; # no conflict allowed
    $self->{_percent} = $1 / 100;
}

=item B

Set/get. Ellipsis in this case means --

    The omission of a word or phrase necessary for a complete
    syntactical construction but not necessary for understanding.
                         http://www.answers.com/topic/ellipsis

What it will probably mean in most real applications is "read more."
The default is C<…> which if the utf8 flag is true will render
as a literal ellipsis, C.

The reason the default is C<…> and not "..." is this is meant
for use in HTML environments, not plain text, and "..." (dot-dot-dot)
is not typographically correct or equivalent to a real horizontal
ellipsis character.

=cut

sub ellipsis {
    my $self = shift;
    if ( @_ )
    {
        $self->{_ellipsis} = shift;
    }
    elsif ( $self->utf8_mode() )
    {
        return HTML::Entities::decode($self->{_ellipsis});
    }
    else
    {
        return $self->{_ellipsis};
    }
}

=item B

It returns the truncated XHTML if asked for a return value.

 my $truncated = $ht->truncate($html);

It will truncate the string in place if no return value is expected
(L is not defined).

   $ht->truncate($html);
   print $html;

Also can be called with inline arguments-

   print $ht->truncate( $html,
                        $chars_or_percent,
                        $ellipsis );

No arguments are strictly required. Without HTML to operate upon it
returns undef. The two optional arguments may be preset with the
methods L (or L) and L.

Valid nesting of tags is required (alla XHTML). Therefore some old
HTML habits like EpE without a E/pE are not supported
and may cause a fatal error. See L for help with badly formed
HTML.

Certain tags are omitted by default from the truncated output.

=over 4

=item * Skipped tags

These will not be included in truncated output by default.

   ...  
...

    ... 
     

=item * Tags allowed to self-close

See L in L.

=back

=cut

sub _chars_or_percent {
    my ( $self, $which ) = @_;
    if ( $which =~ /\%\z/ )
    {
        $self->percent($which);
    }
    else
    {
        $self->chars($which);
    }
}

sub truncate {
    my $self = shift;
    $self->{_raw_html} = \$_[0];
    shift || return;

    $self->_chars_or_percent(+shift) if @_;
    $self->ellipsis(+shift) if @_;

    my @tag_q;
    my $renew = "";
    my $total = 0;
    my $previous_token;
    my $next_token;

#    my $tmp_ellipsis = $self->ellipsis;
#    $tmp_ellipsis =~ s/<\w[^>]+>//g; # Naive html strip.
#    HTML::Entities::encode($tmp_ellipsis);
    my $chars = $self->{_chars};# + length $tmp_ellipsis;

    my $p = HTML::TokeParser->new( $self->{_raw_html} );
    $p->unbroken_text(1);
    $p->utf8_mode( $self->utf8_mode );

  TOKEN:
    while ( my $token = $p->get_token() )
    {
        my @nexttoken;
        NEXT_TOKEN:
        while ( my $next = $p->get_token() )
        {
            push @nexttoken, $next;
            if ( $next->[0] eq 'S' )
            {
                $next_token = $next;
                last NEXT_TOKEN;
            }
        }
        $p->unget_token(@nexttoken);
        $previous_token = $token if $token->[0] eq 'E';

#        print "   Queue: ", join ":", @tag_q;        print $/;
#        print "Previous: $previous_token->[1]\n";
#        print "      IN: $token->[1]\n";
#        print "    Next: $next_token->[1]\n\n";

        if ( $token->[0] eq 'S' )
        {
            # _callback_for...? 321
            ( my $real_tag = $token->[1] ) =~ s,/\z,,;
            next TOKEN if $self->{_skip_tags}{$real_tag};
            push @tag_q, $token->[1] unless $HTML::Tagset::emptyElement{$real_tag};
            $renew .= $token->[-1];
        }
        elsif ( $token->[0] eq 'E' )
        {
            next TOKEN if $self->{_skip_tags}{$token->[1]};
            my $open  = pop @tag_q;
            my $close = $token->[1];
            unless ( $open eq $close )
            {
                if ( $self->{_repair} )
                {
                    my @unmatched;
                    push @unmatched, $open if $open;
                    while ( my $temp = pop @tag_q )
                    {
                        if ( $temp eq $close )
                        {
                            while ( my $add = shift @unmatched )
                            {
                                $renew .= "";
                            }
                            $renew .= "";
                            next TOKEN;
                        }
                        else
                        {
                            push @unmatched, $temp;
                        }
                    }
                    push @tag_q, reverse @unmatched;
                    next TOKEN;        # silently drop unmatched close tags
                }
                else
                {
                    my $nearby = substr($renew,
                                        length($renew) - 15,
                                        15);
                    croak qq|<$open> closed by  near "$nearby"|;
                }
            }
            $renew .= $token->[-1];
        }
        elsif ( $token->[0] eq 'T' )
        {
            next TOKEN if $token->[2]; # DATA
#            my $txt = HTML::Entities::decode($token->[1]);
            my $txt = $token->[1];
            my $current_length = 0;
            unless ( first { $_ eq 'pre' } @tag_q ) # We're not somewhere inside a 
            {
                $txt =~ s/\s+/ /g;

                if ( ! $HTML::Tagset::isPhraseMarkup{$tag_q[-1]} # in flow
                     and
                     ! $HTML::Tagset::isPhraseMarkup{$previous_token->[1]}
                     )
                {
                    $txt =~ s/\A +//;
                }

                if ( ! $HTML::Tagset::isPhraseMarkup{$tag_q[-1]} # in flow
                     and
                     ! $HTML::Tagset::isPhraseMarkup{$next_token->[1]}
                     )
                {
                    $txt =~ s/ +\z//;
                }
                $current_length = _count_visual_chars($txt);
            }
            else
            {
                $current_length = length($txt);
            }

            $total += $current_length;

            if ( $total >= $chars )
            {
                $total -= $current_length;

                my $chars_to_keep = $chars - $total;
                my $keep = "";
                if ( $self->on_space )
                {
                    ( $keep ) = $txt =~ /\A(.{0,$chars_to_keep}\s?)(?=\s|\z)/;
                    $keep =~ s/\s+\z//;
                }
                else
                {
                    $keep = substr($txt, 0, $chars_to_keep);
                }

                if ( my $cleaner = $self->cleanly )
                {
                    $keep =~ s/$cleaner//;
                }

                if ( $keep )
                {
#                    $renew .= $self->utf8_mode ?
#                        $keep : HTML::Entities::encode($keep);
                    $renew .= $keep;
                }

                $renew .= $self->ellipsis();
                last TOKEN;
            }
            else
            {
                $renew .= $token->[1];
            }
        }
    } #  TOKEN block ends

    $renew .= join('', map {""} reverse @tag_q);

    if ( defined wantarray )
    {
        return $renew;
    }
    else
    {
        ${$self->{_raw_html}} = $renew;
    }
}

=item B

Put one or more new tags into the list of those to be omitted from
truncated output. An example of when you might like to use this is if
you're thumb-nailing articles and they start with C<< 
title
 >>
or such before the article body. The heading level would be absurd
with a list of excerpts so you could drop it completely this way--

 $ht->add_skip_tags( 'h1' );

=cut

sub add_skip_tags {
    my $self = shift;
    for ( @_ )
    {
        croak "Args to add_skip_tags must be scalar tag names, not references"
            if ref $_;
        $self->{_skip_tags}{$_} = 1;
    }
}

=item B

Takes tags out of the current list to be omitted from truncated output.

=cut

sub dont_skip_tags {
    my $self = shift;
    for ( @_ )
    {
        croak "Args to dont_skip_tags must be scalar tag names, not references"
            if ref $_;
        carp "$_ was not set to be skipped"
            unless delete $self->{_skip_tags}{$_};
    }
}

=item B

Set/get, true/false. If true, will attempt to repair unclosed HTML
tags by adding close-tags as late as possible (eg. C<<
foobar >> becomes C<< foobar >>). Unmatched
close tags are dropped (C<< foobar >> becomes C<< foobar >>).

=cut

sub repair {
    my $self = shift;
    if ( @_ )
    {
        $self->{_repair} = shift;
        return 1; # say we did it, even if untrue value
    }
    else
    {
        return $self->{_repair};
    }
}

sub _load_chars_from_percent {
    my $self = shift;
    my $p = HTML::TokeParser->new( $self->{_raw_html} );
    my $txt_length = 0;

  CHARS:
    while ( my $token = $p->get_token )
    {
    # don't check padding b/c we're going by a document average
        next unless $token->[0] eq 'T' and not $token->[2]; # Not data.
        $txt_length += _count_visual_chars( $token->[1] );
    }
    $self->chars( int( $txt_length * $self->{_percent} ) );
}

sub _count_visual_chars { # private function
    my $to_count = HTML::Entities::decode_entities(+shift);
    $to_count =~ s/\s\s+/ /g;
    $to_count =~ s/[^[:print:]]+//g;
#    my $count = () =
#        $to_count =~
#        /\&\#\d+;|\&[[:alpha:]]{2,5};|\S|\s+/g;
#   return $count;
    return length($to_count);
}

# Need to put hooks for these or not? 321
#sub _default_image_callback {
#    sub {
#        '[image]'
#    }
#}

=item B

This will make the truncation back up to the first space it finds so
it doesn't truncate in the the middle of a word. L runs
before L if both are set.

=cut

sub on_space {
    my $self = shift;
    if ( @_ )
    {
        $self->{_on_space} = shift;
        return 1; # say we did it, even if setting untrue value
    }
    else
    {
        return $self->{_on_space};
    }
}


=item B

Set/get -- a regular expression. This is on by default and the default
cleaning regular expression is C. It
will make the truncation strip any trailing spacing and punctuation so
you don't get things like "The End...." or "What? ..." You can cancel
it with C<$ht-Ecleanly(undef)> or provide your own regular
expression.

=cut

sub cleanly {
    my $self = shift;
    if ( @_ )
    {
        $self->{_cleanly} = shift;
        return 1; # say we did it, even if setting untrue value
    }
    else
    {
        return $self->{_cleanly};
    }
}

=back

=head1 COOKBOOK (well, a recipe)

=head2 Template Toolkit filter

For excerpting HTML in your Templates. Note the L which
is set to drop any images from the truncated output.

 use Template;
 use HTML::Truncate;

 my %config =
    (
     FILTERS => {
         truncate_html => [ \&truncate_html_filter_factory, 1 ],
     },
     );

 my $tt = Template->new(\%config) or die $Template::ERROR;

 # ... etc ...

 sub truncate_html_filter_factory {
     my ( $context, $len, $ellipsis ) = @_;
     $len = 32 unless $len;
     $ellipsis = chr(8230) unless defined $ellipsis;
     my $ht = HTML::Truncate->new();
     $ht->add_skip_tags(qw( img ));
     return sub {
         my $html = shift || return '';
         return $ht->truncate( $html, $len, $ellipsis );
     }
 }

Then in your templates you can do things like this:

 [% FOR item IN search_results %]
   

     [% item.title %]

     [% item.body | truncate_html(200) %]
   

 [% END %]

See also L.

=head1 AUTHOR

Ashley Pond V, C<<  >>.

=head1 LIMITATIONS

There may be places where this will break down right now. I'll pad out possible edge cases as I find them or they are sent to me via the CPAN bug ticket system.

=head2 This is not an HTML filter

Although this happens to do some crude HTML filtering to achieve its end, it is not a fully featured filter. If you are looking for one, check out L and L.

=head1 BUGS, FEEDBACK, PATCHES

Please report any bugs or feature requests to
C, or through the web interface at
L. I
will get the ticket, and then you'll automatically be notified of
progress as I make changes.

=head2 TO DO

Write a couple more tests (percent and skip stuff) then take out beta notice. Try to make the 5.6 stuff work without decode...? Try a C method?

Write an L based version to load when possible...? Or make that part of L?

=head1 THANKS TO

Kevin Riggle for the L functionality; patch, Pod, and tests.

Lorenzo Iannuzzi for the L functionality.

=head1 SEE ALSO

L, L, the "truncate" filter in L