--- /dev/null
+Revision history for Perl module Algorithm::Diff.
+
+1.19_02 2006-07-31
+- Fix typo in @EXPORT_OK (s/LCDidx/LCSidx/) (RT 8576)
+- Use 'printf' in example code, not 'sprintf' nor 'sprint' (RT 16067)
+- DiffOld wasn't passing extra arguments to compare routine (RT 20650)
+
+1.19 2004-09-22
+- Added OO interface.
+- Based on Ned's v1.18 (unreleased)
+
+1.13 Sun Mar 24 16:05:32 PST 2002
+- sdiff and traverse_balanced added by Mike Schilli <m@perlmeister.com>.
+
+1.11 Thu Jul 12 12:52:18 PDT 2001
+- Added A_FINISHED and B_FINISHED per docs
+- Called user callback function from keygen properly
+
+1.10 July 7 2000
+- Uploaded to CPAN
+- More optimizations
+- Added Algorithm::DiffOld
+
+1.08
+- Fixed bug with binary search that was making diff output too big
+
+1.06 Wed Jun 14 14:15:31 PDT 2000
+- First CPAN version by NEDKONZ
+- Added MJD's list info to README
+
+1.05 Sun Jun 11 15:17:05 PDT 2000
+- Changed version label string.
+- Put MJD's PPT diff version into this distribution as diffnew.pl
+
+1.04 Added documentation.
+
+1.03 Working version
+
+1.01 First version by Ned Konz.
+- Total re-write to cure problems with memory usage and speed.
+ Now takes only a few seconds and less than three megabytes
+ to compare two 4000-line files.
+
+- Changed optional callback function reference from being equality
+ function to being key (hash) generation function.
+
+0.59 Last version maintained by Mark-Jason Dominus
--- /dev/null
+Changes
+lib/Algorithm/Diff.pm Algorithm::Diff perl module
+lib/Algorithm/DiffOld.pm Algorithm::Diff perl module with old behavior
+Makefile.PL
+MANIFEST
+README
+t/base.t Basic test script
+t/oo.t OO interface test script
+cdiff.pl Context diff utility
+diff.pl Simple Unix diff utility written in Perl
+diffnew.pl Full-featured Unix diff utility written in Perl
+htmldiff.pl Sample using traverse_sequences
+META.yml Module meta-data (added by MakeMaker)
--- /dev/null
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Algorithm-Diff
+version: 1.1902
+version_from: lib/Algorithm/Diff.pm
+installdirs: site
+requires:
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
--- /dev/null
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'Algorithm::Diff',
+ 'VERSION_FROM' => 'lib/Algorithm/Diff.pm', # finds $VERSION
+);
--- /dev/null
+This is a module for computing the difference between two files, two
+strings, or any other two lists of things. It uses an intelligent
+algorithm similar to (or identical to) the one used by the Unix "diff"
+program. It is guaranteed to find the *smallest possible* set of
+differences.
+
+This package contains a few parts.
+
+Algorithm::Diff is the module that contains several interfaces for which
+computing the differences betwen two lists.
+
+The several "diff" programs also included in this package use
+Algorithm::Diff to find the differences and then they format the output.
+
+Algorithm::Diff also includes some other useful functions such as "LCS",
+which computes the longest common subsequence of two lists.
+
+A::D is suitable for many uses. You can use it for finding the smallest
+set of differences between two strings, or for computing the most
+efficient way to update the screen if you were replacing "curses".
+
+Algorithm::DiffOld is a previous version of the module which is included
+primarilly for those wanting to use a custom comparison function rather
+than a key generating function (and who don't mind the significant
+performance penalty of perhaps 20-fold).
+
+diff.pl implements a "diff" in Perl that is as simple as (was
+previously) possible so that you can see how it works. The output
+format is not compatible with regular "diff". It needs to be
+reimplemented using the OO interface to greatly simplify the code.
+
+diffnew.pl implements a "diff" in Perl with full bells and whistles. By
+Mark-Jason, with code from cdiff.pl included.
+
+cdiff.pl implements "diff" that generates real context diffs in either
+traditional format or GNU unified format. Original contextless
+"context" diff supplied by Christian Murphy. Modifications to make it
+into a real full-featured diff with -c and -u options supplied by Amir
+D. Karger.
+
+Yes, you can use this program to generate patches.
+
+OTHER RESOURCES
+
+"Longest Common Subsequences", at
+http://www.ics.uci.edu/~eppstein/161/960229.html
+
+This code was adapted from the Smalltalk code of Mario Wolczko
+<mario@wolczko.com>, which is available at
+ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
+
+THANKS SECTION
+
+Thanks to Ned Konz's for rewriting the module to greatly improve
+performance, for maintaining it over the years, and for readilly handing
+it over to me so I could plod along with my improvements.
+
+(From Ned Konz's earlier versions):
+
+Thanks to Mark-Jason Dominus for doing the original Perl version and
+maintaining it over the last couple of years. Mark-Jason has been a huge
+contributor to the Perl community and CPAN; it's because of people like
+him that Perl has become a success.
+
+Thanks to Mario Wolczko <mario@wolczko.com> for writing and making
+publicly available his Smalltalk version of diff, which this Perl
+version is heavily based on.
+
+Thanks to Mike Schilli <m@perlmeister.com> for writing sdiff and
+traverse_balanced and making them available for the Algorithm::Diff
+distribution.
+
+(From Mark-Jason Dominus' earlier versions):
+
+Huge thanks to Amir Karger for adding full context diff supprt to
+"cdiff.pl", and then for waiting patiently for five months while I let
+it sit in a closet and didn't release it. Thank you thank you thank
+you, Amir!
+
+Thanks to Christian Murphy for adding the first context diff format
+support to "cdiff.pl".
--- /dev/null
+#!/usr/bin/perl -w
+#
+# `Diff' program in Perl
+# Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# Altered to output in `context diff' format (but without context)
+# September 1998 Christian Murphy (cpm@muc.de)
+#
+# Command-line arguments and context lines feature added
+# September 1998 Amir D. Karger (karger@bead.aecom.yu.edu)
+#
+# In this file, "item" usually means "line of text", and "item number" usually
+# means "line number". But theoretically the code could be used more generally
+use strict;
+
+use Algorithm::Diff qw(diff);
+use File::stat;
+use vars qw ($opt_C $opt_c $opt_u $opt_U);
+use Getopt::Std;
+
+my $usage = << "ENDUSAGE";
+Usage: $0 [{-c | -u}] [{-C | -U} lines] oldfile newfile
+ -c will do a context diff with 3 lines of context
+ -C will do a context diff with 'lines' lines of context
+ -u will do a unified diff with 3 lines of context
+ -U will do a unified diff with 'lines' lines of context
+ENDUSAGE
+
+getopts('U:C:cu') or bag("$usage");
+bag("$usage") unless @ARGV == 2;
+my ($file1, $file2) = @ARGV;
+if (defined $opt_C || defined $opt_c) {
+ $opt_c = ""; # -c on if -C given on command line
+ $opt_u = undef;
+} elsif (defined $opt_U || defined $opt_u) {
+ $opt_u = ""; # -u on if -U given on command line
+ $opt_c = undef;
+} else {
+ $opt_c = ""; # by default, do context diff, not old diff
+}
+
+my ($char1, $char2); # string to print before file names
+my $Context_Lines; # lines of context to print
+if (defined $opt_c) {
+ $Context_Lines = defined $opt_C ? $opt_C : 3;
+ $char1 = '*' x 3; $char2 = '-' x 3;
+} elsif (defined $opt_u) {
+ $Context_Lines = defined $opt_U ? $opt_U : 3;
+ $char1 = '-' x 3; $char2 = '+' x 3;
+}
+
+# After we've read up to a certain point in each file, the number of items
+# we've read from each file will differ by $FLD (could be 0)
+my $File_Length_Difference = 0;
+
+open (F1, $file1) or bag("Couldn't open $file1: $!");
+open (F2, $file2) or bag("Couldn't open $file2: $!");
+my (@f1, @f2);
+chomp(@f1 = <F1>);
+close F1;
+chomp(@f2 = <F2>);
+close F2;
+
+# diff yields lots of pieces, each of which is basically a Block object
+my $diffs = diff(\@f1, \@f2);
+exit 0 unless @$diffs;
+
+my $st = stat($file1);
+print "$char1 $file1\t", scalar localtime($st->mtime), "\n";
+$st = stat($file2);
+print "$char2 $file2\t", scalar localtime($st->mtime), "\n";
+
+my ($hunk,$oldhunk);
+# Loop over hunks. If a hunk overlaps with the last hunk, join them.
+# Otherwise, print out the old one.
+foreach my $piece (@$diffs) {
+ $hunk = new Hunk ($piece, $Context_Lines);
+ next unless $oldhunk;
+
+ if ($hunk->does_overlap($oldhunk)) {
+ $hunk->prepend_hunk($oldhunk);
+ } else {
+ $oldhunk->output_diff(\@f1, \@f2);
+ }
+
+} continue {
+ $oldhunk = $hunk;
+}
+
+# print the last hunk
+$oldhunk->output_diff(\@f1, \@f2);
+exit 1;
+# END MAIN PROGRAM
+
+sub bag {
+ my $msg = shift;
+ $msg .= "\n";
+ warn $msg;
+ exit 2;
+}
+
+# Package Hunk. A Hunk is a group of Blocks which overlap because of the
+# context surrounding each block. (So if we're not using context, every
+# hunk will contain one block.)
+{
+package Hunk;
+
+sub new {
+# Arg1 is output from &LCS::diff (which corresponds to one Block)
+# Arg2 is the number of items (lines, e.g.,) of context around each block
+#
+# This subroutine changes $File_Length_Difference
+#
+# Fields in a Hunk:
+# blocks - a list of Block objects
+# start - index in file 1 where first block of the hunk starts
+# end - index in file 1 where last block of the hunk ends
+#
+# Variables:
+# before_diff - how much longer file 2 is than file 1 due to all hunks
+# until but NOT including this one
+# after_diff - difference due to all hunks including this one
+ my ($class, $piece, $context_items) = @_;
+
+ my $block = new Block ($piece); # this modifies $FLD!
+
+ my $before_diff = $File_Length_Difference; # BEFORE this hunk
+ my $after_diff = $before_diff + $block->{"length_diff"};
+ $File_Length_Difference += $block->{"length_diff"};
+
+ # @remove_array and @insert_array hold the items to insert and remove
+ # Save the start & beginning of each array. If the array doesn't exist
+ # though (e.g., we're only adding items in this block), then figure
+ # out the line number based on the line number of the other file and
+ # the current difference in file lenghts
+ my @remove_array = $block->remove;
+ my @insert_array = $block->insert;
+ my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
+ $a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
+ $a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
+ $b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
+ $b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;
+
+ $start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
+ $end1 = $a2 == -1 ? $b2 - $after_diff : $a2;
+ $start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
+ $end2 = $b2 == -1 ? $a2 + $after_diff : $b2;
+
+ # At first, a hunk will have just one Block in it
+ my $hunk = {
+ "start1" => $start1,
+ "start2" => $start2,
+ "end1" => $end1,
+ "end2" => $end2,
+ "blocks" => [$block],
+ };
+ bless $hunk, $class;
+
+ $hunk->flag_context($context_items);
+
+ return $hunk;
+}
+
+# Change the "start" and "end" fields to note that context should be added
+# to this hunk
+sub flag_context {
+ my ($hunk, $context_items) = @_;
+ return unless $context_items; # no context
+
+ # add context before
+ my $start1 = $hunk->{"start1"};
+ my $num_added = $context_items > $start1 ? $start1 : $context_items;
+ $hunk->{"start1"} -= $num_added;
+ $hunk->{"start2"} -= $num_added;
+
+ # context after
+ my $end1 = $hunk->{"end1"};
+ $num_added = ($end1+$context_items > $#f1) ?
+ $#f1 - $end1 :
+ $context_items;
+ $hunk->{"end1"} += $num_added;
+ $hunk->{"end2"} += $num_added;
+}
+
+# Is there an overlap between hunk arg0 and old hunk arg1?
+# Note: if end of old hunk is one less than beginning of second, they overlap
+sub does_overlap {
+ my ($hunk, $oldhunk) = @_;
+ return "" unless $oldhunk; # first time through, $oldhunk is empty
+
+ # Do I actually need to test both?
+ return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
+ $hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
+}
+
+# Prepend hunk arg1 to hunk arg0
+# Note that arg1 isn't updated! Only arg0 is.
+sub prepend_hunk {
+ my ($hunk, $oldhunk) = @_;
+
+ $hunk->{"start1"} = $oldhunk->{"start1"};
+ $hunk->{"start2"} = $oldhunk->{"start2"};
+
+ unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
+}
+
+
+# DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...
+sub output_diff {
+ if (defined $main::opt_u) {&output_unified_diff(@_)}
+ elsif (defined $main::opt_c) {&output_context_diff(@_)}
+ else {die "unknown diff"}
+}
+
+sub output_unified_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ # Calculate item number range.
+ my $range1 = $hunk->unified_range(1);
+ my $range2 = $hunk->unified_range(2);
+ print "@@ -$range1 +$range2 @@\n";
+
+ # Outlist starts containing the hunk of file 1.
+ # Removing an item just means putting a '-' in front of it.
+ # Inserting an item requires getting it from file2 and splicing it in.
+ # We splice in $num_added items. Remove blocks use $num_added because
+ # splicing changed the length of outlist.
+ # We remove $num_removed items. Insert blocks use $num_removed because
+ # their item numbers---corresponding to positions in file *2*--- don't take
+ # removed items into account.
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ my ($num_added, $num_removed) = (0,0);
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+
+ foreach my $block (@{$hunk->{"blocks"}}) {
+ foreach my $item ($block->remove) {
+ my $op = $item->{"sign"}; # -
+ my $offset = $item->{"item_no"} - $low + $num_added;
+ $outlist[$offset] =~ s/^ /$op/;
+ $num_removed++;
+ }
+ foreach my $item ($block->insert) {
+ my $op = $item->{"sign"}; # +
+ my $i = $item->{"item_no"};
+ my $offset = $i - $hunk->{"start2"} + $num_removed;
+ splice(@outlist,$offset,0,"$op$$fileref2[$i]");
+ $num_added++;
+ }
+ }
+
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+
+}
+
+sub output_context_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ print "***************\n";
+ # Calculate item number range.
+ my $range1 = $hunk->context_range(1);
+ my $range2 = $hunk->context_range(2);
+
+ # Print out file 1 part for each block in context diff format if there are
+ # any blocks that remove items
+ print "*** $range1 ****\n";
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ if (@blocklist = grep {$_->remove} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # - or !
+ foreach my $item ($block->remove) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+
+ print "--- $range2 ----\n";
+ $low = $hunk->{"start2"};
+ $hi = $hunk->{"end2"};
+ if (@blocklist = grep {$_->insert} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref2[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # + or !
+ foreach my $item ($block->insert) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+}
+
+sub context_range {
+# Generate a range of item numbers to print. Only print 1 number if the range
+# has only one item in it. Otherwise, it's 'start,end'
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $range = ($start < $end) ? "$start,$end" : $end;
+ return $range;
+}
+
+sub unified_range {
+# Generate a range of item numbers to print for unified diff
+# Print number where block starts, followed by number of lines in the block
+# (don't print number of lines if it's 1)
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $length = $end - $start + 1;
+ my $first = $length < 2 ? $end : $start; # strange, but correct...
+ my $range = $length== 1 ? $first : "$first,$length";
+ return $range;
+}
+} # end Package Hunk
+
+# Package Block. A block is an operation removing, adding, or changing
+# a group of items. Basically, this is just a list of changes, where each
+# change adds or deletes a single item.
+# (Change could be a separate class, but it didn't seem worth it)
+{
+package Block;
+sub new {
+# Input is a chunk from &Algorithm::LCS::diff
+# Fields in a block:
+# length_diff - how much longer file 2 is than file 1 due to this block
+# Each change has:
+# sign - '+' for insert, '-' for remove
+# item_no - number of the item in the file (e.g., line number)
+# We don't bother storing the text of the item
+#
+ my ($class,$chunk) = @_;
+ my @changes = ();
+
+# This just turns each change into a hash.
+ foreach my $item (@$chunk) {
+ my ($sign, $item_no, $text) = @$item;
+ my $hashref = {"sign" => $sign, "item_no" => $item_no};
+ push @changes, $hashref;
+ }
+
+ my $block = { "changes" => \@changes };
+ bless $block, $class;
+
+ $block->{"length_diff"} = $block->insert - $block->remove;
+ return $block;
+}
+
+
+# LOW LEVEL FUNCTIONS
+sub op {
+# what kind of block is this?
+ my $block = shift;
+ my $insert = $block->insert;
+ my $remove = $block->remove;
+
+ $remove && $insert and return '!';
+ $remove and return '-';
+ $insert and return '+';
+ warn "unknown block type";
+ return '^'; # context block
+}
+
+# Returns a list of the changes in this block that remove items
+# (or the number of removals if called in scalar context)
+sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }
+
+# Returns a list of the changes in this block that insert items
+sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }
+
+} # end of package Block
+
--- /dev/null
+libalgorithm-diff-perl (1.19.02-1maemo1) fremantle; urgency=low
+
+ * New Maemo packaging
+
+ -- Nito Martinez <Nito@Qindel.ES> Wed, 14 Apr 2010 07:09:51 +0100
+
+
+llibalgorithm-diff-perl (1.19.02-1) unstable; urgency=low
+
+ * Take over for the Debian Perl Group on maintainer's request
+ (http://lists.debian.org/debian-perl/2008/03/msg00055.html)
+ * debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser
+ field (source stanza); Homepage field (source stanza). Changed:
+ Maintainer set to Debian Perl Group <pkg-perl-
+ maintainers@lists.alioth.debian.org> (was: Florian Weimer
+ <fw@deneb.enyo.de>).
+ * debian/watch: add uversionmangle.
+
+ * New upstream release (includes both patches from earlier Debian
+ versions: "export LCSidx" and "typo in example").
+ * Set Standards-Version to 3.7.3 (no changes).
+ * Set debhelper compatibility level to 5 (and add debian/compat).
+ * debian/control:
+ - add /me to Uploaders
+ - remove Section and Priority from binary package stanza
+ - move debhelper to Build-Depends
+ * Remove debian/libalgorithm-diff-perl.dirs.
+ * debian/rules: update based on dh-make-perl's templates.
+ * debian/copyright: mention Debian Perl Group, add additional copyright
+ holder, use specific download URL instead of pointing to CPAN at large.
+
+ -- gregor herrmann <gregor+debian@comodo.priv.at> Sun, 09 Mar 2008 23:20:32 +0100
+
+libalgorithm-diff-perl (1.19.01-2) unstable; urgency=low
+
+ * Update debian/watch to match only relevant .tar.gz files.
+ * Apply patch from Martin Zobel-Helas to properly export LCSidx.
+ Closes: #341227.
+ * Fix typo in Diff.pm example (upstream bug 16067).
+ * Bump Standards-Version to 3.6.2.1. No changes necessary.
+
+ -- Florian Weimer <fw@deneb.enyo.de> Tue, 29 Nov 2005 15:05:46 +0100
+
+libalgorithm-diff-perl (1.19.01-1) unstable; urgency=low
+
+ * New upstream release.
+ * Adopt the package. Closes: #274119.
+
+ -- Florian Weimer <fw@deneb.enyo.de> Fri, 1 Oct 2004 10:52:39 +0200
+
+libalgorithm-diff-perl (1.15-5) unstable; urgency=low
+
+ * Rebuild so that .arch-ids/ files don't get included in the package.
+
+ -- Michael Alan Dorman <mdorman@debian.org> Tue, 23 Dec 2003 19:37:44 -0500
+
+libalgorithm-diff-perl (1.15-4) unstable; urgency=low
+
+ * Update standards version
+ * Remove examples file, since examples are being dealt with in a
+ different manner
+
+ -- Michael Alan Dorman <mdorman@mallet-assembly.org> Fri, 19 Dec 2003 14:43:54 -0500
+
+libalgorithm-diff-perl (1.15-3) unstable; urgency=low
+
+ * Fix override disparity.
+
+ -- Michael Alan Dorman <mdorman@debian.org> Fri, 15 Aug 2003 18:40:06 -0400
+
+libalgorithm-diff-perl (1.15-2) unstable; urgency=low
+
+ * Fix some problems with the copyright statement. (closes: Bug#157538)
+
+ -- Michael Alan Dorman <mdorman@debian.org> Sat, 15 Mar 2003 14:12:36 -0500
+
+libalgorithm-diff-perl (1.15-1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- Michael Alan Dorman <mdorman@debian.org> Sun, 7 Jul 2002 16:04:53 -0400
+
+libalgorithm-diff-perl (1.11a-1) unstable; urgency=low
+
+ * New upstream version (closes: bug#128190)
+
+ -- Michael Alan Dorman <mdorman@debian.org> Tue, 22 Jan 2002 13:12:31 -0500
+
+libalgorithm-diff-perl (1.10-3) unstable; urgency=low
+
+ * Whooops! My package somehow got screwed up, with the newer version of
+ the module appended to the text of the older module. Fixed.
+
+ -- Michael Alan Dorman <mdorman@debian.org> Sun, 15 Apr 2001 21:11:44 -0400
+
+libalgorithm-diff-perl (1.10-2) unstable; urgency=low
+
+ * Add build-depends.
+ * Many edits to rules file.
+
+ -- Michael Alan Dorman <mdorman@debian.org> Sun, 15 Apr 2001 14:39:34 -0400
+
+libalgorithm-diff-perl (1.10-1) unstable; urgency=low
+
+ * New upstream release
+
+ -- Michael Alan Dorman <mdorman@debian.org> Wed, 20 Sep 2000 15:31:15 -0400
+
+libalgorithm-diff-perl (0.59-1) unstable; urgency=low
+
+ * Initial packaging
+
+ -- Michael Alan Dorman <mdorman@debian.org> Sat, 8 Apr 2000 17:55:34 -0400
--- /dev/null
+Source: libalgorithm-diff-perl
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: gregor herrmann <gregor+debian@comodo.priv.at>
+Priority: optional
+Section: perl
+Build-Depends: debhelper (>= 5)
+Build-Depends-Indep: perl (>= 5.6.0-16)
+Standards-Version: 3.7.3
+Homepage: http://search.cpan.org/dist/Algorithm-Diff/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libalgorithm-diff-perl/
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libalgorithm-diff-perl/
+
+Package: libalgorithm-diff-perl
+Architecture: all
+Depends: ${perl:Depends}
+Description: a perl library for finding Longest Common Sequences in text
+ This module provides routines that allow one to analyze text in perl
+ arrays to produce a Longest Common Sequence, which can in turn be
+ used to produce the same information as the common Unix tool 'diff'
--- /dev/null
+This is Debian GNU/Linux's prepackaged version of Algorithm::Diff This
+is a perl library for finding Longest Common Sequences on textual
+information.
+
+Michael Alan Dorman originally built this package. It was later maintained
+by Florian Weimer <fw@deneb.enyo.de> and is now taken care of by the Debian
+Perl Group.
+
+The original sources should always be available from the Comprehensive
+Perl Archive Network (CPAN): http://www.cpan.org/modules/by-module/Algorithm/
+
+The only change for the Debian package was the addition of the debian/
+files.
+
+The Algorithm::Diff copyright is as follows:
+
+| Parts Copyright (c) 2000-2004 Ned Konz. All rights reserved.
+| Parts by Tye McQueen.
+|
+| This program is free software; you can redistribute it and/or modify it
+| under the same terms as Perl.
+
+Perl is distributed under your choice of the GNU General Public License or
+the Artistic License. On Debian GNU/Linux systems, the complete text of the
+GNU General Public License can be found in `/usr/share/common-licenses/GPL'
+and the Artistic Licence in `/usr/share/common-licenses/Artistic'.
+
+cdiff.pl, diff.pl, diffnw.pl:
+ Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com)
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl.
--- /dev/null
+#!/usr/bin/make -f
+# This debian/rules file is provided as a template for normal perl
+# packages. It was created by Marc Brockschmidt <marc@dch-faq.de> for
+# the Debian Perl Group (http://pkg-perl.alioth.debian.org/) but may
+# be used freely wherever it is useful.
+
+# Uncomment this to turn on verbose mode.
+#export DH_VERBOSE=1
+
+# If set to a true value then MakeMaker's prompt function will
+# always return the default without waiting for user input.
+export PERL_MM_USE_DEFAULT=1
+
+PACKAGE=$(shell dh_listpackages)
+
+ifndef PERL
+PERL = /usr/bin/perl
+endif
+
+TMP =$(CURDIR)/debian/$(PACKAGE)
+
+build: build-stamp
+build-stamp:
+ dh_testdir
+
+ $(PERL) Makefile.PL INSTALLDIRS=vendor
+ $(MAKE)
+ $(MAKE) test
+
+ touch $@
+
+clean:
+ dh_testdir
+ dh_testroot
+
+ dh_clean build-stamp install-stamp
+ [ ! -f Makefile ] || $(MAKE) realclean
+
+install: install-stamp
+install-stamp: build-stamp
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+
+ $(MAKE) install DESTDIR=$(TMP) PREFIX=/usr
+
+ # remove scripts, we install them as examples later
+ $(RM) -fv $(TMP)/usr/share/perl5/Algorithm/*.pl
+
+ [ ! -d $(TMP)/usr/lib/perl5 ] || rmdir --ignore-fail-on-non-empty --parents --verbose $(TMP)/usr/lib/perl5
+
+ touch $@
+
+binary-arch:
+# We have nothing to do here for an architecture-independent package
+
+binary-indep: build install
+ dh_testdir
+ dh_testroot
+ dh_installexamples *.pl
+ dh_installdocs README
+ dh_installchangelogs Changes
+ dh_perl
+ dh_compress
+ dh_fixperms
+ dh_installdeb
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+source diff:
+ @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install
--- /dev/null
+version=3
+# http://search.cpan.org/dist/Algorithm-Diff/ doesn't carry current versions
+options=uversionmangle=s/\.(\d\d)(\d\d)/.$1.$2/ \
+http://www.cpan.org/modules/by-module/Algorithm/Algorithm-Diff-([^-]+)\.tar\.gz
--- /dev/null
+#!/usr/bin/perl
+#
+# `Diff' program in Perl
+# Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+
+use Algorithm::Diff qw(diff);
+
+bag("Usage: $0 oldfile newfile") unless @ARGV == 2;
+
+my ($file1, $file2) = @ARGV;
+
+# -f $file1 or bag("$file1: not a regular file");
+# -f $file2 or bag("$file2: not a regular file");
+
+-T $file1 or bag("$file1: binary");
+-T $file2 or bag("$file2: binary");
+
+open (F1, $file1) or bag("Couldn't open $file1: $!");
+open (F2, $file2) or bag("Couldn't open $file2: $!");
+chomp(@f1 = <F1>);
+close F1;
+chomp(@f2 = <F2>);
+close F2;
+
+$diffs = diff(\@f1, \@f2);
+exit 0 unless @$diffs;
+
+foreach $chunk (@$diffs) {
+
+ foreach $line (@$chunk) {
+ my ($sign, $lineno, $text) = @$line;
+ printf "%4d$sign %s\n", $lineno+1, $text;
+ }
+ print "--------\n";
+}
+exit 1;
+
+sub bag {
+ my $msg = shift;
+ $msg .= "\n";
+ warn $msg;
+ exit 2;
+}
--- /dev/null
+#!/usr/bin/perl
+#
+# `Diff' program in Perl
+# Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com)
+#
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+#
+# Altered to output in `context diff' format (but without context)
+# September 1998 Christian Murphy (cpm@muc.de)
+#
+# Context lines feature added
+# Unified, "Old" (Standard UNIX), Ed diff added September 1998
+# Reverse_Ed (-f option) added March 1999
+# Amir D. Karger (karger@bead.aecom.yu.edu)
+#
+# Modular functions integrated into program
+# February 1999 M-J. Dominus (mjd-perl-diff@plover.com)
+#
+# In this file, "item" usually means "line of text", and "item number" usually
+# means "line number". But theoretically the code could be used more generally
+use strict;
+use Algorithm::Diff qw(diff);
+
+# GLOBAL VARIABLES ####
+# After we've read up to a certain point in each file, the number of items
+# we've read from each file will differ by $FLD (could be 0)
+my $File_Length_Difference = 0;
+
+#ed diff outputs hunks *backwards*, so we need to save hunks when doing ed diff
+my @Ed_Hunks = ();
+########################
+
+my $usage = << "ENDUSAGE";
+Usage: $0 [{-c | -C lines -e | -f | -u | -U lines}] oldfile newfile
+ -c do a context diff with 3 lines of context
+ -C do a context diff with 'lines' lines of context (implies -c)
+ -e create a script for the ed editor to change oldfile to newfile
+ -f like -e but in reverse order
+ -u do a unified diff with 3 lines of context
+ -U do a unified diff with 'lines' lines of context (implies -u)
+ -q report only whether or not the files differ
+
+By default it will do an "old-style" diff, with output like UNIX diff
+ENDUSAGE
+
+my $Context_Lines = 0; # lines of context to print. 0 for old-style diff
+my $Diff_Type = "OLD"; # by default, do standard UNIX diff
+my ($opt_c, $opt_u, $opt_e, $opt_f, $opt_q);
+while ($ARGV[0] =~ /^-/) {
+ my $opt = shift;
+ last if $opt eq '--';
+ if ($opt =~ /^-C(.*)/) {
+ $Context_Lines = $1 || shift;
+ $opt_c = 1;
+ $Diff_Type = "CONTEXT";
+ } elsif ($opt =~ /^-c$/) {
+ $Context_Lines = 3;
+ $opt_c = 1;
+ $Diff_Type = "CONTEXT";
+ } elsif ($opt =~ /^-e$/) {
+ $opt_e = 1;
+ $Diff_Type = "ED";
+ } elsif ($opt =~ /^-f$/) {
+ $opt_f = 1;
+ $Diff_Type = "REVERSE_ED";
+ } elsif ($opt =~ /^-U(.*)$/) {
+ $Context_Lines = $1 || shift;
+ $opt_u = 1;
+ $Diff_Type = "UNIFIED";
+ } elsif ($opt =~ /^-u$/) {
+ $Context_Lines = 3;
+ $opt_u = 1;
+ $Diff_Type = "UNIFIED";
+ } elsif ($opt =~ /^-q$/) {
+ $Context_Lines = 0;
+ $opt_q = 1;
+ $opt_e = 1;
+ $Diff_Type = "ED";
+ } else {
+ $opt =~ s/^-//;
+ bag("Illegal option -- $opt");
+ }
+}
+
+if ($opt_q and grep($_,($opt_c, $opt_f, $opt_u)) > 1) {
+ bag("Combining -q with other options is nonsensical");
+}
+
+if (grep($_,($opt_c, $opt_e, $opt_f, $opt_u)) > 1) {
+ bag("Only one of -c, -u, -f, -e are allowed");
+}
+
+bag($usage) unless @ARGV == 2;
+
+######## DO THE DIFF!
+my ($file1, $file2) = @ARGV;
+
+my ($char1, $char2); # string to print before file names
+if ($Diff_Type eq "CONTEXT") {
+ $char1 = '*' x 3; $char2 = '-' x 3;
+} elsif ($Diff_Type eq "UNIFIED") {
+ $char1 = '-' x 3; $char2 = '+' x 3;
+}
+
+open (F1, $file1) or bag("Couldn't open $file1: $!");
+open (F2, $file2) or bag("Couldn't open $file2: $!");
+my (@f1, @f2);
+chomp(@f1 = <F1>);
+close F1;
+chomp(@f2 = <F2>);
+close F2;
+
+# diff yields lots of pieces, each of which is basically a Block object
+my $diffs = diff(\@f1, \@f2);
+exit 0 unless @$diffs;
+
+if ($opt_q and @$diffs) {
+ print "Files $file1 and $file2 differ\n";
+ exit 1;
+}
+
+if ($Diff_Type =~ /UNIFIED|CONTEXT/) {
+ my @st = stat($file1);
+ my $MTIME = 9;
+ print "$char1 $file1\t", scalar localtime($st[$MTIME]), "\n";
+ @st = stat($file2);
+ print "$char2 $file2\t", scalar localtime($st[$MTIME]), "\n";
+}
+
+my ($hunk,$oldhunk);
+# Loop over hunks. If a hunk overlaps with the last hunk, join them.
+# Otherwise, print out the old one.
+foreach my $piece (@$diffs) {
+ $hunk = new Hunk ($piece, $Context_Lines);
+ next unless $oldhunk; # first time through
+
+ # Don't need to check for overlap if blocks have no context lines
+ if ($Context_Lines && $hunk->does_overlap($oldhunk)) {
+ $hunk->prepend_hunk($oldhunk);
+ } else {
+ $oldhunk->output_diff(\@f1, \@f2, $Diff_Type);
+ }
+
+} continue {
+ $oldhunk = $hunk;
+}
+
+# print the last hunk
+$oldhunk->output_diff(\@f1, \@f2, $Diff_Type);
+
+# Print hunks backwards if we're doing an ed diff
+map {$_->output_ed_diff(\@f1, \@f2, $Diff_Type)} @Ed_Hunks if @Ed_Hunks;
+
+exit 1;
+# END MAIN PROGRAM
+
+sub bag {
+ my $msg = shift;
+ $msg .= "\n";
+ warn $msg;
+ exit 2;
+}
+
+########
+# Package Hunk. A Hunk is a group of Blocks which overlap because of the
+# context surrounding each block. (So if we're not using context, every
+# hunk will contain one block.)
+{
+package Hunk;
+
+sub new {
+# Arg1 is output from &LCS::diff (which corresponds to one Block)
+# Arg2 is the number of items (lines, e.g.,) of context around each block
+#
+# This subroutine changes $File_Length_Difference
+#
+# Fields in a Hunk:
+# blocks - a list of Block objects
+# start - index in file 1 where first block of the hunk starts
+# end - index in file 1 where last block of the hunk ends
+#
+# Variables:
+# before_diff - how much longer file 2 is than file 1 due to all hunks
+# until but NOT including this one
+# after_diff - difference due to all hunks including this one
+ my ($class, $piece, $context_items) = @_;
+
+ my $block = new Block ($piece); # this modifies $FLD!
+
+ my $before_diff = $File_Length_Difference; # BEFORE this hunk
+ my $after_diff = $before_diff + $block->{"length_diff"};
+ $File_Length_Difference += $block->{"length_diff"};
+
+ # @remove_array and @insert_array hold the items to insert and remove
+ # Save the start & beginning of each array. If the array doesn't exist
+ # though (e.g., we're only adding items in this block), then figure
+ # out the line number based on the line number of the other file and
+ # the current difference in file lenghts
+ my @remove_array = $block->remove;
+ my @insert_array = $block->insert;
+ my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
+ $a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
+ $a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
+ $b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
+ $b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;
+
+ $start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
+ $end1 = $a2 == -1 ? $b2 - $after_diff : $a2;
+ $start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
+ $end2 = $b2 == -1 ? $a2 + $after_diff : $b2;
+
+ # At first, a hunk will have just one Block in it
+ my $hunk = {
+ "start1" => $start1,
+ "start2" => $start2,
+ "end1" => $end1,
+ "end2" => $end2,
+ "blocks" => [$block],
+ };
+ bless $hunk, $class;
+
+ $hunk->flag_context($context_items);
+
+ return $hunk;
+}
+
+# Change the "start" and "end" fields to note that context should be added
+# to this hunk
+sub flag_context {
+ my ($hunk, $context_items) = @_;
+ return unless $context_items; # no context
+
+ # add context before
+ my $start1 = $hunk->{"start1"};
+ my $num_added = $context_items > $start1 ? $start1 : $context_items;
+ $hunk->{"start1"} -= $num_added;
+ $hunk->{"start2"} -= $num_added;
+
+ # context after
+ my $end1 = $hunk->{"end1"};
+ $num_added = ($end1+$context_items > $#f1) ?
+ $#f1 - $end1 :
+ $context_items;
+ $hunk->{"end1"} += $num_added;
+ $hunk->{"end2"} += $num_added;
+}
+
+# Is there an overlap between hunk arg0 and old hunk arg1?
+# Note: if end of old hunk is one less than beginning of second, they overlap
+sub does_overlap {
+ my ($hunk, $oldhunk) = @_;
+ return "" unless $oldhunk; # first time through, $oldhunk is empty
+
+ # Do I actually need to test both?
+ return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
+ $hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
+}
+
+# Prepend hunk arg1 to hunk arg0
+# Note that arg1 isn't updated! Only arg0 is.
+sub prepend_hunk {
+ my ($hunk, $oldhunk) = @_;
+
+ $hunk->{"start1"} = $oldhunk->{"start1"};
+ $hunk->{"start2"} = $oldhunk->{"start2"};
+
+ unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
+}
+
+
+# DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...
+sub output_diff {
+# First arg is the current hunk of course
+# Next args are refs to the files
+# last arg is type of diff
+ my $diff_type = $_[-1];
+ my %funchash = ("OLD" => \&output_old_diff,
+ "CONTEXT" => \&output_context_diff,
+ "ED" => \&store_ed_diff,
+ "REVERSE_ED" => \&output_ed_diff,
+ "UNIFIED" => \&output_unified_diff,
+ );
+ if (exists $funchash{$diff_type}) {
+ &{$funchash{$diff_type}}(@_); # pass in all args
+ } else {die "unknown diff type $diff_type"}
+}
+
+sub output_old_diff {
+# Note that an old diff can't have any context. Therefore, we know that
+# there's only one block in the hunk.
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');
+
+ my @blocklist = @{$hunk->{"blocks"}};
+ warn ("Expecting one block in an old diff hunk!") if scalar @blocklist != 1;
+ my $block = $blocklist[0];
+ my $op = $block->op; # +, -, or !
+
+ # Calculate item number range.
+ # old diff range is just like a context diff range, except the ranges
+ # are on one line with the action between them.
+ my $range1 = $hunk->context_range(1);
+ my $range2 = $hunk->context_range(2);
+ my $action = $op_hash{$op} || warn "unknown op $op";
+ print "$range1$action$range2\n";
+
+ # If removing anything, just print out all the remove lines in the hunk
+ # which is just all the remove lines in the block
+ if ($block->remove) {
+ my @outlist = @$fileref1[$hunk->{"start1"}..$hunk->{"end1"}];
+ map {$_ = "< $_\n"} @outlist; # all lines will be '< text\n'
+ print @outlist;
+ }
+
+ print "---\n" if $op eq '!'; # only if inserting and removing
+ if ($block->insert) {
+ my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
+ map {$_ = "> $_\n"} @outlist; # all lines will be '> text\n'
+ print @outlist;
+ }
+}
+
+sub output_unified_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ # Calculate item number range.
+ my $range1 = $hunk->unified_range(1);
+ my $range2 = $hunk->unified_range(2);
+ print "@@ -$range1 +$range2 @@\n";
+
+ # Outlist starts containing the hunk of file 1.
+ # Removing an item just means putting a '-' in front of it.
+ # Inserting an item requires getting it from file2 and splicing it in.
+ # We splice in $num_added items. Remove blocks use $num_added because
+ # splicing changed the length of outlist.
+ # We remove $num_removed items. Insert blocks use $num_removed because
+ # their item numbers---corresponding to positions in file *2*--- don't take
+ # removed items into account.
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ my ($num_added, $num_removed) = (0,0);
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+
+ foreach my $block (@{$hunk->{"blocks"}}) {
+ foreach my $item ($block->remove) {
+ my $op = $item->{"sign"}; # -
+ my $offset = $item->{"item_no"} - $low + $num_added;
+ $outlist[$offset] =~ s/^ /$op/;
+ $num_removed++;
+ }
+ foreach my $item ($block->insert) {
+ my $op = $item->{"sign"}; # +
+ my $i = $item->{"item_no"};
+ my $offset = $i - $hunk->{"start2"} + $num_removed;
+ splice(@outlist,$offset,0,"$op$$fileref2[$i]");
+ $num_added++;
+ }
+ }
+
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+
+}
+
+sub output_context_diff {
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my @blocklist;
+
+ print "***************\n";
+ # Calculate item number range.
+ my $range1 = $hunk->context_range(1);
+ my $range2 = $hunk->context_range(2);
+
+ # Print out file 1 part for each block in context diff format if there are
+ # any blocks that remove items
+ print "*** $range1 ****\n";
+ my $low = $hunk->{"start1"};
+ my $hi = $hunk->{"end1"};
+ if (@blocklist = grep {$_->remove} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref1[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # - or !
+ foreach my $item ($block->remove) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+
+ print "--- $range2 ----\n";
+ $low = $hunk->{"start2"};
+ $hi = $hunk->{"end2"};
+ if (@blocklist = grep {$_->insert} @{$hunk->{"blocks"}}) {
+ my @outlist = @$fileref2[$low..$hi];
+ map {s/^/ /} @outlist; # assume it's just context
+ foreach my $block (@blocklist) {
+ my $op = $block->op; # + or !
+ foreach my $item ($block->insert) {
+ $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/;
+ }
+ }
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ }
+}
+
+sub store_ed_diff {
+# ed diff prints out diffs *backwards*. So save them while we're generating
+# them, then print them out at the end
+ my $hunk = shift;
+ unshift @Ed_Hunks, $hunk;
+}
+
+sub output_ed_diff {
+# This sub is used for ed ('diff -e') OR reverse_ed ('diff -f').
+# last arg is type of diff
+ my $diff_type = $_[-1];
+ my ($hunk, $fileref1, $fileref2) = @_;
+ my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');
+
+ # Can't be any context for this kind of diff, so each hunk has one block
+ my @blocklist = @{$hunk->{"blocks"}};
+ warn ("Expecting one block in an ed diff hunk!") if scalar @blocklist != 1;
+ my $block = $blocklist[0];
+ my $op = $block->op; # +, -, or !
+
+ # Calculate item number range.
+ # old diff range is just like a context diff range, except the ranges
+ # are on one line with the action between them.
+ my $range1 = $hunk->context_range(1);
+ $range1 =~ s/,/ / if $diff_type eq "REVERSE_ED";
+ my $action = $op_hash{$op} || warn "unknown op $op";
+ print ($diff_type eq "ED" ? "$range1$action\n" : "$action$range1\n");
+
+ if ($block->insert) {
+ my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
+ map {s/$/\n/} @outlist; # add \n's
+ print @outlist;
+ print ".\n"; # end of ed 'c' or 'a' command
+ }
+}
+
+sub context_range {
+# Generate a range of item numbers to print. Only print 1 number if the range
+# has only one item in it. Otherwise, it's 'start,end'
+# Flag is the number of the file (1 or 2)
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $range = ($start < $end) ? "$start,$end" : $end;
+ return $range;
+}
+
+sub unified_range {
+# Generate a range of item numbers to print for unified diff
+# Print number where block starts, followed by number of lines in the block
+# (don't print number of lines if it's 1)
+ my ($hunk, $flag) = @_;
+ my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
+ $start++; $end++; # index from 1, not zero
+ my $length = $end - $start + 1;
+ my $first = $length < 2 ? $end : $start; # strange, but correct...
+ my $range = $length== 1 ? $first : "$first,$length";
+ return $range;
+}
+} # end Package Hunk
+
+########
+# Package Block. A block is an operation removing, adding, or changing
+# a group of items. Basically, this is just a list of changes, where each
+# change adds or deletes a single item.
+# (Change could be a separate class, but it didn't seem worth it)
+{
+package Block;
+sub new {
+# Input is a chunk from &Algorithm::LCS::diff
+# Fields in a block:
+# length_diff - how much longer file 2 is than file 1 due to this block
+# Each change has:
+# sign - '+' for insert, '-' for remove
+# item_no - number of the item in the file (e.g., line number)
+# We don't bother storing the text of the item
+#
+ my ($class,$chunk) = @_;
+ my @changes = ();
+
+# This just turns each change into a hash.
+ foreach my $item (@$chunk) {
+ my ($sign, $item_no, $text) = @$item;
+ my $hashref = {"sign" => $sign, "item_no" => $item_no};
+ push @changes, $hashref;
+ }
+
+ my $block = { "changes" => \@changes };
+ bless $block, $class;
+
+ $block->{"length_diff"} = $block->insert - $block->remove;
+ return $block;
+}
+
+
+# LOW LEVEL FUNCTIONS
+sub op {
+# what kind of block is this?
+ my $block = shift;
+ my $insert = $block->insert;
+ my $remove = $block->remove;
+
+ $remove && $insert and return '!';
+ $remove and return '-';
+ $insert and return '+';
+ warn "unknown block type";
+ return '^'; # context block
+}
+
+# Returns a list of the changes in this block that remove items
+# (or the number of removals if called in scalar context)
+sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }
+
+# Returns a list of the changes in this block that insert items
+sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }
+
+} # end of package Block
--- /dev/null
+#!/usr/bin/perl -w
+# diffs two files and writes an HTML output file.
+use strict;
+use CGI qw(:standard :html3);
+use Algorithm::Diff 'traverse_sequences';
+use Text::Tabs;
+
+my ( @a, @b );
+
+# Take care of whitespace.
+sub preprocess
+{
+ my $arrayRef = shift;
+ chomp(@$arrayRef);
+ @$arrayRef = expand(@$arrayRef);
+}
+
+# This will be called with both lines are the same
+sub match
+{
+ my ( $ia, $ib ) = @_;
+ print pre( $a[$ia] ), "\n";
+}
+
+# This will be called when there is a line in A that isn't in B
+sub only_a
+{
+ my ( $ia, $ib ) = @_;
+ print pre( { -class => 'onlyA' }, $a[$ia] ), "\n";
+}
+
+# This will be called when there is a line in B that isn't in A
+sub only_b
+{
+ my ( $ia, $ib ) = @_;
+ print pre( { -class => 'onlyB' }, $b[$ib] ), "\n";
+}
+
+# MAIN PROGRAM
+
+# Check for two arguments.
+print "usage: $0 file1 file2 > diff.html\n" if @ARGV != 2;
+
+$tabstop = 4; # For Text::Tabs
+
+# Read each file into an array.
+open FH, $ARGV[0];
+@a = <FH>;
+close FH;
+
+open FH, $ARGV[1];
+@b = <FH>;
+close FH;
+
+# Expand whitespace
+preprocess( \@a );
+preprocess( \@b );
+
+# inline style
+my $style = <<EOS;
+ PRE {
+ margin-left: 24pt;
+ font-size: 12pt;
+ font-family: Courier, monospaced;
+ white-space: pre
+ }
+ PRE.onlyA { color: red }
+ PRE.onlyB { color: blue }
+EOS
+
+# Print out the starting HTML
+print
+
+ # header(),
+ start_html(
+ {
+ -title => "$ARGV[0] vs. $ARGV[1]",
+ -style => { -code => $style }
+ }
+ ),
+ h1(
+ { -style => 'margin-left: 24pt' },
+ span( { -style => 'color: red' }, $ARGV[0] ),
+ span(" <i>vs.</i> "),
+ span( { -style => 'color: blue' }, $ARGV[1] )
+ ),
+ "\n";
+
+# And compare the arrays
+traverse_sequences(
+ \@a, # first sequence
+ \@b, # second sequence
+ {
+ MATCH => \&match, # callback on identical lines
+ DISCARD_A => \&only_a, # callback on A-only
+ DISCARD_B => \&only_b, # callback on B-only
+ }
+);
+
+print end_html();
--- /dev/null
+package Algorithm::Diff;
+# Skip to first "=head" line for documentation.
+use strict;
+
+use integer; # see below in _replaceNextLargerWith() for mod to make
+ # if you don't use this
+use vars qw( $VERSION @EXPORT_OK );
+$VERSION = 1.19_02;
+# ^ ^^ ^^-- Incremented at will
+# | \+----- Incremented for non-trivial changes to features
+# \-------- Incremented for fundamental changes
+require Exporter;
+*import = \&Exporter::import;
+@EXPORT_OK = qw(
+ prepare LCS LCSidx LCS_length
+ diff sdiff compact_diff
+ traverse_sequences traverse_balanced
+);
+
+# McIlroy-Hunt diff algorithm
+# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
+# by Ned Konz, perl@bike-nomad.com
+# Updates by Tye McQueen, http://perlmonks.org/?node=tye
+
+# Create a hash that maps each element of $aCollection to the set of
+# positions it occupies in $aCollection, restricted to the elements
+# within the range of indexes specified by $start and $end.
+# The fourth parameter is a subroutine reference that will be called to
+# generate a string to use as a key.
+# Additional parameters, if any, will be passed to this subroutine.
+#
+# my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
+
+sub _withPositionsOfInInterval
+{
+ my $aCollection = shift; # array ref
+ my $start = shift;
+ my $end = shift;
+ my $keyGen = shift;
+ my %d;
+ my $index;
+ for ( $index = $start ; $index <= $end ; $index++ )
+ {
+ my $element = $aCollection->[$index];
+ my $key = &$keyGen( $element, @_ );
+ if ( exists( $d{$key} ) )
+ {
+ unshift ( @{ $d{$key} }, $index );
+ }
+ else
+ {
+ $d{$key} = [$index];
+ }
+ }
+ return wantarray ? %d : \%d;
+}
+
+# Find the place at which aValue would normally be inserted into the
+# array. If that place is already occupied by aValue, do nothing, and
+# return undef. If the place does not exist (i.e., it is off the end of
+# the array), add it to the end, otherwise replace the element at that
+# point with aValue. It is assumed that the array's values are numeric.
+# This is where the bulk (75%) of the time is spent in this module, so
+# try to make it fast!
+
+sub _replaceNextLargerWith
+{
+ my ( $array, $aValue, $high ) = @_;
+ $high ||= $#$array;
+
+ # off the end?
+ if ( $high == -1 || $aValue > $array->[-1] )
+ {
+ push ( @$array, $aValue );
+ return $high + 1;
+ }
+
+ # binary search for insertion point...
+ my $low = 0;
+ my $index;
+ my $found;
+ while ( $low <= $high )
+ {
+ $index = ( $high + $low ) / 2;
+
+ # $index = int(( $high + $low ) / 2); # without 'use integer'
+ $found = $array->[$index];
+
+ if ( $aValue == $found )
+ {
+ return undef;
+ }
+ elsif ( $aValue > $found )
+ {
+ $low = $index + 1;
+ }
+ else
+ {
+ $high = $index - 1;
+ }
+ }
+
+ # now insertion point is in $low.
+ $array->[$low] = $aValue; # overwrite next larger
+ return $low;
+}
+
+# This method computes the longest common subsequence in $a and $b.
+
+# Result is array or ref, whose contents is such that
+# $a->[ $i ] == $b->[ $result[ $i ] ]
+# foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
+
+# An additional argument may be passed; this is a hash or key generating
+# function that should return a string that uniquely identifies the given
+# element. It should be the case that if the key is the same, the elements
+# will compare the same. If this parameter is undef or missing, the key
+# will be the element as a string.
+
+# By default, comparisons will use "eq" and elements will be turned into keys
+# using the default stringizing operator '""'.
+
+# Additional parameters, if any, will be passed to the key generation
+# routine.
+
+sub _longestCommonSubsequence
+{
+ my $a = shift; # array ref or hash ref
+ my $b = shift; # array ref or hash ref
+ my $counting = shift; # scalar
+ my $keyGen = shift; # code ref
+ my $compare; # code ref
+
+ if ( ref($a) eq 'HASH' )
+ { # prepared hash must be in $b
+ my $tmp = $b;
+ $b = $a;
+ $a = $tmp;
+ }
+
+ # Check for bogus (non-ref) argument values
+ if ( !ref($a) || !ref($b) )
+ {
+ my @callerInfo = caller(1);
+ die 'error: must pass array or hash references to ' . $callerInfo[3];
+ }
+
+ # set up code refs
+ # Note that these are optimized.
+ if ( !defined($keyGen) ) # optimize for strings
+ {
+ $keyGen = sub { $_[0] };
+ $compare = sub { my ( $a, $b ) = @_; $a eq $b };
+ }
+ else
+ {
+ $compare = sub {
+ my $a = shift;
+ my $b = shift;
+ &$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
+ };
+ }
+
+ my ( $aStart, $aFinish, $matchVector ) = ( 0, $#$a, [] );
+ my ( $prunedCount, $bMatches ) = ( 0, {} );
+
+ if ( ref($b) eq 'HASH' ) # was $bMatches prepared for us?
+ {
+ $bMatches = $b;
+ }
+ else
+ {
+ my ( $bStart, $bFinish ) = ( 0, $#$b );
+
+ # First we prune off any common elements at the beginning
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[$aStart], $b->[$bStart], @_ ) )
+ {
+ $matchVector->[ $aStart++ ] = $bStart++;
+ $prunedCount++;
+ }
+
+ # now the end
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) )
+ {
+ $matchVector->[ $aFinish-- ] = $bFinish--;
+ $prunedCount++;
+ }
+
+ # Now compute the equivalence classes of positions of elements
+ $bMatches =
+ _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
+ }
+ my $thresh = [];
+ my $links = [];
+
+ my ( $i, $ai, $j, $k );
+ for ( $i = $aStart ; $i <= $aFinish ; $i++ )
+ {
+ $ai = &$keyGen( $a->[$i], @_ );
+ if ( exists( $bMatches->{$ai} ) )
+ {
+ $k = 0;
+ for $j ( @{ $bMatches->{$ai} } )
+ {
+
+ # optimization: most of the time this will be true
+ if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
+ {
+ $thresh->[$k] = $j;
+ }
+ else
+ {
+ $k = _replaceNextLargerWith( $thresh, $j, $k );
+ }
+
+ # oddly, it's faster to always test this (CPU cache?).
+ if ( defined($k) )
+ {
+ $links->[$k] =
+ [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
+ }
+ }
+ }
+ }
+
+ if (@$thresh)
+ {
+ return $prunedCount + @$thresh if $counting;
+ for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
+ {
+ $matchVector->[ $link->[1] ] = $link->[2];
+ }
+ }
+ elsif ($counting)
+ {
+ return $prunedCount;
+ }
+
+ return wantarray ? @$matchVector : $matchVector;
+}
+
+sub traverse_sequences
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $callbacks = shift || {};
+ my $keyGen = shift;
+ my $matchCallback = $callbacks->{'MATCH'} || sub { };
+ my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
+ my $finishedACallback = $callbacks->{'A_FINISHED'};
+ my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
+ my $finishedBCallback = $callbacks->{'B_FINISHED'};
+ my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
+
+ # Process all the lines in @$matchVector
+ my $lastA = $#$a;
+ my $lastB = $#$b;
+ my $bi = 0;
+ my $ai;
+
+ for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
+ {
+ my $bLine = $matchVector->[$ai];
+ if ( defined($bLine) ) # matched
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
+ &$matchCallback( $ai, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai, $bi, @_ );
+ }
+ }
+
+ # The last entry (if any) processed was a match.
+ # $ai and $bi point just past the last matching lines in their sequences.
+
+ while ( $ai <= $lastA or $bi <= $lastB )
+ {
+
+ # last A?
+ if ( $ai == $lastA + 1 and $bi <= $lastB )
+ {
+ if ( defined($finishedACallback) )
+ {
+ &$finishedACallback( $lastA, @_ );
+ $finishedACallback = undef;
+ }
+ else
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
+ }
+ }
+
+ # last B?
+ if ( $bi == $lastB + 1 and $ai <= $lastA )
+ {
+ if ( defined($finishedBCallback) )
+ {
+ &$finishedBCallback( $lastB, @_ );
+ $finishedBCallback = undef;
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
+ }
+ }
+
+ &$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
+ &$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
+ }
+
+ return 1;
+}
+
+sub traverse_balanced
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $callbacks = shift || {};
+ my $keyGen = shift;
+ my $matchCallback = $callbacks->{'MATCH'} || sub { };
+ my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
+ my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
+ my $changeCallback = $callbacks->{'CHANGE'};
+ my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ );
+
+ # Process all the lines in match vector
+ my $lastA = $#$a;
+ my $lastB = $#$b;
+ my $bi = 0;
+ my $ai = 0;
+ my $ma = -1;
+ my $mb;
+
+ while (1)
+ {
+
+ # Find next match indices $ma and $mb
+ do {
+ $ma++;
+ } while(
+ $ma <= $#$matchVector
+ && !defined $matchVector->[$ma]
+ );
+
+ last if $ma > $#$matchVector; # end of matchVector?
+ $mb = $matchVector->[$ma];
+
+ # Proceed with discard a/b or change events until
+ # next match
+ while ( $ai < $ma || $bi < $mb )
+ {
+
+ if ( $ai < $ma && $bi < $mb )
+ {
+
+ # Change
+ if ( defined $changeCallback )
+ {
+ &$changeCallback( $ai++, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+ elsif ( $ai < $ma )
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ }
+ else
+ {
+
+ # $bi < $mb
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+
+ # Match
+ &$matchCallback( $ai++, $bi++, @_ );
+ }
+
+ while ( $ai <= $lastA || $bi <= $lastB )
+ {
+ if ( $ai <= $lastA && $bi <= $lastB )
+ {
+
+ # Change
+ if ( defined $changeCallback )
+ {
+ &$changeCallback( $ai++, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+ elsif ( $ai <= $lastA )
+ {
+ &$discardACallback( $ai++, $bi, @_ );
+ }
+ else
+ {
+
+ # $bi <= $lastB
+ &$discardBCallback( $ai, $bi++, @_ );
+ }
+ }
+
+ return 1;
+}
+
+sub prepare
+{
+ my $a = shift; # array ref
+ my $keyGen = shift; # code ref
+
+ # set up code ref
+ $keyGen = sub { $_[0] } unless defined($keyGen);
+
+ return scalar _withPositionsOfInInterval( $a, 0, $#$a, $keyGen, @_ );
+}
+
+sub LCS
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref or hash ref
+ my $matchVector = _longestCommonSubsequence( $a, $b, 0, @_ );
+ my @retval;
+ my $i;
+ for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
+ {
+ if ( defined( $matchVector->[$i] ) )
+ {
+ push ( @retval, $a->[$i] );
+ }
+ }
+ return wantarray ? @retval : \@retval;
+}
+
+sub LCS_length
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref or hash ref
+ return _longestCommonSubsequence( $a, $b, 1, @_ );
+}
+
+sub LCSidx
+{
+ my $a= shift @_;
+ my $b= shift @_;
+ my $match= _longestCommonSubsequence( $a, $b, 0, @_ );
+ my @am= grep defined $match->[$_], 0..$#$match;
+ my @bm= @{$match}[@am];
+ return \@am, \@bm;
+}
+
+sub compact_diff
+{
+ my $a= shift @_;
+ my $b= shift @_;
+ my( $am, $bm )= LCSidx( $a, $b, @_ );
+ my @cdiff;
+ my( $ai, $bi )= ( 0, 0 );
+ push @cdiff, $ai, $bi;
+ while( 1 ) {
+ while( @$am && $ai == $am->[0] && $bi == $bm->[0] ) {
+ shift @$am;
+ shift @$bm;
+ ++$ai, ++$bi;
+ }
+ push @cdiff, $ai, $bi;
+ last if ! @$am;
+ $ai = $am->[0];
+ $bi = $bm->[0];
+ push @cdiff, $ai, $bi;
+ }
+ push @cdiff, 0+@$a, 0+@$b
+ if $ai < @$a || $bi < @$b;
+ return wantarray ? @cdiff : \@cdiff;
+}
+
+sub diff
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $retval = [];
+ my $hunk = [];
+ my $discard = sub {
+ push @$hunk, [ '-', $_[0], $a->[ $_[0] ] ];
+ };
+ my $add = sub {
+ push @$hunk, [ '+', $_[1], $b->[ $_[1] ] ];
+ };
+ my $match = sub {
+ push @$retval, $hunk
+ if 0 < @$hunk;
+ $hunk = []
+ };
+ traverse_sequences( $a, $b,
+ { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
+ &$match();
+ return wantarray ? @$retval : $retval;
+}
+
+sub sdiff
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $retval = [];
+ my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
+ my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
+ my $change = sub {
+ push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
+ };
+ my $match = sub {
+ push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
+ };
+ traverse_balanced(
+ $a,
+ $b,
+ {
+ MATCH => $match,
+ DISCARD_A => $discard,
+ DISCARD_B => $add,
+ CHANGE => $change,
+ },
+ @_
+ );
+ return wantarray ? @$retval : $retval;
+}
+
+########################################
+my $Root= __PACKAGE__;
+package Algorithm::Diff::_impl;
+use strict;
+
+sub _Idx() { 0 } # $me->[_Idx]: Ref to array of hunk indices
+ # 1 # $me->[1]: Ref to first sequence
+ # 2 # $me->[2]: Ref to second sequence
+sub _End() { 3 } # $me->[_End]: Diff between forward and reverse pos
+sub _Same() { 4 } # $me->[_Same]: 1 if pos 1 contains unchanged items
+sub _Base() { 5 } # $me->[_Base]: Added to range's min and max
+sub _Pos() { 6 } # $me->[_Pos]: Which hunk is currently selected
+sub _Off() { 7 } # $me->[_Off]: Offset into _Idx for current position
+sub _Min() { -2 } # Added to _Off to get min instead of max+1
+
+sub Die
+{
+ require Carp;
+ Carp::confess( @_ );
+}
+
+sub _ChkPos
+{
+ my( $me )= @_;
+ return if $me->[_Pos];
+ my $meth= ( caller(1) )[3];
+ Die( "Called $meth on 'reset' object" );
+}
+
+sub _ChkSeq
+{
+ my( $me, $seq )= @_;
+ return $seq + $me->[_Off]
+ if 1 == $seq || 2 == $seq;
+ my $meth= ( caller(1) )[3];
+ Die( "$meth: Invalid sequence number ($seq); must be 1 or 2" );
+}
+
+sub getObjPkg
+{
+ my( $us )= @_;
+ return ref $us if ref $us;
+ return $us . "::_obj";
+}
+
+sub new
+{
+ my( $us, $seq1, $seq2, $opts ) = @_;
+ my @args;
+ for( $opts->{keyGen} ) {
+ push @args, $_ if $_;
+ }
+ for( $opts->{keyGenArgs} ) {
+ push @args, @$_ if $_;
+ }
+ my $cdif= Algorithm::Diff::compact_diff( $seq1, $seq2, @args );
+ my $same= 1;
+ if( 0 == $cdif->[2] && 0 == $cdif->[3] ) {
+ $same= 0;
+ splice @$cdif, 0, 2;
+ }
+ my @obj= ( $cdif, $seq1, $seq2 );
+ $obj[_End] = (1+@$cdif)/2;
+ $obj[_Same] = $same;
+ $obj[_Base] = 0;
+ my $me = bless \@obj, $us->getObjPkg();
+ $me->Reset( 0 );
+ return $me;
+}
+
+sub Reset
+{
+ my( $me, $pos )= @_;
+ $pos= int( $pos || 0 );
+ $pos += $me->[_End]
+ if $pos < 0;
+ $pos= 0
+ if $pos < 0 || $me->[_End] <= $pos;
+ $me->[_Pos]= $pos || !1;
+ $me->[_Off]= 2*$pos - 1;
+ return $me;
+}
+
+sub Base
+{
+ my( $me, $base )= @_;
+ my $oldBase= $me->[_Base];
+ $me->[_Base]= 0+$base if defined $base;
+ return $oldBase;
+}
+
+sub Copy
+{
+ my( $me, $pos, $base )= @_;
+ my @obj= @$me;
+ my $you= bless \@obj, ref($me);
+ $you->Reset( $pos ) if defined $pos;
+ $you->Base( $base );
+ return $you;
+}
+
+sub Next {
+ my( $me, $steps )= @_;
+ $steps= 1 if ! defined $steps;
+ if( $steps ) {
+ my $pos= $me->[_Pos];
+ my $new= $pos + $steps;
+ $new= 0 if $pos && $new < 0;
+ $me->Reset( $new )
+ }
+ return $me->[_Pos];
+}
+
+sub Prev {
+ my( $me, $steps )= @_;
+ $steps= 1 if ! defined $steps;
+ my $pos= $me->Next(-$steps);
+ $pos -= $me->[_End] if $pos;
+ return $pos;
+}
+
+sub Diff {
+ my( $me )= @_;
+ $me->_ChkPos();
+ return 0 if $me->[_Same] == ( 1 & $me->[_Pos] );
+ my $ret= 0;
+ my $off= $me->[_Off];
+ for my $seq ( 1, 2 ) {
+ $ret |= $seq
+ if $me->[_Idx][ $off + $seq + _Min ]
+ < $me->[_Idx][ $off + $seq ];
+ }
+ return $ret;
+}
+
+sub Min {
+ my( $me, $seq, $base )= @_;
+ $me->_ChkPos();
+ my $off= $me->_ChkSeq($seq);
+ $base= $me->[_Base] if !defined $base;
+ return $base + $me->[_Idx][ $off + _Min ];
+}
+
+sub Max {
+ my( $me, $seq, $base )= @_;
+ $me->_ChkPos();
+ my $off= $me->_ChkSeq($seq);
+ $base= $me->[_Base] if !defined $base;
+ return $base + $me->[_Idx][ $off ] -1;
+}
+
+sub Range {
+ my( $me, $seq, $base )= @_;
+ $me->_ChkPos();
+ my $off = $me->_ChkSeq($seq);
+ if( !wantarray ) {
+ return $me->[_Idx][ $off ]
+ - $me->[_Idx][ $off + _Min ];
+ }
+ $base= $me->[_Base] if !defined $base;
+ return ( $base + $me->[_Idx][ $off + _Min ] )
+ .. ( $base + $me->[_Idx][ $off ] - 1 );
+}
+
+sub Items {
+ my( $me, $seq )= @_;
+ $me->_ChkPos();
+ my $off = $me->_ChkSeq($seq);
+ if( !wantarray ) {
+ return $me->[_Idx][ $off ]
+ - $me->[_Idx][ $off + _Min ];
+ }
+ return
+ @{$me->[$seq]}[
+ $me->[_Idx][ $off + _Min ]
+ .. ( $me->[_Idx][ $off ] - 1 )
+ ];
+}
+
+sub Same {
+ my( $me )= @_;
+ $me->_ChkPos();
+ return wantarray ? () : 0
+ if $me->[_Same] != ( 1 & $me->[_Pos] );
+ return $me->Items(1);
+}
+
+my %getName;
+BEGIN {
+ %getName= (
+ same => \&Same,
+ diff => \&Diff,
+ base => \&Base,
+ min => \&Min,
+ max => \&Max,
+ range=> \&Range,
+ items=> \&Items, # same thing
+ );
+}
+
+sub Get
+{
+ my $me= shift @_;
+ $me->_ChkPos();
+ my @value;
+ for my $arg ( @_ ) {
+ for my $word ( split ' ', $arg ) {
+ my $meth;
+ if( $word !~ /^(-?\d+)?([a-zA-Z]+)([12])?$/
+ || not $meth= $getName{ lc $2 }
+ ) {
+ Die( $Root, ", Get: Invalid request ($word)" );
+ }
+ my( $base, $name, $seq )= ( $1, $2, $3 );
+ push @value, scalar(
+ 4 == length($name)
+ ? $meth->( $me )
+ : $meth->( $me, $seq, $base )
+ );
+ }
+ }
+ if( wantarray ) {
+ return @value;
+ } elsif( 1 == @value ) {
+ return $value[0];
+ }
+ Die( 0+@value, " values requested from ",
+ $Root, "'s Get in scalar context" );
+}
+
+
+my $Obj= getObjPkg($Root);
+no strict 'refs';
+
+for my $meth ( qw( new getObjPkg ) ) {
+ *{$Root."::".$meth} = \&{$meth};
+ *{$Obj ."::".$meth} = \&{$meth};
+}
+for my $meth ( qw(
+ Next Prev Reset Copy Base Diff
+ Same Items Range Min Max Get
+ _ChkPos _ChkSeq
+) ) {
+ *{$Obj."::".$meth} = \&{$meth};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Algorithm::Diff - Compute `intelligent' differences between two files / lists
+
+=head1 SYNOPSIS
+
+ require Algorithm::Diff;
+
+ # This example produces traditional 'diff' output:
+
+ my $diff = Algorithm::Diff->new( \@seq1, \@seq2 );
+
+ $diff->Base( 1 ); # Return line numbers, not indices
+ while( $diff->Next() ) {
+ next if $diff->Same();
+ my $sep = '';
+ if( ! $diff->Items(2) ) {
+ printf "%d,%dd%d\n",
+ $diff->Get(qw( Min1 Max1 Max2 ));
+ } elsif( ! $diff->Items(1) ) {
+ printf "%da%d,%d\n",
+ $diff->Get(qw( Max1 Min2 Max2 ));
+ } else {
+ $sep = "---\n";
+ printf "%d,%dc%d,%d\n",
+ $diff->Get(qw( Min1 Max1 Min2 Max2 ));
+ }
+ print "< $_" for $diff->Items(1);
+ print $sep;
+ print "> $_" for $diff->Items(2);
+ }
+
+
+ # Alternate interfaces:
+
+ use Algorithm::Diff qw(
+ LCS LCS_length LCSidx
+ diff sdiff compact_diff
+ traverse_sequences traverse_balanced );
+
+ @lcs = LCS( \@seq1, \@seq2 );
+ $lcsref = LCS( \@seq1, \@seq2 );
+ $count = LCS_length( \@seq1, \@seq2 );
+
+ ( $seq1idxref, $seq2idxref ) = LCSidx( \@seq1, \@seq2 );
+
+
+ # Complicated interfaces:
+
+ @diffs = diff( \@seq1, \@seq2 );
+
+ @sdiffs = sdiff( \@seq1, \@seq2 );
+
+ @cdiffs = compact_diff( \@seq1, \@seq2 );
+
+ traverse_sequences(
+ \@seq1,
+ \@seq2,
+ { MATCH => \&callback1,
+ DISCARD_A => \&callback2,
+ DISCARD_B => \&callback3,
+ },
+ \&key_generator,
+ @extra_args,
+ );
+
+ traverse_balanced(
+ \@seq1,
+ \@seq2,
+ { MATCH => \&callback1,
+ DISCARD_A => \&callback2,
+ DISCARD_B => \&callback3,
+ CHANGE => \&callback4,
+ },
+ \&key_generator,
+ @extra_args,
+ );
+
+
+=head1 INTRODUCTION
+
+(by Mark-Jason Dominus)
+
+I once read an article written by the authors of C<diff>; they said
+that they worked very hard on the algorithm until they found the
+right one.
+
+I think what they ended up using (and I hope someone will correct me,
+because I am not very confident about this) was the `longest common
+subsequence' method. In the LCS problem, you have two sequences of
+items:
+
+ a b c d f g h j q z
+
+ a b c d e f g i j k r x y z
+
+and you want to find the longest sequence of items that is present in
+both original sequences in the same order. That is, you want to find
+a new sequence I<S> which can be obtained from the first sequence by
+deleting some items, and from the secend sequence by deleting other
+items. You also want I<S> to be as long as possible. In this case I<S>
+is
+
+ a b c d f g j z
+
+From there it's only a small step to get diff-like output:
+
+ e h i k q r x y
+ + - + + - + + +
+
+This module solves the LCS problem. It also includes a canned function
+to generate C<diff>-like output.
+
+It might seem from the example above that the LCS of two sequences is
+always pretty obvious, but that's not always the case, especially when
+the two sequences have many repeated elements. For example, consider
+
+ a x b y c z p d q
+ a b c a x b y c z
+
+A naive approach might start by matching up the C<a> and C<b> that
+appear at the beginning of each sequence, like this:
+
+ a x b y c z p d q
+ a b c a b y c z
+
+This finds the common subsequence C<a b c z>. But actually, the LCS
+is C<a x b y c z>:
+
+ a x b y c z p d q
+ a b c a x b y c z
+
+or
+
+ a x b y c z p d q
+ a b c a x b y c z
+
+=head1 USAGE
+
+(See also the README file and several example
+scripts include with this module.)
+
+This module now provides an object-oriented interface that uses less
+memory and is easier to use than most of the previous procedural
+interfaces. It also still provides several exportable functions. We'll
+deal with these in ascending order of difficulty: C<LCS>,
+C<LCS_length>, C<LCSidx>, OO interface, C<prepare>, C<diff>, C<sdiff>,
+C<traverse_sequences>, and C<traverse_balanced>.
+
+=head2 C<LCS>
+
+Given references to two lists of items, LCS returns an array containing
+their longest common subsequence. In scalar context, it returns a
+reference to such a list.
+
+ @lcs = LCS( \@seq1, \@seq2 );
+ $lcsref = LCS( \@seq1, \@seq2 );
+
+C<LCS> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+ @lcs = LCS( \@seq1, \@seq2, \&keyGen, @args );
+ $lcsref = LCS( \@seq1, \@seq2, \&keyGen, @args );
+
+Additional parameters, if any, will be passed to the key generation
+routine.
+
+=head2 C<LCS_length>
+
+This is just like C<LCS> except it only returns the length of the
+longest common subsequence. This provides a performance gain of about
+9% compared to C<LCS>.
+
+=head2 C<LCSidx>
+
+Like C<LCS> except it returns references to two arrays. The first array
+contains the indices into @seq1 where the LCS items are located. The
+second array contains the indices into @seq2 where the LCS items are located.
+
+Therefore, the following three lists will contain the same values:
+
+ my( $idx1, $idx2 ) = LCSidx( \@seq1, \@seq2 );
+ my @list1 = @seq1[ @$idx1 ];
+ my @list2 = @seq2[ @$idx2 ];
+ my @list3 = LCS( \@seq1, \@seq2 );
+
+=head2 C<new>
+
+ $diff = Algorithm::Diffs->new( \@seq1, \@seq2 );
+ $diff = Algorithm::Diffs->new( \@seq1, \@seq2, \%opts );
+
+C<new> computes the smallest set of additions and deletions necessary
+to turn the first sequence into the second and compactly records them
+in the object.
+
+You use the object to iterate over I<hunks>, where each hunk represents
+a contiguous section of items which should be added, deleted, replaced,
+or left unchanged.
+
+=over 4
+
+The following summary of all of the methods looks a lot like Perl code
+but some of the symbols have different meanings:
+
+ [ ] Encloses optional arguments
+ : Is followed by the default value for an optional argument
+ | Separates alternate return results
+
+Method summary:
+
+ $obj = Algorithm::Diff->new( \@seq1, \@seq2, [ \%opts ] );
+ $pos = $obj->Next( [ $count : 1 ] );
+ $revPos = $obj->Prev( [ $count : 1 ] );
+ $obj = $obj->Reset( [ $pos : 0 ] );
+ $copy = $obj->Copy( [ $pos, [ $newBase ] ] );
+ $oldBase = $obj->Base( [ $newBase ] );
+
+Note that all of the following methods C<die> if used on an object that
+is "reset" (not currently pointing at any hunk).
+
+ $bits = $obj->Diff( );
+ @items|$cnt = $obj->Same( );
+ @items|$cnt = $obj->Items( $seqNum );
+ @idxs |$cnt = $obj->Range( $seqNum, [ $base ] );
+ $minIdx = $obj->Min( $seqNum, [ $base ] );
+ $maxIdx = $obj->Max( $seqNum, [ $base ] );
+ @values = $obj->Get( @names );
+
+Passing in C<undef> for an optional argument is always treated the same
+as if no argument were passed in.
+
+=item C<Next>
+
+ $pos = $diff->Next(); # Move forward 1 hunk
+ $pos = $diff->Next( 2 ); # Move forward 2 hunks
+ $pos = $diff->Next(-5); # Move backward 5 hunks
+
+C<Next> moves the object to point at the next hunk. The object starts
+out "reset", which means it isn't pointing at any hunk. If the object
+is reset, then C<Next()> moves to the first hunk.
+
+C<Next> returns a true value iff the move didn't go past the last hunk.
+So C<Next(0)> will return true iff the object is not reset.
+
+Actually, C<Next> returns the object's new position, which is a number
+between 1 and the number of hunks (inclusive), or returns a false value.
+
+=item C<Prev>
+
+C<Prev($N)> is almost identical to C<Next(-$N)>; it moves to the $Nth
+previous hunk. On a 'reset' object, C<Prev()> [and C<Next(-1)>] move
+to the last hunk.
+
+The position returned by C<Prev> is relative to the I<end> of the
+hunks; -1 for the last hunk, -2 for the second-to-last, etc.
+
+=item C<Reset>
+
+ $diff->Reset(); # Reset the object's position
+ $diff->Reset($pos); # Move to the specified hunk
+ $diff->Reset(1); # Move to the first hunk
+ $diff->Reset(-1); # Move to the last hunk
+
+C<Reset> returns the object, so, for example, you could use
+C<< $diff->Reset()->Next(-1) >> to get the number of hunks.
+
+=item C<Copy>
+
+ $copy = $diff->Copy( $newPos, $newBase );
+
+C<Copy> returns a copy of the object. The copy and the orignal object
+share most of their data, so making copies takes very little memory.
+The copy maintains its own position (separate from the original), which
+is the main purpose of copies. It also maintains its own base.
+
+By default, the copy's position starts out the same as the original
+object's position. But C<Copy> takes an optional first argument to set the
+new position, so the following three snippets are equivalent:
+
+ $copy = $diff->Copy($pos);
+
+ $copy = $diff->Copy();
+ $copy->Reset($pos);
+
+ $copy = $diff->Copy()->Reset($pos);
+
+C<Copy> takes an optional second argument to set the base for
+the copy. If you wish to change the base of the copy but leave
+the position the same as in the original, here are two
+equivalent ways:
+
+ $copy = $diff->Copy();
+ $copy->Base( 0 );
+
+ $copy = $diff->Copy(undef,0);
+
+Here are two equivalent way to get a "reset" copy:
+
+ $copy = $diff->Copy(0);
+
+ $copy = $diff->Copy()->Reset();
+
+=item C<Diff>
+
+ $bits = $obj->Diff();
+
+C<Diff> returns a true value iff the current hunk contains items that are
+different between the two sequences. It actually returns one of the
+follow 4 values:
+
+=over 4
+
+=item 3
+
+C<3==(1|2)>. This hunk contains items from @seq1 and the items
+from @seq2 that should replace them. Both sequence 1 and 2
+contain changed items so both the 1 and 2 bits are set.
+
+=item 2
+
+This hunk only contains items from @seq2 that should be inserted (not
+items from @seq1). Only sequence 2 contains changed items so only the 2
+bit is set.
+
+=item 1
+
+This hunk only contains items from @seq1 that should be deleted (not
+items from @seq2). Only sequence 1 contains changed items so only the 1
+bit is set.
+
+=item 0
+
+This means that the items in this hunk are the same in both sequences.
+Neither sequence 1 nor 2 contain changed items so neither the 1 nor the
+2 bits are set.
+
+=back
+
+=item C<Same>
+
+C<Same> returns a true value iff the current hunk contains items that
+are the same in both sequences. It actually returns the list of items
+if they are the same or an emty list if they aren't. In a scalar
+context, it returns the size of the list.
+
+=item C<Items>
+
+ $count = $diff->Items(2);
+ @items = $diff->Items($seqNum);
+
+C<Items> returns the (number of) items from the specified sequence that
+are part of the current hunk.
+
+If the current hunk contains only insertions, then
+C<< $diff->Items(1) >> will return an empty list (0 in a scalar conext).
+If the current hunk contains only deletions, then C<< $diff->Items(2) >>
+will return an empty list (0 in a scalar conext).
+
+If the hunk contains replacements, then both C<< $diff->Items(1) >> and
+C<< $diff->Items(2) >> will return different, non-empty lists.
+
+Otherwise, the hunk contains identical items and all of the following
+will return the same lists:
+
+ @items = $diff->Items(1);
+ @items = $diff->Items(2);
+ @items = $diff->Same();
+
+=item C<Range>
+
+ $count = $diff->Range( $seqNum );
+ @indices = $diff->Range( $seqNum );
+ @indices = $diff->Range( $seqNum, $base );
+
+C<Range> is like C<Items> except that it returns a list of I<indices> to
+the items rather than the items themselves. By default, the index of
+the first item (in each sequence) is 0 but this can be changed by
+calling the C<Base> method. So, by default, the following two snippets
+return the same lists:
+
+ @list = $diff->Items(2);
+ @list = @seq2[ $diff->Range(2) ];
+
+You can also specify the base to use as the second argument. So the
+following two snippets I<always> return the same lists:
+
+ @list = $diff->Items(1);
+ @list = @seq1[ $diff->Range(1,0) ];
+
+=item C<Base>
+
+ $curBase = $diff->Base();
+ $oldBase = $diff->Base($newBase);
+
+C<Base> sets and/or returns the current base (usually 0 or 1) that is
+used when you request range information. The base defaults to 0 so
+that range information is returned as array indices. You can set the
+base to 1 if you want to report traditional line numbers instead.
+
+=item C<Min>
+
+ $min1 = $diff->Min(1);
+ $min = $diff->Min( $seqNum, $base );
+
+C<Min> returns the first value that C<Range> would return (given the
+same arguments) or returns C<undef> if C<Range> would return an empty
+list.
+
+=item C<Max>
+
+C<Max> returns the last value that C<Range> would return or C<undef>.
+
+=item C<Get>
+
+ ( $n, $x, $r ) = $diff->Get(qw( min1 max1 range1 ));
+ @values = $diff->Get(qw( 0min2 1max2 range2 same base ));
+
+C<Get> returns one or more scalar values. You pass in a list of the
+names of the values you want returned. Each name must match one of the
+following regexes:
+
+ /^(-?\d+)?(min|max)[12]$/i
+ /^(range[12]|same|diff|base)$/i
+
+The 1 or 2 after a name says which sequence you want the information
+for (and where allowed, it is required). The optional number before
+"min" or "max" is the base to use. So the following equalities hold:
+
+ $diff->Get('min1') == $diff->Min(1)
+ $diff->Get('0min2') == $diff->Min(2,0)
+
+Using C<Get> in a scalar context when you've passed in more than one
+name is a fatal error (C<die> is called).
+
+=back
+
+=head2 C<prepare>
+
+Given a reference to a list of items, C<prepare> returns a reference
+to a hash which can be used when comparing this sequence to other
+sequences with C<LCS> or C<LCS_length>.
+
+ $prep = prepare( \@seq1 );
+ for $i ( 0 .. 10_000 )
+ {
+ @lcs = LCS( $prep, $seq[$i] );
+ # do something useful with @lcs
+ }
+
+C<prepare> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+ $prep = prepare( \@seq1, \&keyGen );
+ for $i ( 0 .. 10_000 )
+ {
+ @lcs = LCS( $seq[$i], $prep, \&keyGen );
+ # do something useful with @lcs
+ }
+
+Using C<prepare> provides a performance gain of about 50% when calling LCS
+many times compared with not preparing.
+
+=head2 C<diff>
+
+ @diffs = diff( \@seq1, \@seq2 );
+ $diffs_ref = diff( \@seq1, \@seq2 );
+
+C<diff> computes the smallest set of additions and deletions necessary
+to turn the first sequence into the second, and returns a description
+of these changes. The description is a list of I<hunks>; each hunk
+represents a contiguous section of items which should be added,
+deleted, or replaced. (Hunks containing unchanged items are not
+included.)
+
+The return value of C<diff> is a list of hunks, or, in scalar context, a
+reference to such a list. If there are no differences, the list will be
+empty.
+
+Here is an example. Calling C<diff> for the following two sequences:
+
+ a b c e h j l m n p
+ b c d e f j k l m r s t
+
+would produce the following list:
+
+ (
+ [ [ '-', 0, 'a' ] ],
+
+ [ [ '+', 2, 'd' ] ],
+
+ [ [ '-', 4, 'h' ],
+ [ '+', 4, 'f' ] ],
+
+ [ [ '+', 6, 'k' ] ],
+
+ [ [ '-', 8, 'n' ],
+ [ '-', 9, 'p' ],
+ [ '+', 9, 'r' ],
+ [ '+', 10, 's' ],
+ [ '+', 11, 't' ] ],
+ )
+
+There are five hunks here. The first hunk says that the C<a> at
+position 0 of the first sequence should be deleted (C<->). The second
+hunk says that the C<d> at position 2 of the second sequence should
+be inserted (C<+>). The third hunk says that the C<h> at position 4
+of the first sequence should be removed and replaced with the C<f>
+from position 4 of the second sequence. And so on.
+
+C<diff> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+Additional parameters, if any, will be passed to the key generation
+routine.
+
+=head2 C<sdiff>
+
+ @sdiffs = sdiff( \@seq1, \@seq2 );
+ $sdiffs_ref = sdiff( \@seq1, \@seq2 );
+
+C<sdiff> computes all necessary components to show two sequences
+and their minimized differences side by side, just like the
+Unix-utility I<sdiff> does:
+
+ same same
+ before | after
+ old < -
+ - > new
+
+It returns a list of array refs, each pointing to an array of
+display instructions. In scalar context it returns a reference
+to such a list. If there are no differences, the list will have one
+entry per item, each indicating that the item was unchanged.
+
+Display instructions consist of three elements: A modifier indicator
+(C<+>: Element added, C<->: Element removed, C<u>: Element unmodified,
+C<c>: Element changed) and the value of the old and new elements, to
+be displayed side-by-side.
+
+An C<sdiff> of the following two sequences:
+
+ a b c e h j l m n p
+ b c d e f j k l m r s t
+
+results in
+
+ ( [ '-', 'a', '' ],
+ [ 'u', 'b', 'b' ],
+ [ 'u', 'c', 'c' ],
+ [ '+', '', 'd' ],
+ [ 'u', 'e', 'e' ],
+ [ 'c', 'h', 'f' ],
+ [ 'u', 'j', 'j' ],
+ [ '+', '', 'k' ],
+ [ 'u', 'l', 'l' ],
+ [ 'u', 'm', 'm' ],
+ [ 'c', 'n', 'r' ],
+ [ 'c', 'p', 's' ],
+ [ '+', '', 't' ],
+ )
+
+C<sdiff> may be passed an optional third parameter; this is a CODE
+reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+Additional parameters, if any, will be passed to the key generation
+routine.
+
+=head2 C<compact_diff>
+
+C<compact_diff> is much like C<sdiff> except it returns a much more
+compact description consisting of just one flat list of indices. An
+example helps explain the format:
+
+ my @a = qw( a b c e h j l m n p );
+ my @b = qw( b c d e f j k l m r s t );
+ @cdiff = compact_diff( \@a, \@b );
+ # Returns:
+ # @a @b @a @b
+ # start start values values
+ ( 0, 0, # =
+ 0, 0, # a !
+ 1, 0, # b c = b c
+ 3, 2, # ! d
+ 3, 3, # e = e
+ 4, 4, # f ! h
+ 5, 5, # j = j
+ 6, 6, # ! k
+ 6, 7, # l m = l m
+ 8, 9, # n p ! r s t
+ 10, 12, #
+ );
+
+The 0th, 2nd, 4th, etc. entries are all indices into @seq1 (@a in the
+above example) indicating where a hunk begins. The 1st, 3rd, 5th, etc.
+entries are all indices into @seq2 (@b in the above example) indicating
+where the same hunk begins.
+
+So each pair of indices (except the last pair) describes where a hunk
+begins (in each sequence). Since each hunk must end at the item just
+before the item that starts the next hunk, the next pair of indices can
+be used to determine where the hunk ends.
+
+So, the first 4 entries (0..3) describe the first hunk. Entries 0 and 1
+describe where the first hunk begins (and so are always both 0).
+Entries 2 and 3 describe where the next hunk begins, so subtracting 1
+from each tells us where the first hunk ends. That is, the first hunk
+contains items C<$diff[0]> through C<$diff[2] - 1> of the first sequence
+and contains items C<$diff[1]> through C<$diff[3] - 1> of the second
+sequence.
+
+In other words, the first hunk consists of the following two lists of items:
+
+ # 1st pair 2nd pair
+ # of indices of indices
+ @list1 = @a[ $cdiff[0] .. $cdiff[2]-1 ];
+ @list2 = @b[ $cdiff[1] .. $cdiff[3]-1 ];
+ # Hunk start Hunk end
+
+Note that the hunks will always alternate between those that are part of
+the LCS (those that contain unchanged items) and those that contain
+changes. This means that all we need to be told is whether the first
+hunk is a 'same' or 'diff' hunk and we can determine which of the other
+hunks contain 'same' items or 'diff' items.
+
+By convention, we always make the first hunk contain unchanged items.
+So the 1st, 3rd, 5th, etc. hunks (all odd-numbered hunks if you start
+counting from 1) all contain unchanged items. And the 2nd, 4th, 6th,
+etc. hunks (all even-numbered hunks if you start counting from 1) all
+contain changed items.
+
+Since @a and @b don't begin with the same value, the first hunk in our
+example is empty (otherwise we'd violate the above convention). Note
+that the first 4 index values in our example are all zero. Plug these
+values into our previous code block and we get:
+
+ @hunk1a = @a[ 0 .. 0-1 ];
+ @hunk1b = @b[ 0 .. 0-1 ];
+
+And C<0..-1> returns the empty list.
+
+Move down one pair of indices (2..5) and we get the offset ranges for
+the second hunk, which contains changed items.
+
+Since C<@diff[2..5]> contains (0,0,1,0) in our example, the second hunk
+consists of these two lists of items:
+
+ @hunk2a = @a[ $cdiff[2] .. $cdiff[4]-1 ];
+ @hunk2b = @b[ $cdiff[3] .. $cdiff[5]-1 ];
+ # or
+ @hunk2a = @a[ 0 .. 1-1 ];
+ @hunk2b = @b[ 0 .. 0-1 ];
+ # or
+ @hunk2a = @a[ 0 .. 0 ];
+ @hunk2b = @b[ 0 .. -1 ];
+ # or
+ @hunk2a = ( 'a' );
+ @hunk2b = ( );
+
+That is, we would delete item 0 ('a') from @a.
+
+Since C<@diff[4..7]> contains (1,0,3,2) in our example, the third hunk
+consists of these two lists of items:
+
+ @hunk3a = @a[ $cdiff[4] .. $cdiff[6]-1 ];
+ @hunk3a = @b[ $cdiff[5] .. $cdiff[7]-1 ];
+ # or
+ @hunk3a = @a[ 1 .. 3-1 ];
+ @hunk3a = @b[ 0 .. 2-1 ];
+ # or
+ @hunk3a = @a[ 1 .. 2 ];
+ @hunk3a = @b[ 0 .. 1 ];
+ # or
+ @hunk3a = qw( b c );
+ @hunk3a = qw( b c );
+
+Note that this third hunk contains unchanged items as our convention demands.
+
+You can continue this process until you reach the last two indices,
+which will always be the number of items in each sequence. This is
+required so that subtracting one from each will give you the indices to
+the last items in each sequence.
+
+=head2 C<traverse_sequences>
+
+C<traverse_sequences> used to be the most general facility provided by
+this module (the new OO interface is more powerful and much easier to
+use).
+
+Imagine that there are two arrows. Arrow A points to an element of
+sequence A, and arrow B points to an element of the sequence B.
+Initially, the arrows point to the first elements of the respective
+sequences. C<traverse_sequences> will advance the arrows through the
+sequences one element at a time, calling an appropriate user-specified
+callback function before each advance. It willadvance the arrows in
+such a way that if there are equal elements C<$A[$i]> and C<$B[$j]>
+which are equal and which are part of the LCS, there will be some moment
+during the execution of C<traverse_sequences> when arrow A is pointing
+to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this happens,
+C<traverse_sequences> will call the C<MATCH> callback function and then
+it will advance both arrows.
+
+Otherwise, one of the arrows is pointing to an element of its sequence
+that is not part of the LCS. C<traverse_sequences> will advance that
+arrow and will call the C<DISCARD_A> or the C<DISCARD_B> callback,
+depending on which arrow it advanced. If both arrows point to elements
+that are not part of the LCS, then C<traverse_sequences> will advance
+one of them and call the appropriate callback, but it is not specified
+which it will call.
+
+The arguments to C<traverse_sequences> are the two sequences to
+traverse, and a hash which specifies the callback functions, like this:
+
+ traverse_sequences(
+ \@seq1, \@seq2,
+ { MATCH => $callback_1,
+ DISCARD_A => $callback_2,
+ DISCARD_B => $callback_3,
+ }
+ );
+
+Callbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least
+the indices of the two arrows as their arguments. They are not expected
+to return any values. If a callback is omitted from the table, it is
+not called.
+
+Callbacks for A_FINISHED and B_FINISHED are invoked with at least the
+corresponding index in A or B.
+
+If arrow A reaches the end of its sequence, before arrow B does,
+C<traverse_sequences> will call the C<A_FINISHED> callback when it
+advances arrow B, if there is such a function; if not it will call
+C<DISCARD_B> instead. Similarly if arrow B finishes first.
+C<traverse_sequences> returns when both arrows are at the ends of their
+respective sequences. It returns true on success and false on failure.
+At present there is no way to fail.
+
+C<traverse_sequences> may be passed an optional fourth parameter; this
+is a CODE reference to a key generation function. See L</KEY GENERATION
+FUNCTIONS>.
+
+Additional parameters, if any, will be passed to the key generation function.
+
+If you want to pass additional parameters to your callbacks, but don't
+need a custom key generation function, you can get the default by
+passing undef:
+
+ traverse_sequences(
+ \@seq1, \@seq2,
+ { MATCH => $callback_1,
+ DISCARD_A => $callback_2,
+ DISCARD_B => $callback_3,
+ },
+ undef, # default key-gen
+ $myArgument1,
+ $myArgument2,
+ $myArgument3,
+ );
+
+C<traverse_sequences> does not have a useful return value; you are
+expected to plug in the appropriate behavior with the callback
+functions.
+
+=head2 C<traverse_balanced>
+
+C<traverse_balanced> is an alternative to C<traverse_sequences>. It
+uses a different algorithm to iterate through the entries in the
+computed LCS. Instead of sticking to one side and showing element changes
+as insertions and deletions only, it will jump back and forth between
+the two sequences and report I<changes> occurring as deletions on one
+side followed immediatly by an insertion on the other side.
+
+In addition to the C<DISCARD_A>, C<DISCARD_B>, and C<MATCH> callbacks
+supported by C<traverse_sequences>, C<traverse_balanced> supports
+a C<CHANGE> callback indicating that one element got C<replaced> by another:
+
+ traverse_balanced(
+ \@seq1, \@seq2,
+ { MATCH => $callback_1,
+ DISCARD_A => $callback_2,
+ DISCARD_B => $callback_3,
+ CHANGE => $callback_4,
+ }
+ );
+
+If no C<CHANGE> callback is specified, C<traverse_balanced>
+will map C<CHANGE> events to C<DISCARD_A> and C<DISCARD_B> actions,
+therefore resulting in a similar behaviour as C<traverse_sequences>
+with different order of events.
+
+C<traverse_balanced> might be a bit slower than C<traverse_sequences>,
+noticable only while processing huge amounts of data.
+
+The C<sdiff> function of this module
+is implemented as call to C<traverse_balanced>.
+
+C<traverse_balanced> does not have a useful return value; you are expected to
+plug in the appropriate behavior with the callback functions.
+
+=head1 KEY GENERATION FUNCTIONS
+
+Most of the functions accept an optional extra parameter. This is a
+CODE reference to a key generating (hashing) function that should return
+a string that uniquely identifies a given element. It should be the
+case that if two elements are to be considered equal, their keys should
+be the same (and the other way around). If no key generation function
+is provided, the key will be the element as a string.
+
+By default, comparisons will use "eq" and elements will be turned into keys
+using the default stringizing operator '""'.
+
+Where this is important is when you're comparing something other than
+strings. If it is the case that you have multiple different objects
+that should be considered to be equal, you should supply a key
+generation function. Otherwise, you have to make sure that your arrays
+contain unique references.
+
+For instance, consider this example:
+
+ package Person;
+
+ sub new
+ {
+ my $package = shift;
+ return bless { name => '', ssn => '', @_ }, $package;
+ }
+
+ sub clone
+ {
+ my $old = shift;
+ my $new = bless { %$old }, ref($old);
+ }
+
+ sub hash
+ {
+ return shift()->{'ssn'};
+ }
+
+ my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );
+ my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );
+ my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );
+ my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );
+ my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );
+
+If you did this:
+
+ my $array1 = [ $person1, $person2, $person4 ];
+ my $array2 = [ $person1, $person3, $person4, $person5 ];
+ Algorithm::Diff::diff( $array1, $array2 );
+
+everything would work out OK (each of the objects would be converted
+into a string like "Person=HASH(0x82425b0)" for comparison).
+
+But if you did this:
+
+ my $array1 = [ $person1, $person2, $person4 ];
+ my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
+ Algorithm::Diff::diff( $array1, $array2 );
+
+$person4 and $person4->clone() (which have the same name and SSN)
+would be seen as different objects. If you wanted them to be considered
+equivalent, you would have to pass in a key generation function:
+
+ my $array1 = [ $person1, $person2, $person4 ];
+ my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
+ Algorithm::Diff::diff( $array1, $array2, \&Person::hash );
+
+This would use the 'ssn' field in each Person as a comparison key, and
+so would consider $person4 and $person4->clone() as equal.
+
+You may also pass additional parameters to the key generation function
+if you wish.
+
+=head1 ERROR CHECKING
+
+If you pass these routines a non-reference and they expect a reference,
+they will die with a message.
+
+=head1 AUTHOR
+
+This version released by Tye McQueen (http://perlmonks.org/?node=tye).
+
+=head1 LICENSE
+
+Parts Copyright (c) 2000-2004 Ned Konz. All rights reserved.
+Parts by Tye McQueen.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl.
+
+=head1 MAILING LIST
+
+Mark-Jason still maintains a mailing list. To join a low-volume mailing
+list for announcements related to diff and Algorithm::Diff, send an
+empty mail message to mjd-perl-diff-request@plover.com.
+
+=head1 CREDITS
+
+Versions through 0.59 (and much of this documentation) were written by:
+
+Mark-Jason Dominus, mjd-perl-diff@plover.com
+
+This version borrows some documentation and routine names from
+Mark-Jason's, but Diff.pm's code was completely replaced.
+
+This code was adapted from the Smalltalk code of Mario Wolczko
+<mario@wolczko.com>, which is available at
+ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
+
+C<sdiff> and C<traverse_balanced> were written by Mike Schilli
+<m@perlmeister.com>.
+
+The algorithm is that described in
+I<A Fast Algorithm for Computing Longest Common Subsequences>,
+CACM, vol.20, no.5, pp.350-353, May 1977, with a few
+minor improvements to improve the speed.
+
+Much work was done by Ned Konz (perl@bike-nomad.com).
+
+The OO interface and some other changes are by Tye McQueen.
+
+=cut
--- /dev/null
+# This is a version of Algorithm::Diff that uses only a comparison function,
+# like versions <= 0.59 used to.
+# $Revision: 1.3 $
+
+package Algorithm::DiffOld;
+use strict;
+use vars qw($VERSION @EXPORT_OK @ISA @EXPORT);
+use integer; # see below in _replaceNextLargerWith() for mod to make
+ # if you don't use this
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw();
+@EXPORT_OK = qw(LCS diff traverse_sequences);
+$VERSION = 1.10; # manually tracking Algorithm::Diff
+
+# McIlroy-Hunt diff algorithm
+# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
+# by Ned Konz, perl@bike-nomad.com
+
+=head1 NAME
+
+Algorithm::DiffOld - Compute `intelligent' differences between two files / lists
+but use the old (<=0.59) interface.
+
+=head1 NOTE
+
+This has been provided as part of the Algorithm::Diff package by Ned Konz.
+This particular module is B<ONLY> for people who B<HAVE> to have the old
+interface, which uses a comparison function rather than a key generating
+function.
+
+Because each of the lines in one array have to be compared with each
+of the lines in the other array, this does M*N comparisions. This can
+be very slow. I clocked it at taking 18 times as long as the stock
+version of Algorithm::Diff for a 4000-line file. It will get worse
+quadratically as array sizes increase.
+
+=head1 SYNOPSIS
+
+ use Algorithm::DiffOld qw(diff LCS traverse_sequences);
+
+ @lcs = LCS( \@seq1, \@seq2, $comparison_function );
+
+ $lcsref = LCS( \@seq1, \@seq2, $comparison_function );
+
+ @diffs = diff( \@seq1, \@seq2, $comparison_function );
+
+ traverse_sequences( \@seq1, \@seq2,
+ { MATCH => $callback,
+ DISCARD_A => $callback,
+ DISCARD_B => $callback,
+ },
+ $comparison_function );
+
+=head1 COMPARISON FUNCTIONS
+
+Each of the main routines should be passed a comparison function. If you
+aren't passing one in, B<use Algorithm::Diff instead>.
+
+These functions should return a true value when two items should compare
+as equal.
+
+For instance,
+
+ @lcs = LCS( \@seq1, \@seq2, sub { my ($a, $b) = @_; $a eq $b } );
+
+but if that is all you're doing with your comparison function, just use
+Algorithm::Diff and let it do this (this is its default).
+
+Or:
+
+ sub someFunkyComparisonFunction
+ {
+ my ($a, $b) = @_;
+ $a =~ m{$b};
+ }
+
+ @diffs = diff( \@lines, \@patterns, \&someFunkyComparisonFunction );
+
+which would allow you to diff an array @lines which consists of text
+lines with an array @patterns which consists of regular expressions.
+
+This is actually the reason I wrote this version -- there is no way
+to do this with a key generation function as in the stock Algorithm::Diff.
+
+=cut
+
+# Find the place at which aValue would normally be inserted into the array. If
+# that place is already occupied by aValue, do nothing, and return undef. If
+# the place does not exist (i.e., it is off the end of the array), add it to
+# the end, otherwise replace the element at that point with aValue.
+# It is assumed that the array's values are numeric.
+# This is where the bulk (75%) of the time is spent in this module, so try to
+# make it fast!
+
+sub _replaceNextLargerWith
+{
+ my ( $array, $aValue, $high ) = @_;
+ $high ||= $#$array;
+
+ # off the end?
+ if ( $high == -1 || $aValue > $array->[ -1 ] )
+ {
+ push( @$array, $aValue );
+ return $high + 1;
+ }
+
+ # binary search for insertion point...
+ my $low = 0;
+ my $index;
+ my $found;
+ while ( $low <= $high )
+ {
+ $index = ( $high + $low ) / 2;
+# $index = int(( $high + $low ) / 2); # without 'use integer'
+ $found = $array->[ $index ];
+
+ if ( $aValue == $found )
+ {
+ return undef;
+ }
+ elsif ( $aValue > $found )
+ {
+ $low = $index + 1;
+ }
+ else
+ {
+ $high = $index - 1;
+ }
+ }
+
+ # now insertion point is in $low.
+ $array->[ $low ] = $aValue; # overwrite next larger
+ return $low;
+}
+
+# This method computes the longest common subsequence in $a and $b.
+
+# Result is array or ref, whose contents is such that
+# $a->[ $i ] == $b->[ $result[ $i ] ]
+# foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
+
+# An additional argument may be passed; this is a CODE ref to a comparison
+# routine. By default, comparisons will use "eq" .
+# Note that this routine will be called as many as M*N times, so make it fast!
+
+# Additional parameters, if any, will be passed to the key generation routine.
+
+sub _longestCommonSubsequence
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $compare = shift || sub { my $a = shift; my $b = shift; $a eq $b };
+
+ my $aStart = 0;
+ my $aFinish = $#$a;
+ my $bStart = 0;
+ my $bFinish = $#$b;
+ my $matchVector = [];
+
+ # First we prune off any common elements at the beginning
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[ $aStart ], $b->[ $bStart ], @_ ) )
+ {
+ $matchVector->[ $aStart++ ] = $bStart++;
+ }
+
+ # now the end
+ while ( $aStart <= $aFinish
+ and $bStart <= $bFinish
+ and &$compare( $a->[ $aFinish ], $b->[ $bFinish ], @_ ) )
+ {
+ $matchVector->[ $aFinish-- ] = $bFinish--;
+ }
+
+ my $thresh = [];
+ my $links = [];
+
+ my ( $i, $ai, $j, $k );
+ for ( $i = $aStart; $i <= $aFinish; $i++ )
+ {
+ $k = 0;
+ # look for each element of @b between $bStart and $bFinish
+ # that matches $a->[ $i ], in reverse order
+ for ($j = $bFinish; $j >= $bStart; $j--)
+ {
+ next if ! &$compare( $a->[$i], $b->[$j], @_ );
+ # optimization: most of the time this will be true
+ if ( $k
+ and $thresh->[ $k ] > $j
+ and $thresh->[ $k - 1 ] < $j )
+ {
+ $thresh->[ $k ] = $j;
+ }
+ else
+ {
+ $k = _replaceNextLargerWith( $thresh, $j, $k );
+ }
+
+ # oddly, it's faster to always test this (CPU cache?).
+ if ( defined( $k ) )
+ {
+ $links->[ $k ] =
+ [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
+ }
+ }
+ }
+
+ if ( @$thresh )
+ {
+ for ( my $link = $links->[ $#$thresh ]; $link; $link = $link->[ 0 ] )
+ {
+ $matchVector->[ $link->[ 1 ] ] = $link->[ 2 ];
+ }
+ }
+
+ return wantarray ? @$matchVector : $matchVector;
+}
+
+sub traverse_sequences
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $callbacks = shift || { };
+ my $compare = shift;
+ my $matchCallback = $callbacks->{'MATCH'} || sub { };
+ my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
+ my $finishedACallback = $callbacks->{'A_FINISHED'};
+ my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
+ my $finishedBCallback = $callbacks->{'B_FINISHED'};
+ my $matchVector = _longestCommonSubsequence( $a, $b, $compare, @_ );
+ # Process all the lines in match vector
+ my $lastA = $#$a;
+ my $lastB = $#$b;
+ my $bi = 0;
+ my $ai;
+ for ( $ai = 0; $ai <= $#$matchVector; $ai++ )
+ {
+ my $bLine = $matchVector->[ $ai ];
+ if ( defined( $bLine ) ) # matched
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
+ &$matchCallback( $ai, $bi++, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai, $bi, @_ );
+ }
+ }
+ # the last entry (if any) processed was a match.
+
+ if ( defined( $finishedBCallback ) && $ai <= $lastA )
+ {
+ &$finishedBCallback( $bi, @_ );
+ }
+ else
+ {
+ &$discardACallback( $ai++, $bi, @_ ) while ( $ai <= $lastA );
+ }
+
+ if ( defined( $finishedACallback ) && $bi <= $lastB )
+ {
+ &$finishedACallback( $ai, @_ );
+ }
+ else
+ {
+ &$discardBCallback( $ai, $bi++, @_ ) while ( $bi <= $lastB );
+ }
+ return 1;
+}
+
+sub LCS
+{
+ my $a = shift; # array ref
+ my $matchVector = _longestCommonSubsequence( $a, @_ );
+ my @retval;
+ my $i;
+ for ( $i = 0; $i <= $#$matchVector; $i++ )
+ {
+ if ( defined( $matchVector->[ $i ] ) )
+ {
+ push( @retval, $a->[ $i ] );
+ }
+ }
+ return wantarray ? @retval : \@retval;
+}
+
+sub diff
+{
+ my $a = shift; # array ref
+ my $b = shift; # array ref
+ my $retval = [];
+ my $hunk = [];
+ my $discard = sub { push( @$hunk, [ '-', $_[ 0 ], $a->[ $_[ 0 ] ] ] ) };
+ my $add = sub { push( @$hunk, [ '+', $_[ 1 ], $b->[ $_[ 1 ] ] ] ) };
+ my $match = sub { push( @$retval, $hunk ) if scalar(@$hunk); $hunk = [] };
+ traverse_sequences( $a, $b,
+ { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add },
+ @_ );
+ &$match();
+ return wantarray ? @$retval : $retval;
+}
+
+1;
--- /dev/null
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl base.t'
+use strict;
+$^W++;
+use lib qw(blib lib);
+use Algorithm::Diff qw(diff LCS traverse_sequences traverse_balanced sdiff);
+use Data::Dumper;
+use Test;
+
+BEGIN
+{
+ $|++;
+ plan tests => 35;
+ $SIG{__DIE__} = sub # breakpoint on die
+ {
+ $DB::single = 1;
+ $DB::single = 1; # avoid complaint
+ die @_;
+ }
+}
+
+my @a = qw(a b c e h j l m n p);
+my @b = qw(b c d e f j k l m r s t);
+my @correctResult = qw(b c e j l m);
+my $correctResult = join(' ', @correctResult);
+my $skippedA = 'a h n p';
+my $skippedB = 'd f k r s t';
+
+# From the Algorithm::Diff manpage:
+my $correctDiffResult = [
+ [ [ '-', 0, 'a' ] ],
+
+ [ [ '+', 2, 'd' ] ],
+
+ [ [ '-', 4, 'h' ], [ '+', 4, 'f' ] ],
+
+ [ [ '+', 6, 'k' ] ],
+
+ [
+ [ '-', 8, 'n' ],
+ [ '+', 9, 'r' ],
+ [ '-', 9, 'p' ],
+ [ '+', 10, 's' ],
+ [ '+', 11, 't' ],
+ ]
+];
+
+# Result of LCS must be as long as @a
+my @result = Algorithm::Diff::_longestCommonSubsequence( \@a, \@b );
+ok( scalar(grep { defined } @result),
+ scalar(@correctResult),
+ "length of _longestCommonSubsequence" );
+
+# result has b[] line#s keyed by a[] line#
+# print "result =", join(" ", map { defined($_) ? $_ : 'undef' } @result), "\n";
+
+my @aresult = map { defined( $result[$_] ) ? $a[$_] : () } 0 .. $#result;
+my @bresult =
+ map { defined( $result[$_] ) ? $b[ $result[$_] ] : () } 0 .. $#result;
+
+ok( "@aresult", $correctResult, "A results" );
+ok( "@bresult", $correctResult, "B results" );
+
+my ( @matchedA, @matchedB, @discardsA, @discardsB, $finishedA, $finishedB );
+
+sub match
+{
+ my ( $a, $b ) = @_;
+ push ( @matchedA, $a[$a] );
+ push ( @matchedB, $b[$b] );
+}
+
+sub discard_b
+{
+ my ( $a, $b ) = @_;
+ push ( @discardsB, $b[$b] );
+}
+
+sub discard_a
+{
+ my ( $a, $b ) = @_;
+ push ( @discardsA, $a[$a] );
+}
+
+sub finished_a
+{
+ my ( $a, $b ) = @_;
+ $finishedA = $a;
+}
+
+sub finished_b
+{
+ my ( $a, $b ) = @_;
+ $finishedB = $b;
+}
+
+traverse_sequences(
+ \@a,
+ \@b,
+ {
+ MATCH => \&match,
+ DISCARD_A => \&discard_a,
+ DISCARD_B => \&discard_b
+ }
+);
+
+ok( "@matchedA", $correctResult);
+ok( "@matchedB", $correctResult);
+ok( "@discardsA", $skippedA);
+ok( "@discardsB", $skippedB);
+
+@matchedA = @matchedB = @discardsA = @discardsB = ();
+$finishedA = $finishedB = undef;
+
+traverse_sequences(
+ \@a,
+ \@b,
+ {
+ MATCH => \&match,
+ DISCARD_A => \&discard_a,
+ DISCARD_B => \&discard_b,
+ A_FINISHED => \&finished_a,
+ B_FINISHED => \&finished_b,
+ }
+);
+
+ok( "@matchedA", $correctResult);
+ok( "@matchedB", $correctResult);
+ok( "@discardsA", $skippedA);
+ok( "@discardsB", $skippedB);
+ok( $finishedA, 9, "index of finishedA" );
+ok( $finishedB, undef, "index of finishedB" );
+
+my @lcs = LCS( \@a, \@b );
+ok( "@lcs", $correctResult );
+
+# Compare the diff output with the one from the Algorithm::Diff manpage.
+my $diff = diff( \@a, \@b );
+$Data::Dumper::Indent = 0;
+my $cds = Dumper($correctDiffResult);
+my $dds = Dumper($diff);
+ok( $dds, $cds );
+
+##################################################
+# <Mike Schilli> m@perlmeister.com 03/23/2002:
+# Tests for sdiff-interface
+#################################################
+
+@a = qw(abc def yyy xxx ghi jkl);
+@b = qw(abc dxf xxx ghi jkl);
+$correctDiffResult = [ ['u', 'abc', 'abc'],
+ ['c', 'def', 'dxf'],
+ ['-', 'yyy', ''],
+ ['u', 'xxx', 'xxx'],
+ ['u', 'ghi', 'ghi'],
+ ['u', 'jkl', 'jkl'] ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+
+#################################################
+@a = qw(a b c e h j l m n p);
+@b = qw(b c d e f j k l m r s t);
+$correctDiffResult = [ ['-', 'a', '' ],
+ ['u', 'b', 'b'],
+ ['u', 'c', 'c'],
+ ['+', '', 'd'],
+ ['u', 'e', 'e'],
+ ['c', 'h', 'f'],
+ ['u', 'j', 'j'],
+ ['+', '', 'k'],
+ ['u', 'l', 'l'],
+ ['u', 'm', 'm'],
+ ['c', 'n', 'r'],
+ ['c', 'p', 's'],
+ ['+', '', 't'],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a b c d e);
+@b = qw(a e);
+$correctDiffResult = [ ['u', 'a', 'a' ],
+ ['-', 'b', ''],
+ ['-', 'c', ''],
+ ['-', 'd', ''],
+ ['u', 'e', 'e'],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a e);
+@b = qw(a b c d e);
+$correctDiffResult = [ ['u', 'a', 'a' ],
+ ['+', '', 'b'],
+ ['+', '', 'c'],
+ ['+', '', 'd'],
+ ['u', 'e', 'e'],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(v x a e);
+@b = qw(w y a b c d e);
+$correctDiffResult = [
+ ['c', 'v', 'w' ],
+ ['c', 'x', 'y' ],
+ ['u', 'a', 'a' ],
+ ['+', '', 'b'],
+ ['+', '', 'c'],
+ ['+', '', 'd'],
+ ['u', 'e', 'e'],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(x a e);
+@b = qw(a b c d e);
+$correctDiffResult = [
+ ['-', 'x', '' ],
+ ['u', 'a', 'a' ],
+ ['+', '', 'b'],
+ ['+', '', 'c'],
+ ['+', '', 'd'],
+ ['u', 'e', 'e'],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a e);
+@b = qw(x a b c d e);
+$correctDiffResult = [
+ ['+', '', 'x' ],
+ ['u', 'a', 'a' ],
+ ['+', '', 'b'],
+ ['+', '', 'c'],
+ ['+', '', 'd'],
+ ['u', 'e', 'e'],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a e v);
+@b = qw(x a b c d e w x);
+$correctDiffResult = [
+ ['+', '', 'x' ],
+ ['u', 'a', 'a' ],
+ ['+', '', 'b'],
+ ['+', '', 'c'],
+ ['+', '', 'd'],
+ ['u', 'e', 'e'],
+ ['c', 'v', 'w'],
+ ['+', '', 'x'],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw();
+@b = qw(a b c);
+$correctDiffResult = [
+ ['+', '', 'a' ],
+ ['+', '', 'b' ],
+ ['+', '', 'c' ],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a b c);
+@b = qw();
+$correctDiffResult = [
+ ['-', 'a', '' ],
+ ['-', 'b', '' ],
+ ['-', 'c', '' ],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a b c);
+@b = qw(1);
+$correctDiffResult = [
+ ['c', 'a', '1' ],
+ ['-', 'b', '' ],
+ ['-', 'c', '' ],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a b c);
+@b = qw(c);
+$correctDiffResult = [
+ ['-', 'a', '' ],
+ ['-', 'b', '' ],
+ ['u', 'c', 'c' ],
+ ];
+@result = sdiff(\@a, \@b);
+ok(Dumper(\@result), Dumper($correctDiffResult));
+
+#################################################
+@a = qw(a b c);
+@b = qw(a x c);
+my $r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ CHANGE => sub { $r .= "C @_";},
+ } );
+ok($r, "M 0 0C 1 1M 2 2");
+
+#################################################
+# No CHANGE callback => use discard_a/b instead
+@a = qw(a b c);
+@b = qw(a x c);
+$r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ } );
+ok($r, "M 0 0DA 1 1DB 2 1M 2 2");
+
+#################################################
+@a = qw(a x y c);
+@b = qw(a v w c);
+$r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ CHANGE => sub { $r .= "C @_";},
+ } );
+ok($r, "M 0 0C 1 1C 2 2M 3 3");
+
+#################################################
+@a = qw(x y c);
+@b = qw(v w c);
+$r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ CHANGE => sub { $r .= "C @_";},
+ } );
+ok($r, "C 0 0C 1 1M 2 2");
+
+#################################################
+@a = qw(a x y z);
+@b = qw(b v w);
+$r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ CHANGE => sub { $r .= "C @_";},
+ } );
+ok($r, "C 0 0C 1 1C 2 2DA 3 3");
+
+#################################################
+@a = qw(a z);
+@b = qw(a);
+$r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ CHANGE => sub { $r .= "C @_";},
+ } );
+ok($r, "M 0 0DA 1 1");
+
+#################################################
+@a = qw(z a);
+@b = qw(a);
+$r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ CHANGE => sub { $r .= "C @_";},
+ } );
+ok($r, "DA 0 0M 1 0");
+
+#################################################
+@a = qw(a b c);
+@b = qw(x y z);
+$r = "";
+traverse_balanced( \@a, \@b,
+ { MATCH => sub { $r .= "M @_";},
+ DISCARD_A => sub { $r .= "DA @_";},
+ DISCARD_B => sub { $r .= "DB @_";},
+ CHANGE => sub { $r .= "C @_";},
+ } );
+ok($r, "C 0 0C 1 1C 2 2");
--- /dev/null
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl oo.t'
+use strict;
+BEGIN { $^W++; }
+use lib qw( blib lib );
+use Algorithm::Diff qw( compact_diff );
+use Data::Dumper;
+use Test qw( plan ok $ntest );
+
+BEGIN
+{
+ $|++;
+ plan( tests => 969 );
+ $SIG{__DIE__} = sub # breakpoint on die
+ {
+ $DB::single = 1
+ if ! $^S;
+ die @_;
+ };
+ $SIG{__WARN__} = sub # breakpoint on warn
+ {
+ $DB::single = 1;
+ warn @_;
+ };
+}
+
+sub Ok($$) { @_= reverse @_; goto &ok }
+
+my( $first, $a, $b, $hunks );
+for my $pair (
+ [ "a b c e h j l m n p",
+ " b c d e f j k l m r s t", 9 ],
+ [ "", "", 0 ],
+ [ "a b c", "", 1 ],
+ [ "", "a b c d", 1 ],
+ [ "a b", "x y z", 1 ],
+ [ " c e h j l m n p r",
+ "a b c d f g j k l m s t", 7 ],
+ [ "a b c d",
+ "a b c d", 1 ],
+ [ "a d",
+ "a b c d", 3 ],
+ [ "a b c d",
+ "a d", 3 ],
+ [ "a b c d",
+ " b c ", 3 ],
+ [ " b c ",
+ "a b c d", 3 ],
+) {
+ $first= $ntest;
+ ( $a, $b, $hunks )= @$pair;
+ my @a = split ' ', $a;
+ my @b = split ' ', $b;
+
+ my $d = Algorithm::Diff->new( \@a, \@b );
+
+ if( @ARGV ) {
+ print "1: $a$/2: $b$/";
+ while( $d->Next() ) {
+ printf "%10s %s %s$/",
+ join(' ',$d->Items(1)),
+ $d->Same() ? '=' : '|',
+ join(' ',$d->Items(2));
+ }
+ }
+
+ Ok( 0, $d->Base() );
+ Ok( 0, $d->Base(undef) );
+ Ok( 0, $d->Base(1) );
+ Ok( 1, $d->Base(undef) );
+ Ok( 1, $d->Base(0) );
+
+ ok( ! eval { $d->Diff(); 1 } );
+ ok( $@, qr/\breset\b/i );
+ ok( ! eval { $d->Same(); 1 } );
+ ok( $@, qr/\breset\b/i );
+ ok( ! eval { $d->Items(1); 1 } );
+ ok( $@, qr/\breset\b/i );
+ ok( ! eval { $d->Range(2); 1 } );
+ ok( $@, qr/\breset\b/i );
+ ok( ! eval { $d->Min(1); 1 } );
+ ok( $@, qr/\breset\b/i );
+ ok( ! eval { $d->Max(2); 1 } );
+ ok( $@, qr/\breset\b/i );
+ ok( ! eval { $d->Get('Min1'); 1 } );
+ ok( $@, qr/\breset\b/i );
+
+ ok( ! $d->Next(0) );
+ ok( ! eval { $d->Same(); 1 } );
+ ok( $@, qr/\breset\b/i );
+ Ok( 1, $d->Next() ) if 0 < $hunks;
+ Ok( 2, $d->Next(undef) ) if 1 < $hunks;
+ Ok( 3, $d->Next(1) ) if 2 < $hunks;
+ Ok( 2, $d->Next(-1) ) if 1 < $hunks;
+ ok( ! $d->Next(-2) );
+ ok( ! eval { $d->Same(); 1 } );
+ ok( $@, qr/\breset\b/i );
+
+ ok( ! $d->Prev(0) );
+ ok( ! eval { $d->Same(); 1 } );
+ ok( $@, qr/\breset\b/i );
+ Ok( -1, $d->Prev() ) if 0 < $hunks;
+ Ok( -2, $d->Prev(undef) ) if 1 < $hunks;
+ Ok( -3, $d->Prev(1) ) if 2 < $hunks;
+ Ok( -2, $d->Prev(-1) ) if 1 < $hunks;
+ ok( ! $d->Prev(-2) );
+
+ Ok( 1, $d->Next() ) if 0 < $hunks;
+ ok( ! $d->Prev() );
+ Ok( 1, $d->Next() ) if 0 < $hunks;
+ ok( ! $d->Prev(2) );
+ Ok( -1, $d->Prev() ) if 0 < $hunks;
+ ok( ! $d->Next() );
+ Ok( -1, $d->Prev() ) if 0 < $hunks;
+ ok( ! $d->Next(5) );
+
+ Ok( 1, $d->Next() ) if 0 < $hunks;
+ Ok( $d, $d->Reset() );
+ ok( ! $d->Prev(0) );
+ Ok( 3, $d->Reset(3)->Next(0) ) if 2 < $hunks;
+ Ok( -3, $d->Reset(-2)->Prev() ) if 2 < $hunks;
+ Ok( $hunks || !1, $d->Reset(0)->Next(-1) );
+
+ my $c = $d->Copy();
+ ok( $c->Base(), $d->Base() );
+ ok( $c->Next(0), $d->Next(0) );
+ ok( $d->Copy(-4)->Next(0),
+ $d->Copy()->Reset(-4)->Next(0) );
+
+ $c = $d->Copy( undef, 1 );
+ Ok( 1, $c->Base() );
+ ok( $c->Next(0), $d->Next(0) );
+
+ $d->Reset();
+ my( @A, @B );
+ while( $d->Next() ) {
+ if( $d->Same() ) {
+ Ok( 0, $d->Diff() );
+ ok( $d->Same(), $d->Range(2) );
+ ok( $d->Items(2), $d->Range(1) );
+ ok( "@{[$d->Same()]}",
+ "@{[$d->Items(1)]}" );
+ ok( "@{[$d->Items(1)]}",
+ "@{[$d->Items(2)]}" );
+ ok( "@{[$d->Items(2)]}",
+ "@a[$d->Range(1)]" );
+ ok( "@a[$d->Range(1,0)]",
+ "@b[$d->Range(2)]" );
+ push @A, $d->Same();
+ push @B, @b[$d->Range(2)];
+ } else {
+ Ok( 0, $d->Same() );
+ ok( $d->Diff() & 1, 1*!!$d->Range(1) );
+ ok( $d->Diff() & 2, 2*!!$d->Range(2) );
+ ok( "@{[$d->Items(1)]}",
+ "@a[$d->Range(1)]" );
+ ok( "@{[$d->Items(2)]}",
+ "@b[$d->Range(2,0)]" );
+ push @A, @a[$d->Range(1)];
+ push @B, $d->Items(2);
+ }
+ }
+ ok( "@A", "@a" );
+ ok( "@B", "@b" );
+
+ next if ! $hunks;
+
+ Ok( 1, $d->Next() );
+ { local $^W= 0;
+ ok( ! eval { $d->Items(); 1 } ); }
+ ok( ! eval { $d->Items(0); 1 } );
+ { local $^W= 0;
+ ok( ! eval { $d->Range(); 1 } ); }
+ ok( ! eval { $d->Range(3); 1 } );
+ { local $^W= 0;
+ ok( ! eval { $d->Min(); 1 } ); }
+ ok( ! eval { $d->Min(-1); 1 } );
+ { local $^W= 0;
+ ok( ! eval { $d->Max(); 1 } ); }
+ ok( ! eval { $d->Max(9); 1 } );
+
+ $d->Reset(-1);
+ $c= $d->Copy(undef,1);
+ ok( "@a[$d->Range(1)]",
+ "@{[(0,@a)[$c->Range(1)]]}" );
+ ok( "@b[$c->Range(2,0)]",
+ "@{[(0,@b)[$d->Range(2,1)]]}" );
+ ok( "@a[$d->Get('min1')..$d->Get('0Max1')]",
+ "@{[(0,@a)[$d->Get('1MIN1')..$c->Get('MAX1')]]}" );
+
+ ok( "@{[$c->Min(1),$c->Max(2,0)]}",
+ "@{[$c->Get('Min1','0Max2')]}" );
+ ok( ! eval { scalar $c->Get('Min1','0Max2'); 1 } );
+ ok( "@{[0+$d->Same(),$d->Diff(),$d->Base()]}",
+ "@{[$d->Get(qq<same Diff BASE>)]}" );
+ ok( "@{[0+$d->Range(1),0+$d->Range(2)]}",
+ "@{[$d->Get(qq<Range1 rAnGe2>)]}" );
+ { local $^W= 0;
+ ok( ! eval { $c->Get('range'); 1 } );
+ ok( ! eval { $c->Get('min'); 1 } );
+ ok( ! eval { $c->Get('max'); 1 } ); }
+
+} continue {
+ if( @ARGV ) {
+ my $tests= $ntest - $first;
+ print "$hunks hunks, $tests tests.$/";
+ }
+}
+
+# $d = Algorithm::Diff->new( \@a, \@b, {KeyGen=>sub...} );
+
+# @cdiffs = compact_diff( \@seq1, \@seq2 );
--- /dev/null
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+Format: 1.0
+Source: libalgorithm-diff-perl
+Binary: libalgorithm-diff-perl
+Architecture: all
+Version: 1.19.02-1
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: gregor herrmann <gregor+debian@comodo.priv.at>
+Homepage: http://search.cpan.org/dist/Algorithm-Diff/
+Standards-Version: 3.7.3
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libalgorithm-diff-perl/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libalgorithm-diff-perl/
+Build-Depends: debhelper (>= 5)
+Build-Depends-Indep: perl (>= 5.6.0-16)
+Files:
+ ff3e17ae485f8adfb8857b183991fbce 33529 libalgorithm-diff-perl_1.19.02.orig.tar.gz
+ dcef32c267f1f8955ae168b1a2256b3e 3250 libalgorithm-diff-perl_1.19.02-1.diff.gz
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.6 (GNU/Linux)
+
+iD8DBQFH1QQqHqjlqpcl9jsRAk4zAJ9N9ZqnSEkrkb1YxRPLtL6o/LaNpwCgts0y
+17YZq6b5k5dEIIqMy6E81Zk=
+=6+cJ
+-----END PGP SIGNATURE-----
--- /dev/null
+Format: 1.0
+Source: libalgorithm-diff-perl
+Version: 1.19.02-1maemo1
+Binary: libalgorithm-diff-perl
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Architecture: all
+Standards-Version: 3.7.3
+Build-Depends: debhelper (>= 5)
+Build-Depends-Indep: perl (>= 5.6.0-16)
+Uploaders: gregor herrmann <gregor+debian@comodo.priv.at>
+Files:
+ ff3e17ae485f8adfb8857b183991fbce 33529 libalgorithm-diff-perl_1.19.02.orig.tar.gz
+ 161cb9a9e0c9f31cb67509ed14f90a0c 3320 libalgorithm-diff-perl_1.19.02-1maemo1.diff.gz
--- /dev/null
+Format: 1.7
+Date: Wed, 14 Apr 2010 07:09:51 +0100
+Source: libalgorithm-diff-perl
+Binary: libalgorithm-diff-perl
+Architecture: source all
+Version: 1.19.02-1maemo1
+Distribution: fremantle
+Urgency: low
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Changed-By: Nito Martinez <Nito@Qindel.ES>
+Description:
+ libalgorithm-diff-perl - a perl library for finding Longest Common Sequences in text
+Changes:
+ libalgorithm-diff-perl (1.19.02-1maemo1) fremantle; urgency=low
+ .
+ * New Maemo packaging
+Files:
+ ee8443a24044661783215f6b4264b6a3 526 perl optional libalgorithm-diff-perl_1.19.02-1maemo1.dsc
+ 161cb9a9e0c9f31cb67509ed14f90a0c 3320 perl optional libalgorithm-diff-perl_1.19.02-1maemo1.diff.gz
+ 117881f1f9020a0ccff71382f64527cf 51688 perl optional libalgorithm-diff-perl_1.19.02-1maemo1_all.deb
--- /dev/null
+
+# Call.pm
+#
+# Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package Filter::Util::Call ;
+
+require 5.002 ;
+require DynaLoader;
+require Exporter;
+use Carp ;
+use strict;
+use warnings;
+use vars qw($VERSION @ISA @EXPORT) ;
+
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw( filter_add filter_del filter_read filter_read_exact) ;
+$VERSION = "1.07" ;
+
+sub filter_read_exact($)
+{
+ my ($size) = @_ ;
+ my ($left) = $size ;
+ my ($status) ;
+
+ croak ("filter_read_exact: size parameter must be > 0")
+ unless $size > 0 ;
+
+ # try to read a block which is exactly $size bytes long
+ while ($left and ($status = filter_read($left)) > 0) {
+ $left = $size - length $_ ;
+ }
+
+ # EOF with pending data is a special case
+ return 1 if $status == 0 and length $_ ;
+
+ return $status ;
+}
+
+sub filter_add($)
+{
+ my($obj) = @_ ;
+
+ # Did we get a code reference?
+ my $coderef = (ref $obj eq 'CODE') ;
+
+ # If the parameter isn't already a reference, make it one.
+ $obj = \$obj unless ref $obj ;
+
+ $obj = bless ($obj, (caller)[0]) unless $coderef ;
+
+ # finish off the installation of the filter in C.
+ Filter::Util::Call::real_import($obj, (caller)[0], $coderef) ;
+}
+
+bootstrap Filter::Util::Call ;
+
+1;
+__END__
+
+=head1 NAME
+
+Filter::Util::Call - Perl Source Filter Utility Module
+
+=head1 SYNOPSIS
+
+ use Filter::Util::Call ;
+
+=head1 DESCRIPTION
+
+This module provides you with the framework to write I<Source Filters>
+in Perl.
+
+An alternate interface to Filter::Util::Call is now available. See
+L<Filter::Simple> for more details.
+
+A I<Perl Source Filter> is implemented as a Perl module. The structure
+of the module can take one of two broadly similar formats. To
+distinguish between them, the first will be referred to as I<method
+filter> and the second as I<closure filter>.
+
+Here is a skeleton for the I<method filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+ filter_add([]) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ $status = filter_read() ;
+ $status ;
+ }
+
+ 1 ;
+
+and this is the equivalent skeleton for the I<closure filter>:
+
+ package MyFilter ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type, @arguments) = @_ ;
+
+ filter_add(
+ sub
+ {
+ my($status) ;
+ $status = filter_read() ;
+ $status ;
+ } )
+ }
+
+ 1 ;
+
+To make use of either of the two filter modules above, place the line
+below in a Perl source file.
+
+ use MyFilter;
+
+In fact, the skeleton modules shown above are fully functional I<Source
+Filters>, albeit fairly useless ones. All they does is filter the
+source stream without modifying it at all.
+
+As you can see both modules have a broadly similar structure. They both
+make use of the C<Filter::Util::Call> module and both have an C<import>
+method. The difference between them is that the I<method filter>
+requires a I<filter> method, whereas the I<closure filter> gets the
+equivalent of a I<filter> method with the anonymous sub passed to
+I<filter_add>.
+
+To make proper use of the I<closure filter> shown above you need to
+have a good understanding of the concept of a I<closure>. See
+L<perlref> for more details on the mechanics of I<closures>.
+
+=head2 B<use Filter::Util::Call>
+
+The following functions are exported by C<Filter::Util::Call>:
+
+ filter_add()
+ filter_read()
+ filter_read_exact()
+ filter_del()
+
+=head2 B<import()>
+
+The C<import> method is used to create an instance of the filter. It is
+called indirectly by Perl when it encounters the C<use MyFilter> line
+in a source file (See L<perlfunc/import> for more details on
+C<import>).
+
+It will always have at least one parameter automatically passed by Perl
+- this corresponds to the name of the package. In the example above it
+will be C<"MyFilter">.
+
+Apart from the first parameter, import can accept an optional list of
+parameters. These can be used to pass parameters to the filter. For
+example:
+
+ use MyFilter qw(a b c) ;
+
+will result in the C<@_> array having the following values:
+
+ @_ [0] => "MyFilter"
+ @_ [1] => "a"
+ @_ [2] => "b"
+ @_ [3] => "c"
+
+Before terminating, the C<import> function must explicitly install the
+filter by calling C<filter_add>.
+
+B<filter_add()>
+
+The function, C<filter_add>, actually installs the filter. It takes one
+parameter which should be a reference. The kind of reference used will
+dictate which of the two filter types will be used.
+
+If a CODE reference is used then a I<closure filter> will be assumed.
+
+If a CODE reference is not used, a I<method filter> will be assumed.
+In a I<method filter>, the reference can be used to store context
+information. The reference will be I<blessed> into the package by
+C<filter_add>.
+
+See the filters at the end of this documents for examples of using
+context information using both I<method filters> and I<closure
+filters>.
+
+=head2 B<filter() and anonymous sub>
+
+Both the C<filter> method used with a I<method filter> and the
+anonymous sub used with a I<closure filter> is where the main
+processing for the filter is done.
+
+The big difference between the two types of filter is that the I<method
+filter> uses the object passed to the method to store any context data,
+whereas the I<closure filter> uses the lexical variables that are
+maintained by the closure.
+
+Note that the single parameter passed to the I<method filter>,
+C<$self>, is the same reference that was passed to C<filter_add>
+blessed into the filter's package. See the example filters later on for
+details of using C<$self>.
+
+Here is a list of the common features of the anonymous sub and the
+C<filter()> method.
+
+=over 5
+
+=item B<$_>
+
+Although C<$_> doesn't actually appear explicitly in the sample filters
+above, it is implicitly used in a number of places.
+
+Firstly, when either C<filter> or the anonymous sub are called, a local
+copy of C<$_> will automatically be created. It will always contain the
+empty string at this point.
+
+Next, both C<filter_read> and C<filter_read_exact> will append any
+source data that is read to the end of C<$_>.
+
+Finally, when C<filter> or the anonymous sub are finished processing,
+they are expected to return the filtered source using C<$_>.
+
+This implicit use of C<$_> greatly simplifies the filter.
+
+=item B<$status>
+
+The status value that is returned by the user's C<filter> method or
+anonymous sub and the C<filter_read> and C<read_exact> functions take
+the same set of values, namely:
+
+ < 0 Error
+ = 0 EOF
+ > 0 OK
+
+=item B<filter_read> and B<filter_read_exact>
+
+These functions are used by the filter to obtain either a line or block
+from the next filter in the chain or the actual source file if there
+aren't any other filters.
+
+The function C<filter_read> takes two forms:
+
+ $status = filter_read() ;
+ $status = filter_read($size) ;
+
+The first form is used to request a I<line>, the second requests a
+I<block>.
+
+In line mode, C<filter_read> will append the next source line to the
+end of the C<$_> scalar.
+
+In block mode, C<filter_read> will append a block of data which is <=
+C<$size> to the end of the C<$_> scalar. It is important to emphasise
+the that C<filter_read> will not necessarily read a block which is
+I<precisely> C<$size> bytes.
+
+If you need to be able to read a block which has an exact size, you can
+use the function C<filter_read_exact>. It works identically to
+C<filter_read> in block mode, except it will try to read a block which
+is exactly C<$size> bytes in length. The only circumstances when it
+will not return a block which is C<$size> bytes long is on EOF or
+error.
+
+It is I<very> important to check the value of C<$status> after I<every>
+call to C<filter_read> or C<filter_read_exact>.
+
+=item B<filter_del>
+
+The function, C<filter_del>, is used to disable the current filter. It
+does not affect the running of the filter. All it does is tell Perl not
+to call filter any more.
+
+See L<Example 4: Using filter_del> for details.
+
+=back
+
+=head1 EXAMPLES
+
+Here are a few examples which illustrate the key concepts - as such
+most of them are of little practical use.
+
+The C<examples> sub-directory has copies of all these filters
+implemented both as I<method filters> and as I<closure filters>.
+
+=head2 Example 1: A simple filter.
+
+Below is a I<method filter> which is hard-wired to replace all
+occurrences of the string C<"Joe"> to C<"Jim">. Not particularly
+Useful, but it is the first example and I wanted to keep it simple.
+
+ package Joe2Jim ;
+
+ use Filter::Util::Call ;
+
+ sub import
+ {
+ my($type) = @_ ;
+
+ filter_add(bless []) ;
+ }
+
+ sub filter
+ {
+ my($self) = @_ ;
+ my($status) ;
+
+ s/Joe/Jim/g
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ }
+
+ 1 ;
+
+Here is an example of using the filter:
+
+ use Joe2Jim ;
+ print "Where is Joe?\n" ;
+
+And this is what the script above will print:
+
+ Where is Jim?
+
+=head2 Example 2: Using the context
+
+The previous example was not particularly useful. To make it more
+general purpose we will make use of the context data and allow any
+arbitrary I<from> and I<to> strings to be used. This time we will use a
+I<closure filter>. To reflect its enhanced role, the filter is called
+C<Subst>.
+
+ package Subst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ croak("usage: use Subst qw(from to)")
+ unless @_ == 3 ;
+ my ($self, $from, $to) = @_ ;
+ filter_add(
+ sub
+ {
+ my ($status) ;
+ s/$from/$to/
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ })
+ }
+ 1 ;
+
+and is used like this:
+
+ use Subst qw(Joe Jim) ;
+ print "Where is Joe?\n" ;
+
+
+=head2 Example 3: Using the context within the filter
+
+Here is a filter which a variation of the C<Joe2Jim> filter. As well as
+substituting all occurrences of C<"Joe"> to C<"Jim"> it keeps a count
+of the number of substitutions made in the context object.
+
+Once EOF is detected (C<$status> is zero) the filter will insert an
+extra line into the source stream. When this extra line is executed it
+will print a count of the number of substitutions actually made.
+Note that C<$status> is set to C<1> in this case.
+
+ package Count ;
+
+ use Filter::Util::Call ;
+
+ sub filter
+ {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0 ) {
+ s/Joe/Jim/g ;
+ ++ $$self ;
+ }
+ elsif ($$self >= 0) { # EOF
+ $_ = "print q[Made ${$self} substitutions\n]" ;
+ $status = 1 ;
+ $$self = -1 ;
+ }
+
+ $status ;
+ }
+
+ sub import
+ {
+ my ($self) = @_ ;
+ my ($count) = 0 ;
+ filter_add(\$count) ;
+ }
+
+ 1 ;
+
+Here is a script which uses it:
+
+ use Count ;
+ print "Hello Joe\n" ;
+ print "Where is Joe\n" ;
+
+Outputs:
+
+ Hello Jim
+ Where is Jim
+ Made 2 substitutions
+
+=head2 Example 4: Using filter_del
+
+Another variation on a theme. This time we will modify the C<Subst>
+filter to allow a starting and stopping pattern to be specified as well
+as the I<from> and I<to> patterns. If you know the I<vi> editor, it is
+the equivalent of this command:
+
+ :/start/,/stop/s/from/to/
+
+When used as a filter we want to invoke it like this:
+
+ use NewSubst qw(start stop from to) ;
+
+Here is the module.
+
+ package NewSubst ;
+
+ use Filter::Util::Call ;
+ use Carp ;
+
+ sub import
+ {
+ my ($self, $start, $stop, $from, $to) = @_ ;
+ my ($found) = 0 ;
+ croak("usage: use Subst qw(start stop from to)")
+ unless @_ == 5 ;
+
+ filter_add(
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+
+ $found = 1
+ if $found == 0 and /$start/ ;
+
+ if ($found) {
+ s/$from/$to/ ;
+ filter_del() if /$stop/ ;
+ }
+
+ }
+ $status ;
+ } )
+
+ }
+
+ 1 ;
+
+=head1 Filter::Simple
+
+If you intend using the Filter::Call functionality, I would strongly
+recommend that you check out Damian Conway's excellent Filter::Simple
+module. Damian's module provides a much cleaner interface than
+Filter::Util::Call. Although it doesn't allow the fine control that
+Filter::Util::Call does, it should be adequate for the majority of
+applications. It's available at
+
+ http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
+ http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+26th January 1996
+
+=cut
+
--- /dev/null
+/*
+ * Filename : Call.xs
+ *
+ * Author : Paul Marquess
+ * Date : 11th November 2001
+ * Version : 1.06
+ *
+ * Copyright (c) 1995-2001 Paul Marquess. All rights reserved.
+ * This program is free software; you can redistribute it and/or
+ * modify it under the same terms as Perl itself.
+ *
+ */
+
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#ifdef _NOT_CORE
+# include "ppport.h"
+#endif
+
+/* Internal defines */
+#define PERL_MODULE(s) IoBOTTOM_NAME(s)
+#define PERL_OBJECT(s) IoTOP_GV(s)
+#define FILTER_ACTIVE(s) IoLINES(s)
+#define BUF_OFFSET(sv) IoPAGE_LEN(sv)
+#define CODE_REF(sv) IoPAGE(sv)
+#ifndef PERL_FILTER_EXISTS
+# define PERL_FILTER_EXISTS(i) (PL_rsfp_filters && (i) <= av_len(PL_rsfp_filters))
+#endif
+
+#define SET_LEN(sv,len) \
+ do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
+
+
+/* Global Data */
+
+#define MY_CXT_KEY "Filter::Util::Call::_guts" XS_VERSION
+
+typedef struct {
+ int x_fdebug ;
+ int x_current_idx ;
+} my_cxt_t;
+
+START_MY_CXT
+
+#define fdebug (MY_CXT.x_fdebug)
+#define current_idx (MY_CXT.x_current_idx)
+
+
+static I32
+filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
+{
+ dMY_CXT;
+ SV *my_sv = FILTER_DATA(idx);
+ char *nl = "\n";
+ char *p;
+ char *out_ptr;
+ int n;
+
+ if (fdebug)
+ warn("**** In filter_call - maxlen = %d, out len buf = %d idx = %d my_sv = %d [%s]\n",
+ maxlen, SvCUR(buf_sv), idx, SvCUR(my_sv), SvPVX(my_sv) ) ;
+
+ while (1) {
+
+ /* anything left from last time */
+ if ((n = SvCUR(my_sv))) {
+
+ out_ptr = SvPVX(my_sv) + BUF_OFFSET(my_sv) ;
+
+ if (maxlen) {
+ /* want a block */
+ if (fdebug)
+ warn("BLOCK(%d): size = %d, maxlen = %d\n",
+ idx, n, maxlen) ;
+
+ sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
+ if(n <= maxlen) {
+ BUF_OFFSET(my_sv) = 0 ;
+ SET_LEN(my_sv, 0) ;
+ }
+ else {
+ BUF_OFFSET(my_sv) += maxlen ;
+ SvCUR_set(my_sv, n - maxlen) ;
+ }
+ return SvCUR(buf_sv);
+ }
+ else {
+ /* want lines */
+ if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
+
+ sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
+
+ n = n - (p - out_ptr + 1);
+ BUF_OFFSET(my_sv) += (p - out_ptr + 1);
+ SvCUR_set(my_sv, n) ;
+ if (fdebug)
+ warn("recycle %d - leaving %d, returning %d [%s]",
+ idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
+
+ return SvCUR(buf_sv);
+ }
+ else /* no EOL, so append the complete buffer */
+ sv_catpvn(buf_sv, out_ptr, n) ;
+ }
+
+ }
+
+
+ SET_LEN(my_sv, 0) ;
+ BUF_OFFSET(my_sv) = 0 ;
+
+ if (FILTER_ACTIVE(my_sv))
+ {
+ dSP ;
+ int count ;
+
+ if (fdebug)
+ warn("gonna call %s::filter\n", PERL_MODULE(my_sv)) ;
+
+ ENTER ;
+ SAVETMPS;
+
+ SAVEINT(current_idx) ; /* save current idx */
+ current_idx = idx ;
+
+ SAVESPTR(DEFSV) ; /* save $_ */
+ /* make $_ use our buffer */
+ DEFSV = sv_2mortal(newSVpv("", 0)) ;
+
+ PUSHMARK(sp) ;
+
+ if (CODE_REF(my_sv)) {
+ /* if (SvROK(PERL_OBJECT(my_sv)) && SvTYPE(SvRV(PERL_OBJECT(my_sv))) == SVt_PVCV) { */
+ count = perl_call_sv((SV*)PERL_OBJECT(my_sv), G_SCALAR);
+ }
+ else {
+ XPUSHs((SV*)PERL_OBJECT(my_sv)) ;
+
+ PUTBACK ;
+
+ count = perl_call_method("filter", G_SCALAR);
+ }
+
+ SPAGAIN ;
+
+ if (count != 1)
+ croak("Filter::Util::Call - %s::filter returned %d values, 1 was expected \n",
+ PERL_MODULE(my_sv), count ) ;
+
+ n = POPi ;
+
+ if (fdebug)
+ warn("status = %d, length op buf = %d [%s]\n",
+ n, SvCUR(DEFSV), SvPVX(DEFSV) ) ;
+ if (SvCUR(DEFSV))
+ sv_setpvn(my_sv, SvPVX(DEFSV), SvCUR(DEFSV)) ;
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+ }
+ else
+ n = FILTER_READ(idx + 1, my_sv, maxlen) ;
+
+ if (n <= 0)
+ {
+ /* Either EOF or an error */
+
+ if (fdebug)
+ warn ("filter_read %d returned %d , returning %d\n", idx, n,
+ (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
+
+ /* PERL_MODULE(my_sv) ; */
+ /* PERL_OBJECT(my_sv) ; */
+ filter_del(filter_call);
+
+ /* If error, return the code */
+ if (n < 0)
+ return n ;
+
+ /* return what we have so far else signal eof */
+ return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
+ }
+
+ }
+}
+
+
+
+MODULE = Filter::Util::Call PACKAGE = Filter::Util::Call
+
+REQUIRE: 1.924
+PROTOTYPES: ENABLE
+
+#define IDX current_idx
+
+int
+filter_read(size=0)
+ int size
+ CODE:
+ {
+ dMY_CXT;
+ SV * buffer = DEFSV ;
+
+ RETVAL = FILTER_READ(IDX + 1, buffer, size) ;
+ }
+ OUTPUT:
+ RETVAL
+
+
+
+
+void
+real_import(object, perlmodule, coderef)
+ SV * object
+ char * perlmodule
+ int coderef
+ PPCODE:
+ {
+ SV * sv = newSV(1) ;
+
+ (void)SvPOK_only(sv) ;
+ filter_add(filter_call, sv) ;
+
+ PERL_MODULE(sv) = savepv(perlmodule) ;
+ PERL_OBJECT(sv) = (GV*) newSVsv(object) ;
+ FILTER_ACTIVE(sv) = TRUE ;
+ BUF_OFFSET(sv) = 0 ;
+ CODE_REF(sv) = coderef ;
+
+ SvCUR_set(sv, 0) ;
+
+ }
+
+void
+filter_del()
+ CODE:
+ dMY_CXT;
+ if (PERL_FILTER_EXISTS(IDX) && FILTER_DATA(IDX) && FILTER_ACTIVE(FILTER_DATA(IDX)))
+ FILTER_ACTIVE(FILTER_DATA(IDX)) = FALSE ;
+
+
+
+void
+unimport(package="$Package", ...)
+ char *package
+ PPCODE:
+ filter_del(filter_call);
+
+
+BOOT:
+ {
+ MY_CXT_INIT;
+ fdebug = 0;
+ /* temporary hack to control debugging in toke.c */
+ if (fdebug)
+ filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
+ }
+
+
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Filter::Util::Call',
+ DEFINE => '-D_NOT_CORE',
+ VERSION_FROM => 'Call.pm',
+);
--- /dev/null
+/* This file is Based on output from
+ * Perl/Pollution/Portability Version 2.0000 */
+
+#ifndef _P_P_PORTABILITY_H_
+#define _P_P_PORTABILITY_H_
+
+#ifndef PERL_REVISION
+# ifndef __PATCHLEVEL_H_INCLUDED__
+# include "patchlevel.h"
+# endif
+# ifndef PERL_REVISION
+# define PERL_REVISION (5)
+ /* Replace: 1 */
+# define PERL_VERSION PATCHLEVEL
+# define PERL_SUBVERSION SUBVERSION
+ /* Replace PERL_PATCHLEVEL with PERL_VERSION */
+ /* Replace: 0 */
+# endif
+#endif
+
+#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
+
+#ifndef ERRSV
+# define ERRSV perl_get_sv("@",FALSE)
+#endif
+
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
+/* Replace: 1 */
+# define PL_Sv Sv
+# define PL_compiling compiling
+# define PL_copline copline
+# define PL_curcop curcop
+# define PL_curstash curstash
+# define PL_defgv defgv
+# define PL_dirty dirty
+# define PL_hints hints
+# define PL_na na
+# define PL_perldb perldb
+# define PL_rsfp_filters rsfp_filters
+# define PL_rsfp rsfp
+# define PL_stdingv stdingv
+# define PL_sv_no sv_no
+# define PL_sv_undef sv_undef
+# define PL_sv_yes sv_yes
+/* Replace: 0 */
+#endif
+
+#ifndef pTHX
+# define pTHX
+# define pTHX_
+# define aTHX
+# define aTHX_
+#endif
+
+#ifndef PTR2IV
+# define PTR2IV(d) (IV)(d)
+#endif
+
+#ifndef INT2PTR
+# define INT2PTR(any,d) (any)(d)
+#endif
+
+#ifndef dTHR
+# ifdef WIN32
+# define dTHR extern int Perl___notused
+# else
+# define dTHR extern int errno
+# endif
+#endif
+
+#ifndef boolSV
+# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
+#endif
+
+#ifndef gv_stashpvn
+# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
+#endif
+
+#ifndef newSVpvn
+# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
+#endif
+
+#ifndef Pid_t
+# define Pid_t pid_t
+#endif
+
+#ifndef newRV_inc
+/* Replace: 1 */
+# define newRV_inc(sv) newRV(sv)
+/* Replace: 0 */
+#endif
+
+/* DEFSV appears first in 5.004_56 */
+#ifndef DEFSV
+# define DEFSV GvSV(PL_defgv)
+#endif
+
+#ifndef SAVE_DEFSV
+# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
+#endif
+
+#ifndef newRV_noinc
+# ifdef __GNUC__
+# define newRV_noinc(sv) \
+ ({ \
+ SV *nsv = (SV*)newRV(sv); \
+ SvREFCNT_dec(sv); \
+ nsv; \
+ })
+# else
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+static SV * newRV_noinc (SV * sv)
+{
+ SV *nsv = (SV*)newRV(sv);
+ SvREFCNT_dec(sv);
+ return nsv;
+}
+# else
+# define newRV_noinc(sv) \
+ ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
+# endif
+# endif
+#endif
+
+/* Provide: newCONSTSUB */
+
+/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
+#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
+
+#if defined(NEED_newCONSTSUB)
+static
+#else
+extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
+#endif
+
+#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
+void
+newCONSTSUB(stash,name,sv)
+HV *stash;
+char *name;
+SV *sv;
+{
+ U32 oldhints = PL_hints;
+ HV *old_cop_stash = PL_curcop->cop_stash;
+ HV *old_curstash = PL_curstash;
+ line_t oldline = PL_curcop->cop_line;
+ PL_curcop->cop_line = PL_copline;
+
+ PL_hints &= ~HINT_BLOCK_SCOPE;
+ if (stash)
+ PL_curstash = PL_curcop->cop_stash = stash;
+
+ newSUB(
+
+#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
+ /* before 5.003_22 */
+ start_subparse(),
+#else
+# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
+ /* 5.003_22 */
+ start_subparse(0),
+# else
+ /* 5.003_23 onwards */
+ start_subparse(FALSE, 0),
+# endif
+#endif
+
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ PL_hints = oldhints;
+ PL_curcop->cop_stash = old_cop_stash;
+ PL_curstash = old_curstash;
+ PL_curcop->cop_line = oldline;
+}
+#endif
+
+#endif /* newCONSTSUB */
+
+
+#ifndef START_MY_CXT
+
+/*
+ * Boilerplate macros for initializing and accessing interpreter-local
+ * data from C. All statics in extensions should be reworked to use
+ * this, if you want to make the extension thread-safe. See ext/re/re.xs
+ * for an example of the use of these macros.
+ *
+ * Code that uses these macros is responsible for the following:
+ * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
+ * 2. Declare a typedef named my_cxt_t that is a structure that contains
+ * all the data that needs to be interpreter-local.
+ * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
+ * 4. Use the MY_CXT_INIT macro such that it is called exactly once
+ * (typically put in the BOOT: section).
+ * 5. Use the members of the my_cxt_t structure everywhere as
+ * MY_CXT.member.
+ * 6. Use the dMY_CXT macro (a declaration) in all the functions that
+ * access MY_CXT.
+ */
+
+#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
+ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
+
+/* This must appear in all extensions that define a my_cxt_t structure,
+ * right after the definition (i.e. at file scope). The non-threads
+ * case below uses it to declare the data as static. */
+#define START_MY_CXT
+
+#if PERL_REVISION == 5 && \
+ (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
+/* Fetches the SV that keeps the per-interpreter data. */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
+#else /* >= perl5.004_68 */
+#define dMY_CXT_SV \
+ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
+ sizeof(MY_CXT_KEY)-1, TRUE)
+#endif /* < perl5.004_68 */
+
+/* This declaration should be used within all functions that use the
+ * interpreter-local data. */
+#define dMY_CXT \
+ dMY_CXT_SV; \
+ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
+
+/* Creates and zeroes the per-interpreter data.
+ * (We allocate my_cxtp in a Perl SV so that it will be released when
+ * the interpreter goes away.) */
+#define MY_CXT_INIT \
+ dMY_CXT_SV; \
+ /* newSV() allocates one more than needed */ \
+ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
+ Zero(my_cxtp, 1, my_cxt_t); \
+ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
+
+/* This macro must be used to access members of the my_cxt_t structure.
+ * e.g. MYCXT.some_data */
+#define MY_CXT (*my_cxtp)
+
+/* Judicious use of these macros can reduce the number of times dMY_CXT
+ * is used. Use is similar to pTHX, aTHX etc. */
+#define pMY_CXT my_cxt_t *my_cxtp
+#define pMY_CXT_ pMY_CXT,
+#define _pMY_CXT ,pMY_CXT
+#define aMY_CXT my_cxtp
+#define aMY_CXT_ aMY_CXT,
+#define _aMY_CXT ,aMY_CXT
+
+#else /* single interpreter */
+
+#ifndef NOOP
+# define NOOP (void)0
+#endif
+
+#ifdef HASATTRIBUTE
+# define PERL_UNUSED_DECL __attribute__((unused))
+#else
+# define PERL_UNUSED_DECL
+#endif
+
+#ifndef dNOOP
+# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
+#endif
+
+#define START_MY_CXT static my_cxt_t my_cxt;
+#define dMY_CXT_SV dNOOP
+#define dMY_CXT dNOOP
+#define MY_CXT_INIT NOOP
+#define MY_CXT my_cxt
+
+#define pMY_CXT void
+#define pMY_CXT_
+#define _pMY_CXT
+#define aMY_CXT
+#define aMY_CXT_
+#define _aMY_CXT
+
+#endif
+
+#endif /* START_MY_CXT */
+
+
+#endif /* _P_P_PORTABILITY_H_ */
--- /dev/null
+
+1.02 Tuesday 20th June 1995
+----
+
+ * First release.
+
+1.03 Sunday 25th June 1995
+----
+
+ * Tidied up the build process so that it doesn't need an empty
+ Filter.xs file.
+
+1.04 Sunday 25th June 1995
+----
+
+ * The test harness now uses $^X to invoke Perl.
+
+
+1.05 Monday 26th June 1995
+----
+
+ * updated MANIFEST
+
+ * tee.t test 5 has been hard-wired to return true if run as root.
+
+ * The test files don't use $^X to invoke perl any more. I've passed
+ the MakeMaker symbol FULLPERL via an environment variable. A bit
+ of a kludge, but it does work :-)
+
+ * added a mytest target to allow users to play with the Filters
+ without having to install them.
+
+ * The EWOULDBLOCK/EAGAIN stuff has been wrapped in preprocessor code.
+
+ * The hints files don't seem to be needed anymore.
+
+
+1.06 Sunday 2nd July 1995
+----
+
+ * Renamed decrypt.test to decrypt.tst.
+
+ * Renamed mytest.pl to mytest - it was getting installed.
+
+ * exec.xs had a bit of debugging code lurking around. This meant
+ that O_NONBLOCK was *always* being used to set non-blocking i/o.
+ This has been removed.
+
+ * Changed the way O_NONBLOCK/O_NDELAY was being detected. The Tk
+ method is now used.
+
+ * Addition of Filter::call - first go at implementation of perl filters.
+
+
+1.07 Wednesday 29th November 1995
+----
+
+ * exec now uses the non-blocking IO constants from Configure. Thanks
+ to Raphael for writing the dist module and to Andy for including it
+ in Configure.
+
+ * The decrypt filter has been enhanced to detect when it is
+ executing as a dynamically linked module and if DEBUGGING is
+ enabled. Thanks to Tim for providing the dynamic module test.
+
+ * Tim provided a pile of bug fixes for decrypt.xs
+
+ * Filter::call has been renamed Filter::Util::Call and the logic for
+ installing it has been changed.
+
+ * The workings of the filter method in Filter::Util::Call has been
+ changed.
+
+
+1.08 Friday 15th December 1995
+----
+
+ * Fixed a bug in Exec.xs - wait was being called without a parameter.
+
+ * Added a closure option to Call
+
+
+1.09 Wednesday 22nd April 1996
+----
+
+ * Fixed a warning in Exec.xs - added a cast to safefree
+
+ * Makefile.PL now uses VERSION_FROM
+
+ * Made all filter modules strict clean.
+
+ * The simple encrypt script supplied with the decryption filter will
+ now preserve the original file permissions. In addition if the
+ first line of the script begins with "#!", the line will be
+ preserved in the encrypted version.
+
+1.10 Thursday 20th June 1996
+----
+
+ * decrypt now calls filter_del.
+
+1.11 Tuesday 29th October 1996
+----
+
+ * test harness for decrypt doesn't display the debugger banner
+ message any more.
+
+ * casted uses of IoTOP_GV in Call.xs, decrypt.xs and Exec.xs to keep
+ the IRIX compiler happy.
+
+1.12 Tuesday 25th March 1997
+----
+
+ * Patch from Andreas Koenig to make tee.xs compile when useperio is
+ enabled.
+
+ * Fix Call interface to work with 5.003_94
+
+
+1.13 Monday 29th December 1997
+----
+
+ * added the order test harness.
+
+ * patch from Gurusamy Sarathy to get the filters to build and pass
+ all tests on NT.
+
+1.14 Thursday 1st January 1998
+----
+
+ * patch from Gurusamy Sarathy to allow the filters to build when
+ threading is enabled.
+
+1.15 Monday 26th October 1998
+----
+
+ * Fixed a bug in the tee filter.
+
+ * Applied patch from Gurusamy Sarathy which prevents Exec from coredump
+ when perl |is run with PERL_DESTRUCT_LEVEL.
+
+1.16 wednesday 17th March 1999
+----
+
+ * Upgraded to use the new PL_* symbols. Means the module can build with
+ Perl5.005_5*.
+
+1.17 Friday 10th December 1999
+----
+
+ * Addition of perlfilter.pod. This is the Source Filters article from
+ The Perl Journal, issue 11 and is identical to the file that is
+ distributed with Perl starting withversion 5.005_63.
+
+1.18 Sunday 2nd April 2000
+----
+
+ * Test harnesses are more robust on Win32.
+
+ * Fixed a problem where an __END__ or __DATA__ could crash Perl.
+
+1.19 Thursday 20th July 2000
+----
+
+ * Added a test in decrypt.xs to check if the Compiler backend is in use.
+ Thanks to Andrew Johnson for bringing this to my attention.
+
+1.20 Sunday 7th January 2001
+----
+
+ * Added a SYNOPSIS to Call.pm & Exec.pm
+
+ * Integrated perl core patches 7849, 7913 & 7931.
+
+ * Modified decrypt.t to fix a case where HP-UX didn't pass test 4.
+
+
+1.21 Monday 19th February 20001
+----
+
+ * Added logic in Makefile.PL to toggle between using $^W and
+ the warnings pragma in the module.
+
+ * The module, the examples & the test harness are now all strict
+ & warnings clean.
+
+1.22 Wednesday 21st February 20001
+----
+
+ * Added Michael G Schwern's example of a practical use of Filter::cpp
+ into the pod.
+
+ * Filter::cpp assumed that cpp.exe is always available on MSWin32. Logic
+ has been added to check for the existence of cpp.exe.
+
+ * Added a reference to Damian Conway's excellent Filter::Simple module.
+
+ * Merged Core patch 9176
+
+1.23 Monday 23rd April 2001
+----
+
+ * Modified Makefile.PL to only enable the warnings pragma if using perl
+ 5.6.1 or better.
+
+1.24
+----
+
+ * Fixed sh.t, exec.t & cpp.t to work properly on NT
+ patch courtesy of Steve Hay.
+
+ * The detection of cpp in cpp.pm is now more robust
+ patch courtesy of Michael Schwern
+
+ * Changed na to PL_na in decrypt.xs
+
+ * Merged Core patches 10752, 11434
+
+1.25
+----
+
+ * Fixed minor typo in Makefile.PL
+
+1.26
+----
+
+ * Call & Exec now use the CXT* macros
+
+ * moved all backward compatability code into ppport.h
+
+1.27
+----
+
+ * Patch from Wim Verhaegen to allow cpp to be an absolute path
+
+ * Patch from Gurusamy Sarathy to fix a Windods core dump in Exec.xs --
+ dMY_CXT was being accessed before it was ititialised.
+
+ * Merged core patch 13940
+
+1.28
+----
+
+ * Fixed bug in Filter::cpp where $Config{cppstdin} refered to an executable
+ with an absolute path. Bug spotted by P. Kent.
+
+1.29 29 June 2002
+----
+
+ * Fixed problem with sleep in Exec.xs. Patch provided by Charles Randall.
+
+ * Exec.xs now used waitpid, when available, instead or wait. Patch provided
+ by Richard Clamp.
+
+ * Also the place where the wait is called has been changed.
+ Deadlock condition spotted by Andrej Czapszys.
+
+1.30 16 August 2003
+----
+
+ * rewording of reference to Filter::Simple
+
+ * merged core patch 18269
+
+1.31 31 August 2005
+----
+
+ * added 'libscan' to Makefile.PL to stop .bak files being installed.
+ [rt.cpan.org: Ticket #14356 .bak files are being installed ]
+
+1.32 3 January 2006
+----
+
+ * Added core patch 26509 -- fix out by one bug in Call.xs
+ Problem reported & fixed by Gisle Aas.
+
+1.33 1 March 2007
+----
+
+ * fixed ninstr issue for 5.8.9
+
+ * added t/pod.t
+
+1.34 7 July 2007
+----
+
+ * Included Core patch #31200 - change to support perl 5.10 for
+ Filter::Util::Call
+
+ * Also included the equivalent changes for the other filters. Patch
+ kindly provided by Steve Hay.
+
--- /dev/null
+package Filter::Util::Exec ;
+
+require 5.002 ;
+require DynaLoader;
+use strict;
+use warnings;
+use vars qw(@ISA $VERSION) ;
+@ISA = qw(DynaLoader);
+$VERSION = "1.03" ;
+
+bootstrap Filter::Util::Exec ;
+1 ;
+__END__
+
+=head1 NAME
+
+Filter::Util::Exec - exec source filter
+
+=head1 SYNOPSIS
+
+ use Filter::Util::Exec;
+
+=head1 DESCRIPTION
+
+This module is provides the interface to allow the creation of I<Source
+Filters> which use a Unix coprocess.
+
+See L<Filter::exec>, L<Filter::cpp> and L<Filter::sh> for examples of
+the use of this module.
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+11th December 1995.
+
+=cut
+
--- /dev/null
+/*
+ * Filename : exec.xs
+ *
+ * Author : Paul Marquess
+ * Date : 26th March 2000
+ * Version : 1.05
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "../Call/ppport.h"
+
+#include <fcntl.h>
+
+/* Global Data */
+
+#define MY_CXT_KEY "Filter::Util::Exec::_guts" XS_VERSION
+
+typedef struct {
+ int x_fdebug ;
+#ifdef WIN32
+ int x_write_started;
+ int x_pipe_pid;
+#endif
+} my_cxt_t;
+
+START_MY_CXT
+
+#define fdebug (MY_CXT.x_fdebug)
+#ifdef WIN32
+#define write_started (MY_CXT.x_write_started)
+#define pipe_pid (MY_CXT.x_pipe_pid)
+#endif
+
+#ifdef PERL_FILTER_EXISTS
+# define CORE_FILTER_SCRIPT PL_parser->rsfp
+#else
+# define CORE_FILTER_SCRIPT PL_rsfp
+#endif
+
+
+#define PIPE_IN(sv) IoLINES(sv)
+#define PIPE_OUT(sv) IoPAGE(sv)
+#define PIPE_PID(sv) IoLINES_LEFT(sv)
+
+#define BUF_SV(sv) IoTOP_GV(sv)
+#define BUF_START(sv) SvPVX((SV*) BUF_SV(sv))
+#define BUF_SIZE(sv) SvCUR((SV*) BUF_SV(sv))
+#define BUF_NEXT(sv) IoFMT_NAME(sv)
+#define BUF_END(sv) (BUF_START(sv) + BUF_SIZE(sv))
+#define BUF_OFFSET(sv) IoPAGE_LEN(sv)
+
+#define SET_LEN(sv,len) \
+ do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
+
+#define BLOCKSIZE 100
+
+
+#ifdef WIN32
+
+typedef struct {
+ SV * sv;
+ int idx;
+#ifdef USE_THREADS
+ struct perl_thread * parent;
+#endif
+#ifdef USE_ITHREADS
+ PerlInterpreter * parent;
+#endif
+} thrarg;
+
+static void
+pipe_write(void *args)
+{
+ thrarg *targ = (thrarg *)args;
+ SV *sv = targ->sv;
+ int idx = targ->idx;
+ int pipe_in = PIPE_IN(sv) ;
+ int pipe_out = PIPE_OUT(sv) ;
+ int rawread_eof = 0;
+ int r,w,len;
+#ifdef USE_THREADS
+ /* use the parent's perl thread context */
+ SET_THR(targ->parent);
+#endif
+#ifdef USE_ITHREADS
+ PERL_SET_THX(targ->parent);
+#endif
+ {
+ dMY_CXT;
+ free(args);
+ for(;;)
+ {
+
+ /* get some raw data to stuff down the pipe */
+ /* But only when BUF_SV is empty */
+ if (!rawread_eof && BUF_NEXT(sv) >= BUF_END(sv)) {
+ /* empty BUF_SV */
+ SvCUR_set((SV*)BUF_SV(sv), 0) ;
+ if ((len = FILTER_READ(idx+1, (SV*) BUF_SV(sv), 0)) > 0) {
+ BUF_NEXT(sv) = BUF_START(sv);
+ if (fdebug)
+ warn ("*pipe_write(%d) Filt Rd returned %d %d [%*s]\n",
+ idx, len, BUF_SIZE(sv), BUF_SIZE(sv), BUF_START(sv)) ;
+ }
+ else {
+ /* eof, close write end of pipe after writing to it */
+ rawread_eof = 1;
+ }
+ }
+
+ /* write down the pipe */
+ if ((w = BUF_END(sv) - BUF_NEXT(sv)) > 0) {
+ errno = 0;
+ if ((w = write(pipe_out, BUF_NEXT(sv), w)) > 0) {
+ BUF_NEXT(sv) += w;
+ if (fdebug)
+ warn ("*pipe_write(%d) wrote %d bytes to pipe\n", idx, w) ;
+ }
+ else {
+ if (fdebug)
+ warn ("*pipe_write(%d) closing pipe_out errno = %d %s\n",
+ idx, errno, Strerror(errno)) ;
+ close(pipe_out) ;
+ CloseHandle((HANDLE)pipe_pid);
+ write_started = 0;
+ return;
+ }
+ }
+ else if (rawread_eof) {
+ if (fdebug)
+ warn ("*pipe_write(%d) closing pipe_out errno = %d %s\n",
+ idx, errno, Strerror(errno)) ;
+ close(pipe_out);
+ CloseHandle((HANDLE)pipe_pid);
+ write_started = 0;
+ return;
+ }
+ }
+ }
+}
+
+static int
+pipe_read(SV *sv, int idx, int maxlen)
+{
+ dMY_CXT;
+ int pipe_in = PIPE_IN(sv) ;
+ int pipe_out = PIPE_OUT(sv) ;
+
+ int r ;
+ int w ;
+ int len ;
+
+ if (fdebug)
+ warn ("*pipe_read(sv=%d, SvCUR(sv)=%d, idx=%d, maxlen=%d\n",
+ sv, SvCUR(sv), idx, maxlen) ;
+
+ if (!maxlen)
+ maxlen = 1024 ;
+
+ /* just make sure the SV is big enough */
+ SvGROW(sv, SvCUR(sv) + maxlen) ;
+
+ if ( !BUF_NEXT(sv) )
+ BUF_NEXT(sv) = BUF_START(sv);
+
+ if (!write_started) {
+ thrarg *targ = (thrarg*)malloc(sizeof(thrarg));
+ targ->sv = sv; targ->idx = idx;
+#ifdef USE_THREADS
+ targ->parent = THR;
+#endif
+#ifdef USE_ITHREADS
+ targ->parent = aTHX;
+#endif
+ /* thread handle is closed when pipe_write() returns */
+ _beginthread(pipe_write,0,(void *)targ);
+ write_started = 1;
+ }
+
+ /* try to get data from filter, if any */
+ errno = 0;
+ len = SvCUR(sv) ;
+ if ((r = read(pipe_in, SvPVX(sv) + len, maxlen)) > 0)
+ {
+ if (fdebug)
+ warn ("*pipe_read(%d) from pipe returned %d [%*s]\n",
+ idx, r, r, SvPVX(sv) + len) ;
+ SvCUR_set(sv, r + len) ;
+ return SvCUR(sv);
+ }
+
+ if (fdebug)
+ warn ("*pipe_read(%d) returned %d, errno = %d %s\n",
+ idx, r, errno, Strerror(errno)) ;
+
+ /* close the read pipe on error/eof */
+ if (fdebug)
+ warn("*pipe_read(%d) -- EOF <#########\n", idx) ;
+ close (pipe_in) ;
+ return 0;
+}
+
+#else /* !WIN32 */
+
+
+static int
+pipe_read(SV *sv, int idx, int maxlen)
+{
+ dMY_CXT;
+ int pipe_in = PIPE_IN(sv) ;
+ int pipe_out = PIPE_OUT(sv) ;
+ int pipe_pid = PIPE_PID(sv) ;
+
+ int r ;
+ int w ;
+ int len ;
+
+ if (fdebug)
+ warn ("*pipe_read(sv=%d, SvCUR(sv)=%d, idx=%d, maxlen=%d\n",
+ sv, SvCUR(sv), idx, maxlen) ;
+
+ if (!maxlen)
+ maxlen = 1024 ;
+
+ /* just make sure the SV is big enough */
+ SvGROW(sv, SvCUR(sv) + maxlen) ;
+
+ for(;;)
+ {
+ if ( !BUF_NEXT(sv) )
+ BUF_NEXT(sv) = BUF_START(sv);
+ else
+ {
+ /* try to get data from filter, if any */
+ errno = 0;
+ len = SvCUR(sv) ;
+ if ((r = read(pipe_in, SvPVX(sv) + len, maxlen)) > 0)
+ {
+ if (fdebug)
+ warn ("*pipe_read(%d) from pipe returned %d [%*s]\n",
+ idx, r, r, SvPVX(sv) + len) ;
+ SvCUR_set(sv, r + len) ;
+ return SvCUR(sv);
+ }
+
+ if (fdebug)
+ warn ("*pipe_read(%d) returned %d, errno = %d %s\n",
+ idx, r, errno, Strerror(errno)) ;
+
+ if (errno != VAL_EAGAIN)
+ {
+ /* close the read pipe on error/eof */
+ if (fdebug)
+ warn("*pipe_read(%d) -- EOF <#########\n", idx) ;
+ close (pipe_in) ;
+#ifdef HAVE_WAITPID
+ waitpid(pipe_pid, NULL, 0) ;
+#else
+ wait(NULL);
+#endif
+ return 0;
+ }
+ }
+
+ /* get some raw data to stuff down the pipe */
+ /* But only when BUF_SV is empty */
+ if (BUF_NEXT(sv) >= BUF_END(sv))
+ {
+ /* empty BUF_SV */
+ SvCUR_set((SV*)BUF_SV(sv), 0) ;
+ if ((len = FILTER_READ(idx+1, (SV*) BUF_SV(sv), 0)) > 0) {
+ BUF_NEXT(sv) = BUF_START(sv);
+ if (fdebug)
+ warn ("*pipe_write(%d) Filt Rd returned %d %d [%*s]\n",
+ idx, len, BUF_SIZE(sv), BUF_SIZE(sv), BUF_START(sv)) ;
+ }
+ else {
+ /* eof, close write end of pipe */
+ close(pipe_out) ;
+ if (fdebug)
+ warn ("*pipe_read(%d) closing pipe_out errno = %d %s\n",
+ idx, errno,
+ Strerror(errno)) ;
+ }
+ }
+
+ /* write down the pipe */
+ if ((w = BUF_END(sv) - BUF_NEXT(sv)) > 0)
+ {
+ errno = 0;
+ if ((w = write(pipe_out, BUF_NEXT(sv), w)) > 0) {
+ BUF_NEXT(sv) += w;
+ if (fdebug)
+ warn ("*pipe_read(%d) wrote %d bytes to pipe\n", idx, w) ;
+ }
+ else if (errno != VAL_EAGAIN) {
+ if (fdebug)
+ warn ("*pipe_read(%d) closing pipe_out errno = %d %s\n",
+ idx, errno, Strerror(errno)) ;
+ /* close(pipe_out) ; */
+ return 0;
+ }
+ else { /* pipe is full, sleep for a while, then continue */
+ if (fdebug)
+ warn ("*pipe_read(%d) - sleeping\n", idx ) ;
+ sleep(0);
+ }
+ }
+ }
+}
+
+
+static void
+make_nonblock(int f)
+{
+ int RETVAL ;
+ int mode = fcntl(f, F_GETFL);
+
+ if (mode < 0)
+ croak("fcntl(f, F_GETFL) failed, RETVAL = %d, errno = %d",
+ mode, errno) ;
+
+ if (!(mode & VAL_O_NONBLOCK))
+ RETVAL = fcntl(f, F_SETFL, mode | VAL_O_NONBLOCK);
+
+ if (RETVAL < 0)
+ croak("cannot create a non-blocking pipe, RETVAL = %d, errno = %d",
+ RETVAL, errno) ;
+}
+
+#endif
+
+
+#define READER 0
+#define WRITER 1
+
+static Pid_t
+spawnCommand(PerlIO *fil, char *command, char *parameters[], int *p0, int *p1)
+{
+ dMY_CXT;
+#ifdef WIN32
+
+#if defined(PERL_OBJECT)
+# define win32_pipe(p,n,f) _pipe(p,n,f)
+#endif
+
+ int p[2], c[2];
+ SV * sv ;
+ int oldstdout, oldstdin;
+
+ /* create the pipes */
+ if (win32_pipe(p,512,O_TEXT|O_NOINHERIT) == -1
+ || win32_pipe(c,512,O_BINARY|O_NOINHERIT) == -1) {
+ PerlIO_close( fil );
+ croak("Can't get pipe for %s", command);
+ }
+
+ /* duplicate stdout and stdin */
+ oldstdout = dup(fileno(stdout));
+ if (oldstdout == -1) {
+ PerlIO_close( fil );
+ croak("Can't dup stdout for %s", command);
+ }
+ oldstdin = dup(fileno(stdin));
+ if (oldstdin == -1) {
+ PerlIO_close( fil );
+ croak("Can't dup stdin for %s", command);
+ }
+
+ /* duplicate inheritable ends as std handles for the child */
+ if (dup2(p[WRITER], fileno(stdout))) {
+ PerlIO_close( fil );
+ croak("Can't attach pipe to stdout for %s", command);
+ }
+ if (dup2(c[READER], fileno(stdin))) {
+ PerlIO_close( fil );
+ croak("Can't attach pipe to stdin for %s", command);
+ }
+
+ /* close original inheritable ends in parent */
+ close(p[WRITER]);
+ close(c[READER]);
+
+ /* spawn child process (which inherits the redirected std handles) */
+ pipe_pid = spawnvp(P_NOWAIT, command, parameters);
+ if (pipe_pid == -1) {
+ PerlIO_close( fil );
+ croak("Can't spawn %s", command);
+ }
+
+ /* restore std handles */
+ if (dup2(oldstdout, fileno(stdout))) {
+ PerlIO_close( fil );
+ croak("Can't restore stdout for %s", command);
+ }
+ if (dup2(oldstdin, fileno(stdin))) {
+ PerlIO_close( fil );
+ croak("Can't restore stdin for %s", command);
+ }
+
+ /* close saved handles */
+ close(oldstdout);
+ close(oldstdin);
+
+ *p0 = p[READER] ;
+ *p1 = c[WRITER] ;
+
+#else /* !WIN32 */
+
+ int p[2], c[2];
+ SV * sv ;
+ int pipepid;
+
+ /* Check that the file is seekable */
+ /* if (lseek(fileno(fil), ftell(fil), 0) == -1) { */
+ /* croak("lseek failed: %s", Strerror(errno)) ; */
+ /* } */
+
+ if (pipe(p) < 0 || pipe(c)) {
+ PerlIO_close( fil );
+ croak("Can't get pipe for %s", command);
+ }
+
+ /* make sure that the child doesn't get anything extra */
+ fflush(stdout);
+ fflush(stderr);
+
+ while ((pipepid = fork()) < 0) {
+ if (errno != EAGAIN) {
+ close(p[0]);
+ close(p[1]);
+ close(c[0]) ;
+ close(c[1]) ;
+ PerlIO_close( fil );
+ croak("Can't fork for %s", command);
+ }
+ sleep(1);
+ }
+
+ if (pipepid == 0) {
+ /* The Child */
+
+ close(p[READER]) ;
+ close(c[WRITER]) ;
+ if (c[READER] != 0) {
+ dup2(c[READER], 0);
+ close(c[READER]);
+ }
+ if (p[WRITER] != 1) {
+ dup2(p[WRITER], 1);
+ close(p[WRITER]);
+ }
+
+ /* Run command */
+ execvp(command, parameters) ;
+ croak("execvp failed for command '%s': %s", command, Strerror(errno)) ;
+ fflush(stdout);
+ fflush(stderr);
+ _exit(0);
+ }
+
+ /* The parent */
+
+ close(p[WRITER]) ;
+ close(c[READER]) ;
+
+ /* make the pipe non-blocking */
+ make_nonblock(p[READER]) ;
+ make_nonblock(c[WRITER]) ;
+
+ *p0 = p[READER] ;
+ *p1 = c[WRITER] ;
+
+ return pipepid;
+#endif
+}
+
+
+static I32
+filter_exec(pTHX_ int idx, SV *buf_sv, int maxlen)
+{
+ dMY_CXT;
+ I32 len;
+ SV *buffer = FILTER_DATA(idx);
+ char * out_ptr = SvPVX(buffer) ;
+ int n ;
+ char * p ;
+ char * nl = "\n" ;
+
+ if (fdebug)
+ warn ("filter_sh(idx=%d, SvCUR(buf_sv)=%d, maxlen=%d\n",
+ idx, SvCUR(buf_sv), maxlen) ;
+ while (1) {
+ STRLEN n_a;
+
+ /* If there was a partial line/block left from last time
+ copy it now
+ */
+ if (n = SvCUR(buffer)) {
+ out_ptr = SvPVX(buffer) + BUF_OFFSET(buffer) ;
+ if (maxlen) {
+ /* want a block */
+ if (fdebug)
+ warn("filter_sh(%d) - wants a block\n", idx) ;
+ sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
+ if(n <= maxlen) {
+ BUF_OFFSET(buffer) = 0 ;
+ SET_LEN(buffer, 0) ;
+ }
+ else {
+ BUF_OFFSET(buffer) += maxlen ;
+ SvCUR_set(buffer, n - maxlen) ;
+ }
+ return SvCUR(buf_sv);
+ }
+ else {
+ /* want a line */
+ if (fdebug)
+ warn("filter_sh(%d) - wants a line\n", idx) ;
+ if (p = ninstr(out_ptr, out_ptr + n, nl, nl + 1)) {
+ sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
+ n = n - (p - out_ptr + 1);
+ BUF_OFFSET(buffer) += (p - out_ptr + 1);
+ SvCUR_set(buffer, n) ;
+ if (fdebug)
+ warn("recycle(%d) - leaving %d [%s], returning %d %d [%s]",
+ idx, n,
+ SvPVX(buffer), p - out_ptr + 1,
+ SvCUR(buf_sv), SvPVX(buf_sv)) ;
+
+ return SvCUR(buf_sv);
+ }
+ else /* partial buffer didn't have any newlines, so copy it all */
+ sv_catpvn(buf_sv, out_ptr, n) ;
+ }
+
+ }
+
+
+ /* the buffer has been consumed, so reset the length */
+ SET_LEN(buffer, 0) ;
+ BUF_OFFSET(buffer) = 0 ;
+
+ /* read from the sub-process */
+ if ( (n=pipe_read(buffer, idx, maxlen)) <= 0) {
+
+ if (fdebug)
+ warn ("filter_sh(%d) - pipe_read returned %d , returning %d\n",
+ idx, n, (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
+
+ SvCUR_set(buffer, 0);
+ BUF_NEXT(buffer) = Nullch; /* or perl will try to free() it */
+ /* filter_del(filter_sh); */
+
+ /* If error, return the code */
+ if (n < 0)
+ return n ;
+
+ /* return what we have so far else signal eof */
+ return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
+ }
+
+ if (fdebug)
+ warn(" filter_sh(%d): pipe_read returned %d %d: '%s'",
+ idx, n, SvCUR(buffer), SvPV(buffer,n_a));
+
+ }
+
+}
+
+
+MODULE = Filter::Util::Exec PACKAGE = Filter::Util::Exec
+
+REQUIRE: 1.924
+PROTOTYPES: ENABLE
+
+BOOT:
+ {
+ MY_CXT_INIT;
+ fdebug = 0;
+ /* temporary hack to control debugging in toke.c */
+ filter_add(NULL, (fdebug) ? (SV*)"1" : (SV*)"0");
+ }
+
+
+void
+filter_add(module, command, ...)
+ SV * module = NO_INIT
+ char ** command = (char**) safemalloc(items * sizeof(char*)) ;
+ PROTOTYPE: $@
+ CODE:
+ dMY_CXT;
+ int i ;
+ int pipe_in, pipe_out ;
+ STRLEN n_a ;
+ /* SV * sv = newSVpv("", 0) ; */
+ SV * sv = newSV(1) ;
+ Pid_t pid;
+
+ if (fdebug)
+ warn("Filter::exec::import\n") ;
+ for (i = 1 ; i < items ; ++i)
+ {
+ command[i-1] = SvPV(ST(i), n_a) ;
+ if (fdebug)
+ warn(" %s\n", command[i-1]) ;
+ }
+ command[i-1] = NULL ;
+ filter_add(filter_exec, sv);
+ pid = spawnCommand(CORE_FILTER_SCRIPT, command[0], command, &pipe_in, &pipe_out) ;
+ safefree((char*)command) ;
+
+ PIPE_PID(sv) = pid ;
+ PIPE_IN(sv) = pipe_in ;
+ PIPE_OUT(sv) = pipe_out ;
+ /* BUF_SV(sv) = newSVpv("", 0) ; */
+ BUF_SV(sv) = (GV*) newSV(1) ;
+ (void)SvPOK_only(BUF_SV(sv)) ;
+ BUF_NEXT(sv) = NULL ;
+ BUF_OFFSET(sv) = 0 ;
+
+
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Filter::Util::Exec',
+ VERSION_FROM => 'Exec.pm',
+);
+
--- /dev/null
+Changes
+MANIFEST
+Makefile.PL
+README
+Call/Makefile.PL
+Call/Call.pm
+Call/Call.xs
+Call/ppport.h
+Exec/Makefile.PL
+Exec/Exec.pm
+Exec/Exec.xs
+decrypt/Makefile.PL
+decrypt/decr
+decrypt/decrypt.pm
+decrypt/decrypt.xs
+decrypt/encrypt
+examples/method/Count.pm
+examples/method/NewSubst.pm
+examples/method/UUdecode.pm
+examples/method/Decompress.pm
+examples/method/Joe2Jim.pm
+examples/method/Subst.pm
+examples/closure/Count.pm
+examples/closure/NewSubst.pm
+examples/closure/UUdecode.pm
+examples/closure/Decompress.pm
+examples/closure/Include.pm
+examples/closure/Joe2Jim.pm
+examples/closure/Subst.pm
+examples/filtdef
+examples/filtuu
+lib/Filter/cpp.pm
+lib/Filter/exec.pm
+lib/Filter/sh.pm
+mytest
+t/call.t
+t/cpp.t
+t/decrypt.t
+t/exec.t
+t/order.t
+t/pod.t
+t/sh.t
+t/tee.t
+tee/Makefile.PL
+tee/tee.pm
+tee/tee.xs
+filter-util.pl
+perlfilter.pod
+META.yml Module meta-data (added by MakeMaker)
--- /dev/null
+--- #YAML:1.0
+name: Filter
+version: 1.34
+abstract: Source Filters
+license: perl
+generated_by: ExtUtils::MakeMaker version 6.36
+distribution_type: module
+requires:
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
+author:
+ - Paul Marquess <pmqs@cpan.org>
--- /dev/null
+use ExtUtils::MakeMaker;
+
+BEGIN
+{
+ die "Filters needs Perl version 5.004 or better, you have $]\n"
+ if $] < 5.004 ;
+
+ warn "Perl 5.6.0 or better is strongly recommended for Win32\n"
+ if $^O eq 'MSWin32' && $] < 5.006 ;
+}
+
+use strict;
+
+my @files = qw( filter-util.pl
+ Call/Call.pm
+ Exec/Exec.pm
+ decrypt/decrypt.pm decrypt/decr decrypt/encrypt
+ tee/tee.pm
+ lib/Filter/cpp.pm lib/Filter/exec.pm lib/Filter/sh.pm
+ examples/filtdef
+ examples/method/Count.pm
+ examples/method/NewSubst.pm
+ examples/method/UUdecode.pm
+ examples/method/Decompress.pm
+ examples/method/Joe2Jim.pm
+ examples/method/Subst.pm
+ examples/closure/Count.pm
+ examples/closure/NewSubst.pm
+ examples/closure/UUdecode.pm
+ examples/closure/Decompress.pm
+ examples/closure/Include.pm
+ examples/closure/Joe2Jim.pm
+ examples/closure/Subst.pm
+ examples/filtdef
+ examples/filtuu
+ t/call.t
+ t/cpp.t
+ t/decrypt.t
+ t/exec.t
+ t/order.t
+ t/sh.t
+ t/tee.t
+ );
+
+if ($] < 5.006001)
+ { oldWarnings(@files) }
+else
+ { newWarnings(@files) }
+
+
+{
+ package MY;
+
+ # Fun hack by cjwatson to get perlfilter.pod manified in section 1 with
+ # all the other perl*.pod pages.
+ sub constants {
+ my ($self) = @_;
+ $self->{MAN1PODS}->{'perlfilter.pod'} =
+ $self->catfile("\$(INST_MAN1DIR)", "perlfilter.\$(MAN1EXT)");
+ delete $self->{MAN3PODS}->{'perlfilter.pod'};
+ $self->SUPER::constants();
+ }
+}
+
+
+WriteMakefile(
+ NAME => 'Filter',
+ VERSION => '1.34',
+ 'linkext' => {LINKTYPE => ''},
+ 'dist' => {COMPRESS=>'gzip', SUFFIX=>'gz',
+ DIST_DEFAULT => 'MyDoubleCheck tardist'},
+ ($] >= 5.005
+ ? (ABSTRACT => 'Source Filters',
+ AUTHOR => 'Paul Marquess <pmqs@cpan.org>')
+ : ()
+ ),
+ ((ExtUtils::MakeMaker->VERSION() gt '6.30') ?
+ ('LICENSE' => 'perl') : ()),
+ ) ;
+
+sub MY::libscan
+{
+ my $self = shift ;
+ my $path = shift ;
+
+ return undef
+ if $path =~ /(~|\.bak)$/ ||
+ $path =~ /^\..*\.swp$/ ;
+
+ return $path;
+}
+
+sub MY::postamble
+{
+ '
+
+MyDoubleCheck:
+ @echo Checking for $$^W in files
+ @perl -ne \' \
+ exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/; \
+ \' ' . " @files || " . ' \
+ (echo found unexpected $$^W ; exit 1)
+ @echo All is ok.
+
+' ;
+}
+
+sub oldWarnings
+{
+ local ($^I) = "" ;
+ local (@ARGV) = @_ ;
+
+ while (<>)
+ {
+ if (/^__END__/)
+ {
+ print ;
+ my $this = $ARGV ;
+ while (<>)
+ {
+ last if $ARGV ne $this ;
+ print ;
+ }
+ }
+
+ s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ;
+ s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ;
+ print ;
+ }
+}
+
+sub newWarnings
+{
+ local ($^I) = "" ;
+ local (@ARGV) = @_ ;
+
+ while (<>)
+ {
+ if (/^__END__/)
+ {
+ my $this = $ARGV ;
+ print ;
+ while (<>)
+ {
+ last if $ARGV ne $this ;
+ print ;
+ }
+ }
+
+ s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ;
+ print ;
+ }
+}
--- /dev/null
+ Source Filters
+
+ Version 1.33
+
+ 1st March 2007
+
+ Copyright (c) 1995-2007 Paul Marquess. All rights reserved.
+ This program is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
+
+
+DESCRIPTION
+-----------
+
+This distribution consists of a number of Source Filters.
+
+For more details see the pod documentation embedded in the .pm files.
+
+If you intend using the Filter::Call functionality, I would strongly
+recommend that you check out Damian Conway's excellent Filter::Simple
+module. Damian's module provides a much cleaner interface than
+Filter::Util::Call. Although it doesn't allow the fine control that
+Filter::Util::Call does, it should be adequate for the majority of
+applications. It's available at
+
+ http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
+ http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
+
+PREREQUISITES
+-------------
+
+Before you can build the Source Filters you need to have the following
+installed on your system:
+
+ * Perl 5.004 or better. 5.6.0 or better is recommended for Win32.
+
+If your Perl is less than version 5.004_55, the "order" test harness
+will be skipped.
+
+
+BUILDING THE MODULES
+--------------------
+
+Assuming you have met all the prerequisites, building the modules
+should be relatively straightforward.
+
+The modules can now be built using this sequence of commands:
+
+ perl Makefile.PL
+ make
+ make test
+
+The filters have been successfully built and tested on the following
+systems (at least):
+
+ SunOS 4.1.3 (Sun C compiler & gcc 2.7.2.3)
+ Solaris 2.3 (Sun C Compiler)
+ irix 5.3
+ irix 6.x
+ Windows NT 4.0 (Visual C++ 5.0 and Borland C++ 5.02)
+
+GNU tr and GNU cpp must be installed somewhere on the path for the
+testsuite to pass successfully on Windows NT.
+
+INSTALLATION
+------------
+
+ make install
+
+UPDATES
+-------
+
+The most recent version of the Filters is always available at
+
+ http://www.cpan.org/modules/by-module/Filter
--- /dev/null
+libfilter-perl (1.34-1maemo1) fremantle; urgency=low
+
+ * New Maemo packaging
+
+ -- Nito Martinez <Nito@Qindel.ES> Wed, 14 Apr 2010 07:27:21 +0100
+
+
+llibfilter-perl (1.34-1) unstable; urgency=low
+
+ * New upstream release.
+ - Support Perl 5.10 (closes: #466751).
+ * Update copyright dates.
+
+ -- Colin Watson <cjwatson@debian.org> Thu, 21 Feb 2008 09:18:07 +0000
+
+libfilter-perl (1.31-2) unstable; urgency=low
+
+ * Add ${shlibs:Depends} and call dh_shlibdeps.
+ * Don't ignore errors from 'make realclean' other than the Makefile not
+ existing.
+ * Use debhelper v4.
+ * Add a Homepage field.
+ * Policy version 3.7.3: no changes required.
+ * debian/watch: use dist-based URL.
+
+ -- Colin Watson <cjwatson@debian.org> Thu, 17 Jan 2008 23:56:29 +0000
+
+libfilter-perl (1.31-1) unstable; urgency=low
+
+ * New upstream release (closes: #329543).
+ * Remove my Makefile.PL hack for Subversion from 1.29-2, which is no
+ longer necessary with current perl.
+ * Policy version 3.6.2: no changes required.
+
+ -- Colin Watson <cjwatson@debian.org> Thu, 22 Sep 2005 09:32:09 +0100
+
+libfilter-perl (1.30-2) unstable; urgency=low
+
+ * Upgrade debian/watch to format version 2.
+ * Improve package description, based on a suggestion by Anthony DeRobertis
+ (closes: #258801).
+ * Policy version 3.6.1: no changes required.
+
+ -- Colin Watson <cjwatson@debian.org> Sun, 11 Jul 2004 20:22:59 +0100
+
+libfilter-perl (1.30-1) unstable; urgency=low
+
+ * New upstream release.
+
+ -- Colin Watson <cjwatson@debian.org> Tue, 19 Aug 2003 00:47:33 +0100
+
+libfilter-perl (1.29-2) unstable; urgency=low
+
+ * debian/copyright: Copy Perl's licensing terms rather than referring to
+ them.
+ * debian/watch: Improve pattern to avoid downloading Filter::Trigraphs by
+ mistake.
+ * debian/control: Change section from interpreters to perl.
+ * debian/rules: Move debhelper compatibility level to debian/compat.
+ Requires debhelper 3.4.4.
+ * Makefile.PL: Add workaround from #190065 to cope with keeping the
+ package in Subversion.
+
+ -- Colin Watson <cjwatson@debian.org> Sat, 24 May 2003 12:06:16 +0100
+
+libfilter-perl (1.29-1) unstable; urgency=low
+
+ * New upstream release (closes: #193820).
+ * Policy version 3.5.10: drop DEB_BUILD_OPTIONS=debug and support noopt.
+ * Clean up "Upstream Author(s)" in debian/copyright (lintian).
+
+ -- Colin Watson <cjwatson@debian.org> Wed, 21 May 2003 00:22:55 +0100
+
+libfilter-perl (1.28-3) unstable; urgency=low
+
+ * Add a pointer to /usr/share/doc/perl/copyright in the copyright file
+ (closes: #157586).
+
+ -- Colin Watson <cjwatson@debian.org> Mon, 26 Aug 2002 03:19:07 +0100
+
+libfilter-perl (1.28-2) unstable; urgency=low
+
+ * Rebuild for perl 5.8. Bumped perl build-dependency to 5.8.0-3.
+
+ -- Colin Watson <cjwatson@debian.org> Wed, 31 Jul 2002 13:41:45 +0000
+
+libfilter-perl (1.28-1) unstable; urgency=low
+
+ * New upstream release.
+
+ -- Colin Watson <cjwatson@debian.org> Sat, 26 Jan 2002 15:22:33 +0000
+
+libfilter-perl (1.25-1) unstable; urgency=low
+
+ * New upstream release.
+ * Policy version 3.5.6, Perl policy version 1.20 (versioned
+ build-dependency on perl).
+ * Actually build-depend on perl 5.6.1 so that new warnings are used.
+ * Add evil hack to Makefile.PL to install perlfilter.pod in section 1p.
+
+ -- Colin Watson <cjwatson@debian.org> Thu, 4 Oct 2001 01:06:04 +0100
+
+libfilter-perl (1.23-1) unstable; urgency=low
+
+ * New upstream release.
+ * Build-depend on debhelper (>= 3.0.18), in accordance with version 1.19
+ of the Perl policy.
+
+ -- Colin Watson <cjwatson@debian.org> Sat, 19 May 2001 15:31:52 +0100
+
+libfilter-perl (1.22-1) unstable; urgency=low
+
+ * New upstream release.
+ * Updated policy version to 3.5.2.
+ * Install our perlfilter documentation; vendor packages now put podfiles
+ in a different place to core packages, and while perl-doc installs
+ perlfilter(1) we happen to install perlfilter(3pm). I've filed a bug
+ against perl-doc asking for the perlfilter documentation to be removed
+ from there, as otherwise man will show perlfilter(1) in preference.
+
+ -- Colin Watson <cjwatson@debian.org> Sun, 4 Mar 2001 17:59:08 +0000
+
+libfilter-perl (1.20-2) unstable; urgency=low
+
+ * Update to new Perl policy.
+ * Suggest libcompress-zlib-perl for the benefit of the filtdef example.
+
+ -- Colin Watson <cjwatson@debian.org> Thu, 15 Feb 2001 12:01:29 +0000
+
+libfilter-perl (1.20-1) unstable; urgency=low
+
+ * Uploaded to Debian (closes: #85155, #85343).
+ * New maintainer address.
+ * New upstream release.
+ * Updated policy version to 3.5.0.
+ * Fixed debian/watch.
+
+ -- Colin Watson <cjwatson@debian.org> Fri, 9 Feb 2001 21:26:49 +0000
+
+libfilter-perl (1.19-1) unstable; urgency=low
+
+ * Initial Release.
+
+ -- Colin Watson <cjw44@flatline.org.uk> Wed, 27 Dec 2000 21:42:32 +0000
--- /dev/null
+Source: libfilter-perl
+Section: perl
+Priority: optional
+Maintainer: Colin Watson <cjwatson@debian.org>
+Build-Depends: debhelper (>= 4.0.0), perl (>= 5.8.0-3)
+Standards-Version: 3.7.3
+Homepage: http://www.cpan.org/modules/by-module/Filter/
+
+Package: libfilter-perl
+Architecture: any
+Depends: ${shlibs:Depends}, ${perl:Depends}
+Suggests: libcompress-zlib-perl
+Description: Perl source filters
+ Source filters alter the program text of a module before Perl sees it, much
+ as a C preprocessor alters the source text of a C program before the
+ compiler sees it.
+ .
+ This package contains a number of source filters, including:
+ .
+ exec and sh: pipe the source file through an external command
+ cpp: pipe the source file through the C preprocessor
+ decrypt: example of simple (though weak!) source obfuscation
+ tee: copy filtered source to a file (debugging aid)
+ .
+ A substantial amount of documentation and examples is also included.
--- /dev/null
+This package was debianized by Colin Watson <cjwatson@debian.org> on
+Wed, 27 Dec 2000 21:19:47 +0000.
+
+It was downloaded from http://www.cpan.org/modules/by-module/Filter/
+
+Upstream Author: Paul Marquess <Paul.Marquess@btinternet.com>
+
+Copyright:
+
+Copyright (c) 1995-2007 Paul Marquess. All rights reserved.
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+Perl's licensing terms at the time of writing are as follows:
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of either:
+
+ a) the GNU General Public License as published by the Free Software
+ Foundation; either version 1, or (at your option) any later
+ version, or
+
+ b) the "Artistic License" which comes with Perl.
+
+ On Debian GNU/Linux systems, the complete text of the GNU General
+ Public License can be found in `/usr/share/common-licenses/GPL' and
+ the Artistic Licence in `/usr/share/common-licenses/Artistic'.
--- /dev/null
+examples/*
--- /dev/null
+#!/usr/bin/make -f
+# Sample debian/rules that uses debhelper.
+# GNU copyright 1997 to 1999 by Joey Hess.
+
+# Uncomment this to turn on verbose mode.
+#export DH_VERBOSE=1
+
+tmp = $(CURDIR)/debian/libfilter-perl
+config = INSTALLDIRS=vendor INSTALLMAN3DIR=/usr/share/man/man3
+vendorarch = `perl -MConfig -e 'print $$Config{vendorarch}'`
+
+configure: configure-stamp
+configure-stamp:
+ dh_testdir
+ # Add here commands to configure the package.
+ perl Makefile.PL $(config)
+
+ touch configure-stamp
+
+build: configure build-stamp
+build-stamp:
+ dh_testdir
+
+ # Add here commands to compile the package.
+ifeq (,$(findstring noopt,$(DEB_BUILD_OPTIONS)))
+ $(MAKE) OPTIMIZE="-O2 -g -Wall"
+else
+ $(MAKE) OPTIMIZE="-g -Wall"
+endif
+
+ touch build-stamp
+
+clean: configure
+ dh_testdir
+ dh_testroot
+
+ # Add here commands to clean up after the build process.
+ [ ! -f Makefile ] || $(MAKE) realclean
+ rm -f Try.pm # for 'make test'
+
+ dh_clean build-stamp configure-stamp
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ dh_installdirs
+
+ # Add here commands to install the package into debian/tmp.
+ $(MAKE) install PREFIX=$(tmp)/usr
+
+# Build architecture-independent files here.
+binary-indep: build install
+# We have nothing to do by default.
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+ dh_installdocs
+ dh_installexamples
+ dh_installchangelogs Changes
+ dh_strip
+ dh_compress
+ dh_fixperms
+ dh_installdeb
+ dh_perl
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
--- /dev/null
+version=3
+http://search.cpan.org/dist/Filter/ .*/Filter-v?(\d[\d_.]+)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip) debian uupdate
--- /dev/null
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'Filter::decrypt',
+ VERSION_FROM => 'decrypt.pm',
+
+ # The line below disables both the dynamic link test and the
+ # test for DEBUGGING.
+ # It is only enabled here to allow the decrypt test harness
+ # to run without having to build statically.
+ DEFINE => "-DBYPASS",
+);
--- /dev/null
+#!/usr/local/bin/perl
+
+# This script will decrypt a Perl script that has been encrypted using the
+# "encrypt" script. It cannot decrypt any other kind of encrypted Perl script.
+#
+# Usage is decr file...
+#
+
+use strict;
+use warnings;
+
+use vars qw($XOR $BLOCKSIZE $HEADERSIZE $CRYPT_MAGIC_1 $CRYPT_MAGIC_2
+ $size $mode $line $Fingerprint $file $block $sharp_bang $f
+ ) ;
+$XOR = 'Perl' ;
+$BLOCKSIZE = length $XOR ;
+$HEADERSIZE = 2 ;
+$CRYPT_MAGIC_1 = 0xff ;
+$CRYPT_MAGIC_2 = 0x00 ;
+my $Version = 1 ;
+my $module_name = 'Filter::decrypt' ;
+
+my $Fingerprint = pack ("C*", $CRYPT_MAGIC_1, $CRYPT_MAGIC_2) ;
+
+die "Usage: decrypt file...\n"
+ unless @ARGV ;
+
+
+# Loop through each file in turn.
+foreach $file (@ARGV)
+{
+ if (! -f $file)
+ {
+ print "Skipping directory $file\n" if -d $file ;
+ #print "Skipping strange file $file\n" if ! -d $file ;
+ next ;
+ }
+
+ open (F, "<$file") || die "Cannot open $file: $!\n" ;
+
+ # skip the #! line
+ $a = <F> ;
+ if ($a =~ /^#!/)
+ {
+ $sharp_bang = $a ;
+ $a = <F> ;
+ }
+
+ # skip "use decrypt;" line
+ die "No use $module_name in $file\n"
+ unless $a =~ /use\s+$module_name\s*;/ ;
+
+ read(F, $f, length($Fingerprint)) || die "Cannot read from $file: $!\n" ;
+ (print "skipping file '$file': not encrypted\n"), next
+ unless $f eq $Fingerprint ;
+
+ print "decrypting $file to $file.pd\n" ;
+ open (O, ">${file}.pd") || die "Cannot open ${file}.pd: $!\n" ;
+ print O $sharp_bang if $sharp_bang ;
+ while ($size = read(F, $block, $BLOCKSIZE) )
+ {
+ print O ($block ^ substr($XOR, 0, $size)) ;
+ }
+
+
+ close F ;
+ close O ;
+
+}
+
--- /dev/null
+package Filter::decrypt ;
+
+require 5.002 ;
+require DynaLoader;
+use strict;
+use warnings;
+use vars qw(@ISA $VERSION);
+@ISA = qw(DynaLoader);
+$VERSION = "1.05" ;
+
+bootstrap Filter::decrypt ;
+1;
+__END__
+
+=head1 NAME
+
+Filter::decrypt - template for a decrypt source filter
+
+=head1 SYNOPSIS
+
+ use Filter::decrypt ;
+
+=head1 DESCRIPTION
+
+This is a sample decrypting source filter.
+
+Although this is a fully functional source filter and it does implement
+a I<very> simple decrypt algorithm, it is I<not> intended to be used as
+it is supplied. Consider it to be a template which you can combine with
+a proper decryption algorithm to develop your own decryption filter.
+
+=head1 WARNING
+
+It is important to note that a decryption filter can I<never> provide
+complete security against attack. At some point the parser within Perl
+needs to be able to scan the original decrypted source. That means that
+at some stage fragments of the source will exist in a memory buffer.
+
+Also, with the introduction of the Perl Compiler backend modules, and
+the B::Deparse module in particular, using a Source Filter to hide source
+code is becoming an increasingly futile exercise.
+
+The best you can hope to achieve by decrypting your Perl source using a
+source filter is to make it unavailable to the casual user.
+
+Given that proviso, there are a number of things you can do to make
+life more difficult for the prospective cracker.
+
+=over 5
+
+=item 1.
+
+Strip the Perl binary to remove all symbols.
+
+=item 2.
+
+Build the decrypt extension using static linking. If the extension is
+provided as a dynamic module, there is nothing to stop someone from
+linking it at run time with a modified Perl binary.
+
+=item 3.
+
+Do not build Perl with C<-DDEBUGGING>. If you do then your source can
+be retrieved with the C<-Dp> command line option.
+
+The sample filter contains logic to detect the C<DEBUGGING> option.
+
+=item 4.
+
+Do not build Perl with C debugging support enabled.
+
+=item 5.
+
+Do not implement the decryption filter as a sub-process (like the cpp
+source filter). It is possible to peek into the pipe that connects to
+the sub-process.
+
+=item 6.
+
+Check that the Perl Compiler isn't being used.
+
+There is code in the BOOT: section of decrypt.xs that shows how to detect
+the presence of the Compiler. Make sure you include it in your module.
+
+Assuming you haven't taken any steps to spot when the compiler is in
+use and you have an encrypted Perl script called "myscript.pl", you can
+get access the source code inside it using the perl Compiler backend,
+like this
+
+ perl -MO=Deparse myscript.pl
+
+Note that even if you have included the BOOT: test, it is still
+possible to use the Deparse module to get the source code for individual
+subroutines.
+
+=item 7.
+
+Do not use the decrypt filter as-is. The algorithm used in this filter
+has been purposefully left simple.
+
+=back
+
+If you feel that the source filtering mechanism is not secure enough
+you could try using the unexec/undump method. See the Perl FAQ for
+further details.
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+19th December 1995
+
+=cut
--- /dev/null
+/*
+ * Filename : decrypt.xs
+ *
+ * Author : Paul Marquess
+ * Date : 20th July 2000
+ * Version : 1.05
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "../Call/ppport.h"
+
+#ifdef FDEBUG
+static int fdebug = 0;
+#endif
+
+/* constants specific to the encryption format */
+#define CRYPT_MAGIC_1 0xff
+#define CRYPT_MAGIC_2 0x00
+
+#define HEADERSIZE 2
+#define BLOCKSIZE 4
+
+
+#define SET_LEN(sv,len) \
+ do { SvPVX(sv)[len] = '\0'; SvCUR_set(sv, len); } while (0)
+
+
+static unsigned XOR [BLOCKSIZE] = {'P', 'e', 'r', 'l' } ;
+
+
+/* Internal defines */
+#ifdef PERL_FILTER_EXISTS
+# define CORE_FILTER_COUNT \
+ (PL_parser && PL_parser->rsfp_filters ? av_len(PL_parser->rsfp_filters) : 0)
+#else
+# define CORE_FILTER_COUNT \
+ (PL_rsfp_filters ? av_len(PL_rsfp_filters) : 0)
+#endif
+
+#define FILTER_COUNT(s) IoPAGE(s)
+#define FILTER_LINE_NO(s) IoLINES(s)
+#define FIRST_TIME(s) IoLINES_LEFT(s)
+
+#define ENCRYPT_GV(s) IoTOP_GV(s)
+#define ENCRYPT_SV(s) ((SV*) ENCRYPT_GV(s))
+#define ENCRYPT_BUFFER(s) SvPVX(ENCRYPT_SV(s))
+#define CLEAR_ENCRYPT_SV(s) SvCUR_set(ENCRYPT_SV(s), 0)
+
+#define DECRYPT_SV(s) s
+#define DECRYPT_BUFFER(s) SvPVX(DECRYPT_SV(s))
+#define CLEAR_DECRYPT_SV(s) SvCUR_set(DECRYPT_SV(s), 0)
+#define DECRYPT_BUFFER_LEN(s) SvCUR(DECRYPT_SV(s))
+#define DECRYPT_OFFSET(s) IoPAGE_LEN(s)
+#define SET_DECRYPT_BUFFER_LEN(s,n) SvCUR_set(DECRYPT_SV(s), n)
+
+static unsigned
+Decrypt(SV *in_sv, SV *out_sv)
+{
+ /* Here is where the actual decryption takes place */
+
+ unsigned char * in_buffer = (unsigned char *) SvPVX(in_sv) ;
+ unsigned char * out_buffer ;
+ unsigned size = SvCUR(in_sv) ;
+ unsigned index = size ;
+ int i ;
+
+ /* make certain that the output buffer is big enough */
+ /* as the output from the decryption can never be larger than */
+ /* the input buffer, make it that size */
+ SvGROW(out_sv, size) ;
+ out_buffer = (unsigned char *) SvPVX(out_sv) ;
+
+ /* XOR */
+ for (i = 0 ; i < size ; ++i)
+ out_buffer[i] = (unsigned char)( XOR[i] ^ in_buffer[i] ) ;
+
+ /* input has been consumed, so set length to 0 */
+ SET_LEN(in_sv, 0) ;
+
+ /* set decrypt buffer length */
+ SET_LEN(out_sv, index) ;
+
+ /* return the size of the decrypt buffer */
+ return (index) ;
+}
+
+static int
+ReadBlock(int idx, SV *sv, unsigned size)
+{ /* read *exactly* size bytes from the next filter */
+ int i = size;
+ while (1) {
+ int n = FILTER_READ(idx, sv, i) ;
+ if (n <= 0 && i==size) /* eof/error when nothing read so far */
+ return n ;
+ if (n <= 0) /* eof/error when something already read */
+ return size - i;
+ if (n == i)
+ return size ;
+ i -= n ;
+ }
+}
+
+static void
+preDecrypt(int idx)
+{
+ /* If the encrypted data starts with a header or needs to do some
+ initialisation it can be done here
+
+ In this case the encrypted data has to start with a fingerprint,
+ so that is checked.
+ */
+
+ SV * sv = FILTER_DATA(idx) ;
+ unsigned char * buffer ;
+
+
+ /* read the header */
+ if (ReadBlock(idx+1, sv, HEADERSIZE) != HEADERSIZE)
+ croak("truncated file") ;
+
+ buffer = (unsigned char *) SvPVX(sv) ;
+
+ /* check for fingerprint of encrypted data */
+ if (buffer[0] != CRYPT_MAGIC_1 || buffer[1] != CRYPT_MAGIC_2)
+ croak( "bad encryption format" );
+}
+
+static void
+postDecrypt()
+{
+}
+
+static I32
+filter_decrypt(pTHX_ int idx, SV *buf_sv, int maxlen)
+{
+ SV *my_sv = FILTER_DATA(idx);
+ char *nl = "\n";
+ char *p;
+ char *out_ptr;
+ int n;
+
+ /* check if this is the first time through */
+ if (FIRST_TIME(my_sv)) {
+
+ /* Mild paranoia mode - make sure that no extra filters have */
+ /* been applied on the same line as the use Filter::decrypt */
+ if (CORE_FILTER_COUNT > FILTER_COUNT(my_sv) )
+ croak("too many filters") ;
+
+ /* As this is the first time through, so deal with any */
+ /* initialisation required */
+ preDecrypt(idx) ;
+
+ FIRST_TIME(my_sv) = FALSE ;
+ SET_LEN(DECRYPT_SV(my_sv), 0) ;
+ SET_LEN(ENCRYPT_SV(my_sv), 0) ;
+ DECRYPT_OFFSET(my_sv) = 0 ;
+ }
+
+#ifdef FDEBUG
+ if (fdebug)
+ warn("**** In filter_decrypt - maxlen = %d, len buf = %d idx = %d\n",
+ maxlen, SvCUR(buf_sv), idx ) ;
+#endif
+
+ while (1) {
+
+ /* anything left from last time */
+ if ((n = SvCUR(DECRYPT_SV(my_sv)))) {
+
+ out_ptr = SvPVX(DECRYPT_SV(my_sv)) + DECRYPT_OFFSET(my_sv) ;
+
+ if (maxlen) {
+ /* want a block */
+#ifdef FDEBUG
+ if (fdebug)
+ warn("BLOCK(%d): size = %d, maxlen = %d\n",
+ idx, n, maxlen) ;
+#endif
+
+ sv_catpvn(buf_sv, out_ptr, maxlen > n ? n : maxlen );
+ if(n <= maxlen) {
+ DECRYPT_OFFSET(my_sv) = 0 ;
+ SET_LEN(DECRYPT_SV(my_sv), 0) ;
+ }
+ else {
+ DECRYPT_OFFSET(my_sv) += maxlen ;
+ SvCUR_set(DECRYPT_SV(my_sv), n - maxlen) ;
+ }
+ return SvCUR(buf_sv);
+ }
+ else {
+ /* want lines */
+ if ((p = ninstr(out_ptr, out_ptr + n, nl, nl + 1))) {
+
+ sv_catpvn(buf_sv, out_ptr, p - out_ptr + 1);
+
+ n = n - (p - out_ptr + 1);
+ DECRYPT_OFFSET(my_sv) += (p - out_ptr + 1) ;
+ SvCUR_set(DECRYPT_SV(my_sv), n) ;
+#ifdef FDEBUG
+ if (fdebug)
+ warn("recycle %d - leaving %d, returning %d [%.999s]",
+ idx, n, SvCUR(buf_sv), SvPVX(buf_sv)) ;
+#endif
+
+ return SvCUR(buf_sv);
+ }
+ else /* no EOL, so append the complete buffer */
+ sv_catpvn(buf_sv, out_ptr, n) ;
+ }
+
+ }
+
+
+ SET_LEN(DECRYPT_SV(my_sv), 0) ;
+ DECRYPT_OFFSET(my_sv) = 0 ;
+
+ /* read from the file into the encrypt buffer */
+ if ( (n = ReadBlock(idx+1, ENCRYPT_SV(my_sv), BLOCKSIZE)) <= 0)
+ {
+ /* Either EOF or an error */
+
+#ifdef FDEBUG
+ if (fdebug)
+ warn ("filter_read %d returned %d , returning %d\n", idx, n,
+ (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n);
+#endif
+
+ /* If the decrypt code needs to tidy up on EOF/error,
+ now is the time - here is a hook */
+ postDecrypt() ;
+
+ filter_del(filter_decrypt);
+
+
+ /* If error, return the code */
+ if (n < 0)
+ return n ;
+
+ /* return what we have so far else signal eof */
+ return (SvCUR(buf_sv)>0) ? SvCUR(buf_sv) : n;
+ }
+
+#ifdef FDEBUG
+ if (fdebug)
+ warn(" filter_decrypt(%d): sub-filter returned %d: '%.999s'",
+ idx, n, SvPV(my_sv,PL_na));
+#endif
+
+ /* Now decrypt a block */
+ n = Decrypt(ENCRYPT_SV(my_sv), DECRYPT_SV(my_sv)) ;
+
+#ifdef FDEBUG
+ if (fdebug)
+ warn("Decrypt (%d) returned %d [%.999s]\n", idx, n, SvPVX(DECRYPT_SV(my_sv)) ) ;
+#endif
+
+ }
+}
+
+
+MODULE = Filter::decrypt PACKAGE = Filter::decrypt
+
+PROTOTYPES: DISABLE
+
+BOOT:
+ /* Check for the presence of the Perl Compiler */
+ if (gv_stashpvn("B", 1, FALSE))
+ croak("Aborting, Compiler detected") ;
+#ifndef BYPASS
+ /* Don't run if this module is dynamically linked */
+ if (!isALPHA(SvPV(GvSV(CvFILEGV(cv)), PL_na)[0]))
+ croak("module is dynamically linked. Recompile as a static module") ;
+#ifdef DEBUGGING
+ /* Don't run if compiled with DEBUGGING */
+ croak("recompile without -DDEBUGGING") ;
+#endif
+
+ /* Double check that DEBUGGING hasn't been enabled */
+ if (PL_debug)
+ croak("debugging flags detected") ;
+#endif
+
+
+void
+import(module)
+ SV * module
+ PPCODE:
+ {
+
+ SV * sv = newSV(BLOCKSIZE) ;
+
+ /* make sure the Perl debugger isn't enabled */
+ if( PL_perldb )
+ croak("debugger disabled") ;
+
+ filter_add(filter_decrypt, sv) ;
+ FIRST_TIME(sv) = TRUE ;
+
+ ENCRYPT_GV(sv) = (GV*) newSV(BLOCKSIZE) ;
+ (void)SvPOK_only(DECRYPT_SV(sv));
+ (void)SvPOK_only(ENCRYPT_SV(sv));
+ SET_LEN(DECRYPT_SV(sv), 0) ;
+ SET_LEN(ENCRYPT_SV(sv), 0) ;
+
+
+ /* remember how many filters are enabled */
+ FILTER_COUNT(sv) = CORE_FILTER_COUNT ;
+ /* and the line number */
+ FILTER_LINE_NO(sv) = PL_curcop->cop_line ;
+
+ }
+
+void
+unimport(...)
+ PPCODE:
+ /* filter_del(filter_decrypt); */
--- /dev/null
+
+require 5.002 ;
+
+use strict;
+use warnings;
+
+use vars qw($XOR $BLOCKSIZE $HEADERSIZE $CRYPT_MAGIC_1 $CRYPT_MAGIC_2
+ $size $mode $line $Fingerprint $file $block
+ ) ;
+
+$XOR = 'Perl' ;
+$BLOCKSIZE = length $XOR ;
+$HEADERSIZE = 2 ;
+$CRYPT_MAGIC_1 = 0xff ;
+$CRYPT_MAGIC_2 = 0x00 ;
+
+$Fingerprint = pack ("C*", $CRYPT_MAGIC_1, $CRYPT_MAGIC_2) ;
+
+die "Usage: encrypt file...\n"
+ unless @ARGV ;
+
+# Loop throught each file in turn.
+foreach $file (@ARGV)
+{
+
+ if (! -T $file)
+ {
+ print "Skipping directory $file\n" if -d $file ;
+ print "Skipping non-text $file\n" if ! -d $file ;
+ next ;
+ }
+
+ open (F, "<$file") or die "Cannot open $file: $!\n" ;
+ open (O, ">${file}.pe") or die "Cannot open ${file}.pe: $!\n" ;
+ binmode O;
+
+ # Get the mode
+ $mode = (stat F)[2] ;
+
+ # Check for "#!perl" line
+ $line = <F> ;
+
+ if ( $line =~ /^#!/ )
+ { print O $line }
+ else
+ { seek F, 0, 0 }
+
+ print O "use Filter::decrypt ;\n" ;
+ print O $Fingerprint ;
+
+
+ $block = '';
+ while ($size = read(F, $block, $BLOCKSIZE) )
+ {
+ print O ($block ^ substr($XOR, 0, length $block)) ;
+ }
+
+ close F ;
+ close O ;
+
+ unlink ($file)
+ or die "Could not remove '$file': $!\n" ;
+
+ rename ("${file}.pe", $file)
+ or die "Could not rename $file.pe to $file: $!\n" ;
+
+ chmod $mode, $file unless $^O eq 'MSWin32' ;
+
+ print "encrypted $file\n" ;
+}
+
--- /dev/null
+package Count ;
+
+use Filter::Util::Call ;
+
+use strict ;
+use warnings ;
+
+sub import
+{
+ my ($self) = @_ ;
+ my ($count) = 0 ;
+ filter_add(
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0 ) {
+ s/Joe/Jim/g ;
+ ++ $count ;
+ }
+ elsif ($count >= 0) { # EOF
+ $_ = "print q[Made $count substitutions\n] ;" ;
+ $status = 1 ;
+ $count = -1 ;
+ }
+
+ $status ;
+ })
+}
+
+1 ;
+
--- /dev/null
+package Filter::Decompress ;
+
+use Filter::Util::Call ;
+use Compress::Zlib ;
+use Carp ;
+
+use strict ;
+use warnings ;
+
+my $VERSION = '1.01' ;
+
+sub import
+{
+ my ($self) = @_ ;
+
+ # Initialise an inflation stream.
+ my $x = inflateInit()
+ or croak "Internal Error" ;
+ filter_add(
+ sub
+ {
+ my ($status, $err) ;
+
+ if (($status = filter_read()) >0) {
+ ($_, $err) = $x->inflate($_) ;
+ return -1 unless $err == Z_OK or $err == Z_STREAM_END ;
+ }
+ $status ;
+ })
+}
+
+1 ;
+__END__
--- /dev/null
+package Include ;
+
+use Filter::Util::Call ;
+use IO::File ;
+use Carp ;
+
+sub import
+{
+ my ($self) = shift ;
+ my ($filename) = shift ;
+ my $fh = new IO::File "<$filename"
+ or croak "Cannot open file '$filename': $!" ;
+
+ my $first_time = 1 ;
+ my ($orig_filename, $orig_line) = (caller)[1,2] ;
+ ++ $orig_line ;
+
+ filter_add(
+ sub
+ {
+ $_ = <$fh> ;
+
+ if ($first_time) {
+ $_ = "#line 1 $filename\n$_" ;
+ $first_time = 0 ;
+ }
+
+ if ($fh->eof) {
+ $fh->close ;
+ $_ .= "#line $orig_line $orig_filename\n" ;
+ filter_del() ;
+ }
+ 1 ;
+ })
+}
+
+1 ;
+
--- /dev/null
+package Joe2Jim ;
+
+use Filter::Util::Call ;
+
+use strict ;
+use warnings ;
+
+sub import
+{
+ my($type) = @_ ;
+
+ filter_add(
+ sub
+ {
+ my($status) ;
+ s/Joe/Jim/g
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ })
+}
+
+1 ;
+
--- /dev/null
+package NewSubst ;
+
+use Filter::Util::Call ;
+use Carp ;
+
+use strict ;
+use warnings ;
+
+sub import
+{
+ my ($self, $start, $stop, $from, $to) = @_ ;
+ my ($found) = 0 ;
+ croak("usage: use Subst qw(start stop from to)")
+ unless @_ == 5 ;
+
+ filter_add(
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+
+ $found = 1
+ if $found == 0 and /$start/ ;
+
+ if ($found) {
+ s/$from/$to/ ;
+ filter_del() if /$stop/ ;
+ }
+
+ }
+ $status ;
+ } )
+
+}
+
+1 ;
--- /dev/null
+package Subst ;
+
+use Filter::Util::Call ;
+use Carp ;
+
+use strict ;
+use warnings ;
+
+sub import
+{
+ croak("usage: use Subst qw(from to)")
+ unless @_ == 3 ;
+ my ($self, $from, $to) = @_ ;
+ filter_add(
+ sub
+ {
+ my ($status) ;
+ s/$from/$to/
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ })
+}
+
+1 ;
--- /dev/null
+
+package Filter::UUdecode ;
+
+use Filter::Util::Call ;
+
+use strict ;
+use warnings ;
+
+my $VERSION = '1.00' ;
+
+sub import
+{
+ my($self) = @_ ;
+ my ($count) = 0 ;
+
+ filter_add(
+ sub
+ {
+ my ($status) ;
+
+ while (1) {
+
+ return $status
+ if ($status = filter_read() ) <= 0;
+
+ chomp ;
+ ++ $count ;
+
+ # Skip the begin line (if it is there)
+ ($_ = ''), next if $count == 1 and /^begin/ ;
+
+ # is this the last line?
+ if ($_ eq " " or length $_ <= 1) {
+ $_ = '' ;
+ # If there is an end line, skip it too
+ return $status
+ if ($status = filter_read() ) <= 0 ;
+ $_ = "\n" if /^end/ ;
+ filter_del() ;
+ return 1 ;
+ }
+
+ # uudecode the line
+ $_ = unpack("u", $_) ;
+
+ # return the uudecoded data
+ return $status ;
+ }
+ })
+
+}
+1 ;
--- /dev/null
+#!/usr/bin/perl
+
+use strict ;
+use warnings ;
+
+my ($file, $output, $status) ;
+
+use Compress::Zlib ;
+
+die "Usage: mkdef file\n"
+ unless @ARGV == 1;
+
+foreach $file (@ARGV)
+{
+ open (F, "<$file") or die "Cannot open $file: $!\n" ;
+ my $x = deflateInit()
+ or die "Cannot create a deflation stream\n" ;
+
+ print "use Filter::Decompress;\n" ;
+ while (<F>)
+ {
+ ($output, $status) = $x->deflate($_) ;
+
+ $status == Z_OK
+ or die "deflation failed\n" ;
+
+ print $output ;
+ }
+
+ ($output, $status) = $x->flush() ;
+
+ $status == Z_OK
+ or die "deflation failed\n" ;
+
+ print $output ;
+ close F ;
+}
--- /dev/null
+#!/usr/bin/perl
+
+print "use Filter::UUdecode ;\n" ;
+while (<>) {
+ print pack("u", $_) ;
+}
--- /dev/null
+package Count ;
+
+use Filter::Util::Call ;
+
+use strict ;
+use warnings ;
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0 ) {
+ s/Joe/Jim/g ;
+ ++ $$self ;
+ }
+ elsif ($$self >= 0) { # EOF
+ $_ = "print q[Made ${$self} substitutions\n] ;" ;
+ $status = 1 ;
+ $$self = -1 ;
+ }
+
+ $status ;
+}
+
+sub import
+{
+ my ($self) = @_ ;
+ my ($count) = 0 ;
+ filter_add(\$count) ;
+}
+
+1 ;
+
--- /dev/null
+package Filter::Decompress ;
+
+use Filter::Util::Call ;
+use Compress::Zlib ;
+use Carp ;
+
+use strict ;
+use warnings ;
+
+my $VERSION = '1.01' ;
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($inf) = $$self ;
+
+ if (($status = filter_read()) >0) {
+ ($_, $err) = $inf->inflate($_) ;
+ return -1 unless $err == Z_OK or $err == Z_STREAM_END ;
+ }
+ $status ;
+}
+
+sub import
+{
+ my ($self) = @_ ;
+
+ # Initialise an inflation stream.
+ my $x = inflateInit()
+ or croak "Internal Error" ;
+ filter_add(\$x) ;
+}
+
+1 ;
+__END__
--- /dev/null
+package Joe2Jim ;
+
+use Filter::Util::Call ;
+
+use strict ;
+use warnings ;
+
+sub import
+{
+ my($type) = @_ ;
+
+ filter_add(bless []) ;
+}
+
+sub filter
+{
+ my($self) = @_ ;
+ my($status) ;
+
+ s/Joe/Jim/g
+ if ($status = filter_read()) > 0 ;
+ $status ;
+}
+
+1 ;
+
--- /dev/null
+package NewSubst ;
+
+use Filter::Util::Call ;
+use Carp ;
+
+use strict ;
+use warnings ;
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+
+ $self->{Found} = 1
+ if $self->{Found} == 0 and /$self->{Start}/ ;
+
+ if ($self->{Found}) {
+ s/$self->{From}/$self->{To}/ ;
+ filter_del() if /$self->{Stop}/ ;
+ }
+
+ }
+ $status ;
+}
+
+sub import
+{
+ my ($self, @args) = @_ ;
+ croak("usage: use Subst qw(start stop from to)")
+ unless @args == 4 ;
+
+ filter_add( { Start => $args[0],
+ Stop => $args[1],
+ From => $args[2],
+ To => $args[3],
+ Found => 0 }
+ ) ;
+}
+
+1 ;
+
--- /dev/null
+package Subst ;
+
+use Filter::Util::Call ;
+use Carp ;
+
+use strict ;
+use warnings ;
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($from) = $self->[0] ;
+ my ($to) = $self->[1] ;
+
+ s/$from/$to/
+ if ($status = filter_read()) > 0 ;
+ $status ;
+}
+
+sub import
+{
+ my ($self, @args) = @_ ;
+ croak("usage: use Subst qw(from to)")
+ unless @args == 2 ;
+ filter_add([ @args ]) ;
+}
+
+1 ;
+
--- /dev/null
+
+package Filter::UUdecode ;
+
+use Filter::Util::Call ;
+
+use strict ;
+use warnings ;
+
+my $VERSION = '1.00' ;
+
+sub import
+{
+ my($self) = @_ ;
+ my ($count) = 0 ;
+
+ filter_add( \$count ) ;
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ while (1) {
+
+ return $status
+ if ($status = filter_read() ) <= 0;
+
+ chomp ;
+ ++ $$self ;
+
+ # Skip the begin line (if it is there)
+ ($_ = ''), next if $$self == 1 and /^begin/ ;
+
+ # is this the last line?
+ if ($_ eq " " or length $_ <= 1) {
+ $_ = '' ;
+ # If there is an end line, skip it too
+ return $status
+ if ($status = filter_read() ) <= 0 ;
+ $_ = "\n" if /^end/ ;
+ filter_del() ;
+ return 1 ;
+ }
+
+ # uudecode the line
+ $_ = unpack("u", $_) ;
+
+ # return the uudecoded data
+ return $status ;
+ }
+}
+
+1 ;
--- /dev/null
+
+use strict ;
+use warnings;
+
+use vars qw( $Perl $Inc);
+
+sub readFile
+{
+ my ($filename) = @_ ;
+ my ($string) = '' ;
+
+ open (F, "<$filename")
+ or die "Cannot open $filename: $!\n" ;
+ while (<F>)
+ { $string .= $_ }
+ close F ;
+ $string ;
+}
+
+sub writeFile
+{
+ my($filename, @strings) = @_ ;
+ open (F, ">$filename")
+ or die "Cannot open $filename: $!\n" ;
+ binmode(F) if $filename =~ /bin$/i;
+ foreach (@strings)
+ { print F }
+ close F or die "Could not close: $!" ;
+}
+
+sub ok
+{
+ my($number, $result, $note) = @_ ;
+
+ $note = "" if ! defined $note ;
+ if ($note) {
+ $note = "# $note" if $note !~ /^\s*#/ ;
+ $note =~ s/^\s*/ / ;
+ }
+
+ print "not " if !$result ;
+ print "ok ${number}${note}\n";
+}
+
+$Inc = '' ;
+foreach (@INC)
+ { $Inc .= "\"-I$_\" " }
+
+$Perl = '' ;
+$Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ;
+
+$Perl = "$Perl -MMac::err=unix" if $^O eq 'MacOS';
+$Perl = "$Perl -w" ;
+
+1;
--- /dev/null
+package Filter::cpp;
+
+use Config ;
+use Carp ;
+use Filter::Util::Exec ;
+use strict;
+use warnings;
+use vars qw($VERSION);
+
+$VERSION = '1.03' ;
+
+my $cpp;
+my $sep;
+if ($^O eq 'MSWin32') {
+ $cpp = 'cpp.exe' ;
+ $sep = ';';
+}
+else {
+ ($cpp) = $Config{cppstdin} =~ /^(\S+)/;
+ $sep = ':';
+}
+
+croak ("Cannot find cpp\n")
+ if ! $cpp;
+
+# Check if cpp is installed
+if ( ! -x $cpp) {
+ my $foundCPP = 0 ;
+ foreach my $dir (split($sep, $ENV{PATH}), '')
+ {
+ if (-x "$dir/$cpp")
+ {
+ $foundCPP = 1;
+ last ;
+ }
+ }
+
+ croak "Cannot find cpp\n"
+ if ! $foundCPP ;
+}
+
+sub import
+{
+ my($self, @args) = @_ ;
+
+ #require "Filter/exec.pm" ;
+
+ if ($^O eq 'MSWin32') {
+ Filter::Util::Exec::filter_add ($self, 'cmd', '/c',
+ "cpp.exe 2>nul") ;
+ }
+ else {
+ Filter::Util::Exec::filter_add ($self, 'sh', '-c',
+ "$Config{'cppstdin'} $Config{'cppminus'} 2>/dev/null") ;
+ }
+}
+
+1 ;
+__END__
+
+=head1 NAME
+
+Filter::cpp - cpp source filter
+
+=head1 SYNOPSIS
+
+ use Filter::cpp ;
+
+=head1 DESCRIPTION
+
+This source filter pipes the current source file through the C
+pre-processor (cpp) if it is available.
+
+As with all source filters its scope is limited to the current source
+file only. Every file you want to be processed by the filter must have a
+
+ use Filter::cpp ;
+
+near the top.
+
+Here is an example script which uses the filter:
+
+ use Filter::cpp ;
+
+ #define FRED 1
+ $a = 2 + FRED ;
+ print "a = $a\n" ;
+ #ifdef FRED
+ print "Hello FRED\n" ;
+ #else
+ print "Where is FRED\n" ;
+ #endif
+
+And here is what it will output:
+
+ a = 3
+ Hello FRED
+
+This example below, provided by Michael G Schwern, shows a clever way
+to get Perl to use a C pre-processor macro when the Filter::cpp module
+is available, or to use a Perl sub when it is not.
+
+ # use Filter::cpp if we can.
+ BEGIN { eval 'use Filter::cpp' }
+
+ sub PRINT {
+ my($string) = shift;
+
+ #define PRINT($string) \
+ (print $string."\n")
+ }
+
+ PRINT("Mu");
+
+Look at Michael's Tie::VecArray module for a practical use.
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+11th December 1995.
+
+=cut
+
--- /dev/null
+package Filter::exec ;
+
+use Carp ;
+use Filter::Util::Exec ;
+use strict ;
+use warnings ;
+use vars qw($VERSION) ;
+
+$VERSION = "1.01" ;
+
+sub import
+{
+ my($self, @args) = @_ ;
+
+ croak("Usage: use Filter::exec 'command'")
+ unless @args ;
+
+ Filter::Util::Exec::filter_add($self, @args) ;
+}
+
+1 ;
+__END__
+
+=head1 NAME
+
+Filter::exec - exec source filter
+
+=head1 SYNOPSIS
+
+ use Filter::exec qw(command parameters) ;
+
+=head1 DESCRIPTION
+
+This filter pipes the current source file through the program which
+corresponds to the C<command> parameter.
+
+As with all source filters its scope is limited to the current source
+file only. Every file you want to be processed by the filter must have a
+
+ use Filter::exec qw(command ) ;
+
+near the top.
+
+Here is an example script which uses the filter:
+
+ use Filter::exec qw(tr XYZ PQR) ;
+ $a = 1 ;
+ print "XYZ a = $a\n" ;
+
+And here is what it will output:
+
+ PQR = 1
+
+=head1 WARNING
+
+You should be I<very> careful when using this filter. Because of the
+way the filter is implemented it is possible to end up with deadlock.
+
+Be especially careful when stacking multiple instances of the filter in
+a single source file.
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+11th December 1995.
+
+=cut
+
--- /dev/null
+package Filter::sh;
+
+use Carp ;
+use strict ;
+use warnings ;
+use vars qw($VERSION) ;
+$VERSION = "1.01" ;
+
+use Filter::Util::Exec ;
+
+sub import
+{
+ my($self, @args) = @_ ;
+
+ croak ("Usage: use Filter::sh 'command'")
+ unless @args ;
+
+ #require "Filter/exec.pm" ;
+ #Filter::exec::import ($self, 'sh', '-c', "@args") ;
+ if ($^O eq 'MSWin32') {
+ Filter::Util::Exec::filter_add ($self, 'cmd', '/c', "@args") ;
+ }
+ else {
+ Filter::Util::Exec::filter_add ($self, 'sh', '-c', "@args") ;
+ }
+}
+
+1 ;
+__END__
+
+=head1 NAME
+
+Filter::sh - sh source filter
+
+=head1 SYNOPSIS
+
+ use Filter::sh 'command' ;
+
+=head1 DESCRIPTION
+
+This filter pipes the current source file through the program which
+corresponds to the C<command> parameter using the Bourne shell.
+
+As with all source filters its scope is limited to the current source
+file only. Every file you want to be processed by the filter must have a
+
+ use Filter::sh 'command' ;
+
+near the top.
+
+Here is an example script which uses the filter:
+
+ use Filter::sh 'tr XYZ PQR' ;
+ $a = 1 ;
+ print "XYZ a = $a\n" ;
+
+And here is what it will output:
+
+ PQR = 1
+
+=head1 WARNING
+
+You should be I<very> careful when using this filter. Because of the
+way the filter is implemented it is possible to end up with deadlock.
+
+Be especially careful when stacking multiple instances of the filter in
+a single source file.
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+11th December 1995.
+
+=cut
+
--- /dev/null
+# You can use this file to play with the filters.
+#
+# If you type
+#
+# make mytest
+#
+# this file will get executed with the same 'environment' as the
+# scripts in the t subdirectory.
+
+print "hello\n" ;
--- /dev/null
+=head1 NAME
+
+perlfilter - Source Filters
+
+
+=head1 DESCRIPTION
+
+This article is about a little-known feature of Perl called
+I<source filters>. Source filters alter the program text of a module
+before Perl sees it, much as a C preprocessor alters the source text of
+a C program before the compiler sees it. This article tells you more
+about what source filters are, how they work, and how to write your
+own.
+
+The original purpose of source filters was to let you encrypt your
+program source to prevent casual piracy. This isn't all they can do, as
+you'll soon learn. But first, the basics.
+
+=head1 CONCEPTS
+
+Before the Perl interpreter can execute a Perl script, it must first
+read it from a file into memory for parsing and compilation. (Even
+scripts specified on the command line with the C<-e> option are stored in
+a temporary file for the parser to process.) If that script itself
+includes other scripts with a C<use> or C<require> statement, then each
+of those scripts will have to be read from their respective files as
+well.
+
+Now think of each logical connection between the Perl parser and an
+individual file as a I<source stream>. A source stream is created when
+the Perl parser opens a file, it continues to exist as the source code
+is read into memory, and it is destroyed when Perl is finished parsing
+the file. If the parser encounters a C<require> or C<use> statement in
+a source stream, a new and distinct stream is created just for that
+file.
+
+The diagram below represents a single source stream, with the flow of
+source from a Perl script file on the left into the Perl parser on the
+right. This is how Perl normally operates.
+
+ file -------> parser
+
+There are two important points to remember:
+
+=over 5
+
+=item 1.
+
+Although there can be any number of source streams in existence at any
+given time, only one will be active.
+
+=item 2.
+
+Every source stream is associated with only one file.
+
+=back
+
+A source filter is a special kind of Perl module that intercepts and
+modifies a source stream before it reaches the parser. A source filter
+changes the our diagram like this:
+
+ file ----> filter ----> parser
+
+If that doesn't make much sense, consider the analogy of a command
+pipeline. Say you have a shell script stored in the compressed file
+I<trial.gz>. The simple pipeline command below runs the script without
+needing to create a temporary file to hold the uncompressed file.
+
+ gunzip -c trial.gz | sh
+
+In this case, the data flow from the pipeline can be represented as follows:
+
+ trial.gz ----> gunzip ----> sh
+
+With source filters, you can store the text of your script compressed and use a source filter to uncompress it for Perl's parser:
+
+ compressed gunzip
+ Perl program ---> source filter ---> parser
+
+=head1 USING FILTERS
+
+So how do you use a source filter in a Perl script? Above, I said that
+a source filter is just a special kind of module. Like all Perl
+modules, a source filter is invoked with a use statement.
+
+Say you want to pass your Perl source through the C preprocessor before
+execution. You could use the existing C<-P> command line option to do
+this, but as it happens, the source filters distribution comes with a C
+preprocessor filter module called Filter::cpp. Let's use that instead.
+
+Below is an example program, C<cpp_test>, which makes use of this filter.
+Line numbers have been added to allow specific lines to be referenced
+easily.
+
+ 1: use Filter::cpp ;
+ 2: #define TRUE 1
+ 3: $a = TRUE ;
+ 4: print "a = $a\n" ;
+
+When you execute this script, Perl creates a source stream for the
+file. Before the parser processes any of the lines from the file, the
+source stream looks like this:
+
+ cpp_test ---------> parser
+
+Line 1, C<use Filter::cpp>, includes and installs the C<cpp> filter
+module. All source filters work this way. The use statement is compiled
+and executed at compile time, before any more of the file is read, and
+it attaches the cpp filter to the source stream behind the scenes. Now
+the data flow looks like this:
+
+ cpp_test ----> cpp filter ----> parser
+
+As the parser reads the second and subsequent lines from the source
+stream, it feeds those lines through the C<cpp> source filter before
+processing them. The C<cpp> filter simply passes each line through the
+real C preprocessor. The output from the C preprocessor is then
+inserted back into the source stream by the filter.
+
+ .-> cpp --.
+ | |
+ | |
+ | <-'
+ cpp_test ----> cpp filter ----> parser
+
+The parser then sees the following code:
+
+ use Filter::cpp ;
+ $a = 1 ;
+ print "a = $a\n" ;
+
+Let's consider what happens when the filtered code includes another
+module with use:
+
+ 1: use Filter::cpp ;
+ 2: #define TRUE 1
+ 3: use Fred ;
+ 4: $a = TRUE ;
+ 5: print "a = $a\n" ;
+
+The C<cpp> filter does not apply to the text of the Fred module, only
+to the text of the file that used it (C<cpp_test>). Although the use
+statement on line 3 will pass through the cpp filter, the module that
+gets included (C<Fred>) will not. The source streams look like this
+after line 3 has been parsed and before line 4 is parsed:
+
+ cpp_test ---> cpp filter ---> parser (INACTIVE)
+
+ Fred.pm ----> parser
+
+As you can see, a new stream has been created for reading the source
+from C<Fred.pm>. This stream will remain active until all of C<Fred.pm>
+has been parsed. The source stream for C<cpp_test> will still exist,
+but is inactive. Once the parser has finished reading Fred.pm, the
+source stream associated with it will be destroyed. The source stream
+for C<cpp_test> then becomes active again and the parser reads line 4
+and subsequent lines from C<cpp_test>.
+
+You can use more than one source filter on a single file. Similarly,
+you can reuse the same filter in as many files as you like.
+
+For example, if you have a uuencoded and compressed source file, it is
+possible to stack a uudecode filter and an uncompression filter like
+this:
+
+ use Filter::uudecode ; use Filter::uncompress ;
+ M'XL(".H<US4''V9I;F%L')Q;>7/;1I;_>_I3=&E=%:F*I"T?22Q/
+ M6]9*<IQCO*XFT"0[PL%%'Y+IG?WN^ZYN-$'J.[.JE$,20/?K=_[>
+ ...
+
+Once the first line has been processed, the flow will look like this:
+
+ file ---> uudecode ---> uncompress ---> parser
+ filter filter
+
+Data flows through filters in the same order they appear in the source
+file. The uudecode filter appeared before the uncompress filter, so the
+source file will be uudecoded before it's uncompressed.
+
+=head1 WRITING A SOURCE FILTER
+
+There are three ways to write your own source filter. You can write it
+in C, use an external program as a filter, or write the filter in Perl.
+I won't cover the first two in any great detail, so I'll get them out
+of the way first. Writing the filter in Perl is most convenient, so
+I'll devote the most space to it.
+
+=head1 WRITING A SOURCE FILTER IN C
+
+The first of the three available techniques is to write the filter
+completely in C. The external module you create interfaces directly
+with the source filter hooks provided by Perl.
+
+The advantage of this technique is that you have complete control over
+the implementation of your filter. The big disadvantage is the
+increased complexity required to write the filter - not only do you
+need to understand the source filter hooks, but you also need a
+reasonable knowledge of Perl guts. One of the few times it is worth
+going to this trouble is when writing a source scrambler. The
+C<decrypt> filter (which unscrambles the source before Perl parses it)
+included with the source filter distribution is an example of a C
+source filter (see Decryption Filters, below).
+
+
+=over 5
+
+=item B<Decryption Filters>
+
+All decryption filters work on the principle of "security through
+obscurity." Regardless of how well you write a decryption filter and
+how strong your encryption algorithm, anyone determined enough can
+retrieve the original source code. The reason is quite simple - once
+the decryption filter has decrypted the source back to its original
+form, fragments of it will be stored in the computer's memory as Perl
+parses it. The source might only be in memory for a short period of
+time, but anyone possessing a debugger, skill, and lots of patience can
+eventually reconstruct your program.
+
+That said, there are a number of steps that can be taken to make life
+difficult for the potential cracker. The most important: Write your
+decryption filter in C and statically link the decryption module into
+the Perl binary. For further tips to make life difficult for the
+potential cracker, see the file I<decrypt.pm> in the source filters
+module.
+
+=back
+
+=head1 CREATING A SOURCE FILTER AS A SEPARATE EXECUTABLE
+
+An alternative to writing the filter in C is to create a separate
+executable in the language of your choice. The separate executable
+reads from standard input, does whatever processing is necessary, and
+writes the filtered data to standard output. C<Filter:cpp> is an
+example of a source filter implemented as a separate executable - the
+executable is the C preprocessor bundled with your C compiler.
+
+The source filter distribution includes two modules that simplify this
+task: C<Filter::exec> and C<Filter::sh>. Both allow you to run any
+external executable. Both use a coprocess to control the flow of data
+into and out of the external executable. (For details on coprocesses,
+see Stephens, W.R. "Advanced Programming in the UNIX Environment."
+Addison-Wesley, ISBN 0-210-56317-7, pages 441-445.) The difference
+between them is that C<Filter::exec> spawns the external command
+directly, while C<Filter::sh> spawns a shell to execute the external
+command. (Unix uses the Bourne shell; NT uses the cmd shell.) Spawning
+a shell allows you to make use of the shell metacharacters and
+redirection facilities.
+
+Here is an example script that uses C<Filter::sh>:
+
+ use Filter::sh 'tr XYZ PQR' ;
+ $a = 1 ;
+ print "XYZ a = $a\n" ;
+
+The output you'll get when the script is executed:
+
+ PQR a = 1
+
+Writing a source filter as a separate executable works fine, but a
+small performance penalty is incurred. For example, if you execute the
+small example above, a separate subprocess will be created to run the
+Unix C<tr> command. Each use of the filter requires its own subprocess.
+If creating subprocesses is expensive on your system, you might want to
+consider one of the other options for creating source filters.
+
+=head1 WRITING A SOURCE FILTER IN PERL
+
+The easiest and most portable option available for creating your own
+source filter is to write it completely in Perl. To distinguish this
+from the previous two techniques, I'll call it a Perl source filter.
+
+To help understand how to write a Perl source filter we need an example
+to study. Here is a complete source filter that performs rot13
+decoding. (Rot13 is a very simple encryption scheme used in Usenet
+postings to hide the contents of offensive posts. It moves every letter
+forward thirteen places, so that A becomes N, B becomes O, and Z
+becomes M.)
+
+
+ package Rot13 ;
+
+ use Filter::Util::Call ;
+
+ sub import {
+ my ($type) = @_ ;
+ my ($ref) = [] ;
+ filter_add(bless $ref) ;
+ }
+
+ sub filter {
+ my ($self) = @_ ;
+ my ($status) ;
+
+ tr/n-za-mN-ZA-M/a-zA-Z/
+ if ($status = filter_read()) > 0 ;
+ $status ;
+ }
+
+ 1;
+
+All Perl source filters are implemented as Perl classes and have the
+same basic structure as the example above.
+
+First, we include the C<Filter::Util::Call> module, which exports a
+number of functions into your filter's namespace. The filter shown
+above uses two of these functions, C<filter_add()> and
+C<filter_read()>.
+
+Next, we create the filter object and associate it with the source
+stream by defining the C<import> function. If you know Perl well
+enough, you know that C<import> is called automatically every time a
+module is included with a use statement. This makes C<import> the ideal
+place to both create and install a filter object.
+
+In the example filter, the object (C<$ref>) is blessed just like any
+other Perl object. Our example uses an anonymous array, but this isn't
+a requirement. Because this example doesn't need to store any context
+information, we could have used a scalar or hash reference just as
+well. The next section demonstrates context data.
+
+The association between the filter object and the source stream is made
+with the C<filter_add()> function. This takes a filter object as a
+parameter (C<$ref> in this case) and installs it in the source stream.
+
+Finally, there is the code that actually does the filtering. For this
+type of Perl source filter, all the filtering is done in a method
+called C<filter()>. (It is also possible to write a Perl source filter
+using a closure. See the C<Filter::Util::Call> manual page for more
+details.) It's called every time the Perl parser needs another line of
+source to process. The C<filter()> method, in turn, reads lines from
+the source stream using the C<filter_read()> function.
+
+If a line was available from the source stream, C<filter_read()>
+returns a status value greater than zero and appends the line to C<$_>.
+A status value of zero indicates end-of-file, less than zero means an
+error. The filter function itself is expected to return its status in
+the same way, and put the filtered line it wants written to the source
+stream in C<$_>. The use of C<$_> accounts for the brevity of most Perl
+source filters.
+
+In order to make use of the rot13 filter we need some way of encoding
+the source file in rot13 format. The script below, C<mkrot13>, does
+just that.
+
+ die "usage mkrot13 filename\n" unless @ARGV ;
+ my $in = $ARGV[0] ;
+ my $out = "$in.tmp" ;
+ open(IN, "<$in") or die "Cannot open file $in: $!\n";
+ open(OUT, ">$out") or die "Cannot open file $out: $!\n";
+
+ print OUT "use Rot13;\n" ;
+ while (<IN>) {
+ tr/a-zA-Z/n-za-mN-ZA-M/ ;
+ print OUT ;
+ }
+
+ close IN;
+ close OUT;
+ unlink $in;
+ rename $out, $in;
+
+If we encrypt this with C<mkrot13>:
+
+ print " hello fred \n" ;
+
+the result will be this:
+
+ use Rot13;
+ cevag "uryyb serq\a" ;
+
+Running it produces this output:
+
+ hello fred
+
+=head1 USING CONTEXT: THE DEBUG FILTER
+
+The rot13 example was a trivial example. Here's another demonstration
+that shows off a few more features.
+
+Say you wanted to include a lot of debugging code in your Perl script
+during development, but you didn't want it available in the released
+product. Source filters offer a solution. In order to keep the example
+simple, let's say you wanted the debugging output to be controlled by
+an environment variable, C<DEBUG>. Debugging code is enabled if the
+variable exists, otherwise it is disabled.
+
+Two special marker lines will bracket debugging code, like this:
+
+ ## DEBUG_BEGIN
+ if ($year > 1999) {
+ warn "Debug: millennium bug in year $year\n" ;
+ }
+ ## DEBUG_END
+
+When the C<DEBUG> environment variable exists, the filter ensures that
+Perl parses only the code between the C<DEBUG_BEGIN> and C<DEBUG_END>
+markers. That means that when C<DEBUG> does exist, the code above
+should be passed through the filter unchanged. The marker lines can
+also be passed through as-is, because the Perl parser will see them as
+comment lines. When C<DEBUG> isn't set, we need a way to disable the
+debug code. A simple way to achieve that is to convert the lines
+between the two markers into comments:
+
+ ## DEBUG_BEGIN
+ #if ($year > 1999) {
+ # warn "Debug: millennium bug in year $year\n" ;
+ #}
+ ## DEBUG_END
+
+Here is the complete Debug filter:
+
+ package Debug;
+
+ use strict;
+ use warnings;
+ use Filter::Util::Call ;
+
+ use constant TRUE => 1 ;
+ use constant FALSE => 0 ;
+
+ sub import {
+ my ($type) = @_ ;
+ my (%context) = (
+ Enabled => defined $ENV{DEBUG},
+ InTraceBlock => FALSE,
+ Filename => (caller)[1],
+ LineNo => 0,
+ LastBegin => 0,
+ ) ;
+ filter_add(bless \%context) ;
+ }
+
+ sub Die {
+ my ($self) = shift ;
+ my ($message) = shift ;
+ my ($line_no) = shift || $self->{LastBegin} ;
+ die "$message at $self->{Filename} line $line_no.\n"
+ }
+
+ sub filter {
+ my ($self) = @_ ;
+ my ($status) ;
+ $status = filter_read() ;
+ ++ $self->{LineNo} ;
+
+ # deal with EOF/error first
+ if ($status <= 0) {
+ $self->Die("DEBUG_BEGIN has no DEBUG_END")
+ if $self->{InTraceBlock} ;
+ return $status ;
+ }
+
+ if ($self->{InTraceBlock}) {
+ if (/^\s*##\s*DEBUG_BEGIN/ ) {
+ $self->Die("Nested DEBUG_BEGIN", $self->{LineNo})
+ } elsif (/^\s*##\s*DEBUG_END/) {
+ $self->{InTraceBlock} = FALSE ;
+ }
+
+ # comment out the debug lines when the filter is disabled
+ s/^/#/ if ! $self->{Enabled} ;
+ } elsif ( /^\s*##\s*DEBUG_BEGIN/ ) {
+ $self->{InTraceBlock} = TRUE ;
+ $self->{LastBegin} = $self->{LineNo} ;
+ } elsif ( /^\s*##\s*DEBUG_END/ ) {
+ $self->Die("DEBUG_END has no DEBUG_BEGIN", $self->{LineNo});
+ }
+ return $status ;
+ }
+
+ 1 ;
+
+The big difference between this filter and the previous example is the
+use of context data in the filter object. The filter object is based on
+a hash reference, and is used to keep various pieces of context
+information between calls to the filter function. All but two of the
+hash fields are used for error reporting. The first of those two,
+Enabled, is used by the filter to determine whether the debugging code
+should be given to the Perl parser. The second, InTraceBlock, is true
+when the filter has encountered a C<DEBUG_BEGIN> line, but has not yet
+encountered the following C<DEBUG_END> line.
+
+If you ignore all the error checking that most of the code does, the
+essence of the filter is as follows:
+
+ sub filter {
+ my ($self) = @_ ;
+ my ($status) ;
+ $status = filter_read() ;
+
+ # deal with EOF/error first
+ return $status if $status <= 0 ;
+ if ($self->{InTraceBlock}) {
+ if (/^\s*##\s*DEBUG_END/) {
+ $self->{InTraceBlock} = FALSE
+ }
+
+ # comment out debug lines when the filter is disabled
+ s/^/#/ if ! $self->{Enabled} ;
+ } elsif ( /^\s*##\s*DEBUG_BEGIN/ ) {
+ $self->{InTraceBlock} = TRUE ;
+ }
+ return $status ;
+ }
+
+Be warned: just as the C-preprocessor doesn't know C, the Debug filter
+doesn't know Perl. It can be fooled quite easily:
+
+ print <<EOM;
+ ##DEBUG_BEGIN
+ EOM
+
+Such things aside, you can see that a lot can be achieved with a modest
+amount of code. I<[Note that Tuomas' toy VRML parser on p. 17 had the
+same difficulty parsing VRML strings that look like comments. -Jon]>
+
+=head1 CONCLUSION
+
+You now have better understanding of what a source filter is, and you
+might even have a possible use for them. If you feel like playing with
+source filters but need a bit of inspiration, here are some extra
+features you could add to the Debug filter.
+
+First, an easy one. Rather than having debugging code that is
+all-or-nothing, it would be much more useful to be able to control
+which specific blocks of debugging code get included. Try extending the
+syntax for debug blocks to allow each to be identified. The contents of
+the C<DEBUG> environment variable can then be used to control which
+blocks get included.
+
+Once you can identify individual blocks, try allowing them to be
+nested. That isn't difficult either.
+
+Here is a interesting idea that doesn't involve the Debug filter.
+Currently Perl subroutines have fairly limited support for formal
+parameter lists. You can specify the number of parameters and their
+type, but you still have to manually take them out of the C<@_> array
+yourself. Write a source filter that allows you to have a named
+parameter list. Such a filter would turn this:
+
+ sub MySub ($first, $second, @rest) { ... }
+
+into this:
+
+ sub MySub($$@) {
+ my ($first) = shift ;
+ my ($second) = shift ;
+ my (@rest) = @_ ;
+ ...
+ }
+
+Finally, if you feel like a real challenge, have a go at writing a
+full-blown Perl macro preprocessor as a source filter. Borrow the
+useful features from the C preprocessor and any other macro processors
+you know. The tricky bit will be choosing how much knowledge of Perl's
+syntax you want your filter to have.
+
+=head1 REQUIREMENTS
+
+The Source Filters distribution is available on CPAN, in
+
+ CPAN/modules/by-module/Filter
+
+=head1 AUTHOR
+
+Paul Marquess E<lt>Paul.Marquess@btinternet.comE<gt>
+
+=head1 Copyrights
+
+This article originally appeared in The Perl Journal #11, and is
+copyright 1998 The Perl Journal. It appears courtesy of Jon Orwant and
+The Perl Journal. This document may be distributed under the same terms
+as Perl itself.
--- /dev/null
+use strict;
+use warnings;
+
+use vars qw($Inc $Perl);
+
+require 'filter-util.pl';
+
+print "1..32\n" ;
+
+$Perl = "$Perl -w" ;
+
+use Cwd ;
+my $here = getcwd ;
+
+
+my $filename = "call.tst" ;
+my $filename2 = "call2.tst" ;
+my $filenamebin = "call.bin" ;
+my $module = "MyTest" ;
+my $module2 = "MyTest2" ;
+my $module3 = "MyTest3" ;
+my $module4 = "MyTest4" ;
+my $module5 = "MyTest5" ;
+my $module6 = "MyTest6" ;
+my $nested = "nested" ;
+my $block = "block" ;
+my $redir = $^O eq 'MacOS' ? "" : "2>&1";
+
+# Test error cases
+##################
+
+# no filter function in module
+###############################
+
+writeFile("${module}.pm", <<EOM) ;
+package ${module} ;
+
+use Filter::Util::Call ;
+
+sub import { filter_add(bless []) }
+
+1 ;
+EOM
+
+my $a = `$Perl "-I." $Inc -e "use ${module} ;" $redir` ;
+ok(1, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'MacOS' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ;
+ok(2, $a =~ /^Can't locate object method "filter" via package "MyTest"/) ;
+
+# no reference parameter in filter_add
+######################################
+
+writeFile("${module}.pm", <<EOM) ;
+package ${module} ;
+
+use Filter::Util::Call ;
+
+sub import { filter_add() }
+
+1 ;
+EOM
+
+$a = `$Perl "-I." $Inc -e "use ${module} ;" $redir` ;
+ok(3, (($? >>8) != 0 or (($^O eq 'MSWin32' || $^O eq 'MacOS' || $^O eq 'NetWare' || $^O eq 'mpeix') && $? != 0))) ;
+#ok(4, $a =~ /^usage: filter_add\(ref\) at ${module}.pm/) ;
+ok(4, $a =~ /^Not enough arguments for Filter::Util::Call::filter_add/) ;
+
+
+
+
+# non-error cases
+#################
+
+
+# a simple filter, using a closure
+#################
+
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+
+EOM
+use Filter::Util::Call ;
+sub import {
+ filter_add(
+ sub {
+
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+ } ) ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module ;
+EOM
+
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(5, ($? >>8) == 0) ;
+ok(6, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+# a simple filter, not using a closure
+#################
+
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+
+EOM
+use Filter::Util::Call ;
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+}
+
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module ;
+EOM
+
+use Cwd ;
+$here = getcwd ;
+print "I am $here\n" ;
+print "some letters ABC\n" ;
+$y = "ABCDEF" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(7, ($? >>8) == 0) ;
+ok(8, $a eq <<EOM) ;
+I am $here
+some letters DEF
+Alphabetti Spagetti (DEFDEF)
+EOM
+
+
+# nested filters
+################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/XYZ/PQR/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile("${module3}.pm", <<EOM, <<'EOM') ;
+package ${module3} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(
+
+ sub
+ {
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Fred/Joe/g
+ }
+ $status ;
+ } ) ;
+}
+
+1 ;
+EOM
+
+writeFile("${module4}.pm", <<EOM) ;
+package ${module4} ;
+
+use $module5 ;
+
+print "I'm feeling used!\n" ;
+print "Fred Joe ABC DEF PQR XYZ\n" ;
+print "See you Today\n" ;
+1;
+EOM
+
+writeFile("${module5}.pm", <<EOM, <<'EOM') ;
+package ${module5} ;
+use Filter::Util::Call ;
+
+EOM
+sub import { filter_add(bless []) }
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/Today/Tomorrow/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+# two filters for this file
+use $module ;
+use $module2 ;
+require "$nested" ;
+use $module4 ;
+EOM
+
+print "some letters ABCXYZ\n" ;
+$y = "ABCDEFXYZ" ;
+print <<EOF ;
+Fred likes Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+writeFile($nested, <<EOM, <<'EOM') ;
+use $module3 ;
+EOM
+
+print "This is another file XYZ\n" ;
+print <<EOF ;
+Where is Fred?
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(9, ($? >>8) == 0) ;
+ok(10, $a eq <<EOM) ;
+I'm feeling used!
+Fred Joe ABC DEF PQR XYZ
+See you Tomorrow
+This is another file XYZ
+Where is Joe?
+some letters DEFPQR
+Fred likes Alphabetti Spagetti (DEFDEFPQR)
+EOM
+
+# using the module context (with a closure)
+###########################################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (
+
+ sub
+ {
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@strings)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+ }
+ )
+
+}
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(11, ($? >>8) == 0) ;
+ok(12, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+
+
+# using the module context (without a closure)
+##############################################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings])
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ if (($status = filter_read()) > 0) {
+ foreach $pattern (@$self)
+ { s/$pattern/PQR/g }
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 qw( XYZ KLM) ;
+use $module2 qw( ABC NMO) ;
+EOM
+
+print "some letters ABCXYZ KLM NMO\n" ;
+$y = "ABCDEFXYZKLMNMO" ;
+print <<EOF ;
+Alphabetti Spagetti ($y)
+EOF
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(13, ($? >>8) == 0) ;
+ok(14, $a eq <<EOM) ;
+some letters PQRPQR PQR PQR
+Alphabetti Spagetti (PQRDEFPQRPQRPQR)
+EOM
+
+# multi line test
+#################
+
+
+writeFile("${module2}.pm", <<EOM, <<'EOM') ;
+package ${module2} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [])
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ # read first line
+ if (($status = filter_read()) > 0) {
+ chop ;
+ s/\r$//;
+ # and now the second line (it will append)
+ $status = filter_read() ;
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+
+writeFile($filename, <<EOM, <<'EOM') ;
+
+use $module2 ;
+EOM
+print "don't cut me
+in half\n" ;
+print
+<<EOF ;
+appen
+ded
+EO
+F
+
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(15, ($? >>8) == 0) ;
+ok(16, $a eq <<EOM) ;
+don't cut me in half
+appended
+EOM
+
+# Block test
+#############
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add (bless [@strings] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($pattern) ;
+
+ filter_read(20) ;
+}
+
+1 ;
+EOM
+
+my $string = <<'EOM' ;
+print "hello mum\n" ;
+$x = 'me ' x 3 ;
+print "Who wants it?\n$x\n" ;
+EOM
+
+
+writeFile($filename, <<EOM, $string ) ;
+use $block ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(17, ($? >>8) == 0) ;
+ok(18, $a eq <<EOM) ;
+hello mum
+Who wants it?
+me me me
+EOM
+
+# use in the filter
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+use Cwd ;
+
+sub import
+{
+ my ($type) = shift ;
+ my (@strings) = @_ ;
+
+
+ filter_add(bless [@strings] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+ my ($here) = quotemeta getcwd ;
+
+ if (($status = filter_read()) > 0) {
+ s/DIR/$here/g
+ }
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "We are in DIR\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(19, ($? >>8) == 0) ;
+ok(20, $a eq <<EOM) ;
+We are in $here
+EOM
+
+
+# filter_del
+#############
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+ my ($count) = @_ ;
+
+
+ filter_add(bless \$count )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ s/HERE/THERE/g
+ if ($status = filter_read()) > 0 ;
+
+ -- $$self ;
+ filter_del() if $$self <= 0 ;
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block (3) ;
+EOM
+print "
+HERE I am
+I am HERE
+HERE today gone tomorrow\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(21, ($? >>8) == 0) ;
+ok(22, $a eq <<EOM) ;
+
+THERE I am
+I am THERE
+HERE today gone tomorrow
+EOM
+
+
+# filter_read_exact
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read_exact(9)) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filenamebin, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "
+HERE I am
+I'm HERE
+HERE today gone tomorrow\n" ;
+EOM
+
+$a = `$Perl "-I." $Inc $filenamebin $redir` ;
+ok(23, ($? >>8) == 0) ;
+ok(24, $a eq <<EOM) ;
+
+HERE I am
+I'm THERE
+THERE today gone tomorrow
+EOM
+
+{
+
+# Check __DATA__
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+print @a;
+__DATA__
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(25, ($? >>8) == 0) ;
+ok(26, $a eq <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+{
+
+# Check __END__
+####################
+
+writeFile("${block}.pm", <<EOM, <<'EOM') ;
+package ${block} ;
+use Filter::Util::Call ;
+
+EOM
+
+sub import
+{
+ my ($type) = shift ;
+
+ filter_add(bless [] )
+}
+
+sub filter
+{
+ my ($self) = @_ ;
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/HERE/THERE/g
+ }
+
+ $status ;
+}
+
+1 ;
+EOM
+
+writeFile($filename, <<EOM, <<'EOM') ;
+use $block ;
+EOM
+print "HERE HERE\n";
+@a = <DATA>;
+print @a;
+__END__
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+$a = `$Perl "-I." $Inc $filename $redir` ;
+ok(27, ($? >>8) == 0) ;
+ok(28, $a eq <<EOM) ;
+THERE THERE
+HERE I am
+I'm HERE
+HERE today gone tomorrow
+EOM
+
+}
+
+{
+
+# no without use
+# see Message-ID: <20021106212427.A15377@ttul.org>
+####################
+
+writeFile("${module6}.pm", <<EOM);
+package ${module6} ;
+#use Filter::Simple;
+#FILTER {}
+use Filter::Util::Call;
+sub import { filter_add(sub{}) }
+sub unimport { filter_del() }
+1;
+EOM
+
+writeFile($filename2, <<EOM);
+no ${module6} ;
+print "ok";
+EOM
+
+my $str = $^O eq 'MacOS' ? "'ok'" : "q{ok}";
+my $a = `$Perl "-I." $Inc -e "no ${module6}; print $str"`;
+ok(29, ($? >>8) == 0);
+chomp( $a ) if $^O eq 'VMS';
+ok(30, $a eq 'ok');
+
+$a = `$Perl "-I." $Inc $filename2`;
+ok(31, ($? >>8) == 0);
+chomp( $a ) if $^O eq 'VMS';
+ok(32, $a eq 'ok');
+
+}
+
+END {
+ 1 while unlink $filename ;
+ 1 while unlink $filename2 ;
+ 1 while unlink $filenamebin ;
+ 1 while unlink "${module}.pm" ;
+ 1 while unlink "${module2}.pm" ;
+ 1 while unlink "${module3}.pm" ;
+ 1 while unlink "${module4}.pm" ;
+ 1 while unlink "${module5}.pm" ;
+ 1 while unlink "${module6}.pm" ;
+ 1 while unlink $nested ;
+ 1 while unlink "${block}.pm" ;
+}
+
+
--- /dev/null
+
+use strict;
+use warnings;
+use Config;
+
+BEGIN
+{
+ my $cpp;
+ my $sep;
+ if ($^O eq 'MSWin32') {
+ $cpp = 'cpp.exe' ;
+ $sep = ';';
+ }
+ else {
+ ($cpp) = $Config{cppstdin} =~ /^(\S+)/;
+ $sep = ':';
+ }
+
+ if (! $cpp) {
+ print "1..0 # Skipping cpp not found on this system.\n" ;
+ exit 0 ;
+ }
+
+ # Check if cpp is installed
+ if ( ! -x $cpp) {
+ my $foundCPP = 0 ;
+ foreach my $dir (split($sep, $ENV{PATH}), '')
+ {
+ if (-x "$dir/$cpp")
+ {
+ $foundCPP = 1;
+ last ;
+ }
+ }
+
+ if (! $foundCPP) {
+ print "1..0 # Skipping cpp not found on this system.\n" ;
+ exit 0 ;
+ }
+ }
+}
+
+use vars qw( $Inc $Perl ) ;
+
+require "./filter-util.pl" ;
+
+my $script = <<'EOF' ;
+use Filter::cpp ;
+#define FRED 1
+#define JOE
+
+#a perl comment, not a cpp line
+
+$a = FRED + 2 ;
+print "a = $a\n" ;
+
+require "./fred" ;
+
+#ifdef JOE
+ print "Hello Joe\n" ;
+#else
+ print "Where is Joe?\n" ;
+#endif
+EOF
+
+my $cpp_script = 'cpp.script' ;
+writeFile($cpp_script, $script) ;
+writeFile('fred', 'print "This is FRED, not JOE\n" ; 1 ;') ;
+
+my $expected_output = <<'EOM' ;
+a = 3
+This is FRED, not JOE
+Hello Joe
+EOM
+
+$a = `$Perl $Inc $cpp_script 2>&1` ;
+
+print "1..2\n" ;
+ok(1, ($? >>8) == 0) ;
+#print "|$a| vs |$expected_output|\n";
+ok(2, $a eq $expected_output) ;
+
+unlink $cpp_script ;
+unlink 'fred' ;
--- /dev/null
+
+use strict;
+use warnings;
+
+require "filter-util.pl" ;
+use Cwd ;
+my $here = getcwd ;
+
+use vars qw( $Inc $Perl ) ;
+
+my $script = <<'EOM' ;
+
+print "testing, testing, 1, 2, 3\n" ;
+require "./plain" ;
+use Cwd ;
+$cwd = getcwd ;
+print <<EOT ;
+some
+more test
+lines
+EOT
+
+print "a multi-line
+ string
+$cwd\n" ;
+
+format STDOUT_TOP =
+I'm a format top
+.
+
+format STDOUT =
+@<<<<<<<<<
+"I'm not"
+.
+
+
+write ;
+EOM
+
+my $expected_output = <<EOM ;
+testing, testing, 1, 2, 3
+This is plain text
+some
+more test
+lines
+a multi-line
+ string
+$here
+I'm a format top
+I'm not
+EOM
+
+my $filename = "decrypt.tst" ;
+
+writeFile($filename, $script) ;
+`$Perl decrypt/encrypt $filename` ;
+writeFile('plain', 'print "This is plain text\n" ; 1 ;') ;
+
+my $a = `$Perl $Inc $filename 2>&1` ;
+
+print "1..6\n" ;
+
+print "# running perl with $Perl\n";
+print "# test 1: \$? $?\n" unless ($? >>8) == 0 ;
+
+ok(1, ($? >>8) == 0) ;
+print "# test 2: Got '$a'\n" unless $a eq $expected_output ;
+ok(2, $a eq $expected_output) ;
+
+# try to catch error cases
+
+# case 1 - Perl debugger
+$ENV{'PERLDB_OPTS'} = 'noTTY' ;
+$a = `$Perl $Inc -d $filename 2>&1` ;
+print "# test 3: Got '$a'\n" unless $a =~ /debugger disabled/ ;
+ok(3, $a =~ /debugger disabled/) ;
+
+# case 2 - Perl Compiler in use
+$a = `$Perl $Inc -MCarp -MO=Deparse $filename 2>&1` ;
+#print "[[$a]]\n" ;
+my $skip = "" ;
+$skip = "# skipped -- compiler not available"
+ if $a =~ /^Can't locate O\.pm in/ ||
+ $a =~ /^Can't load '/ ||
+ $a =~ /^"my" variable \$len masks/ ;
+print "# test 4: Got '$a'\n" unless $skip || $a =~ /Aborting, Compiler detected/;
+ok(4, ($skip || $a =~ /Aborting, Compiler detected/), $skip) ;
+
+# case 3 - unknown encryption
+writeFile($filename, <<EOM) ;
+use Filter::decrypt ;
+mary had a little lamb
+EOM
+
+$a = `$Perl $Inc $filename 2>&1` ;
+
+print "# test 5: Got '$a'\n" unless $a =~ /bad encryption format/ ;
+ok(5, $a =~ /bad encryption format/) ;
+
+# case 4 - extra source filter on the same line
+writeFile($filename, <<EOM) ;
+use Filter::decrypt ; use Filter::tee '/dev/null' ;
+mary had a little lamb
+EOM
+
+$a = `$Perl $Inc $filename 2>&1` ;
+print "# test 6: Got '$a'\n" unless $a =~ /too many filters/ ;
+ok(6, $a =~ /too many filters/) ;
+
+unlink $filename ;
+unlink 'plain' ;
--- /dev/null
+
+use strict;
+use warnings;
+use Config;
+
+BEGIN
+{
+ my $foundTR = 0 ;
+ if ($^O eq 'MSWin32') {
+ # Check if tr is installed
+ foreach (split ";", $ENV{PATH}) {
+ if (-e "$_/tr.exe") {
+ $foundTR = 1;
+ last ;
+ }
+ }
+ }
+ else {
+ $foundTR = 1
+ if $Config{'tr'} ne '' ;
+ }
+
+ if (! $foundTR) {
+ print "1..0 # Skipping tr not found on this system.\n" ;
+ exit 0 ;
+ }
+}
+
+require "filter-util.pl" ;
+
+use vars qw( $Inc $Perl $script ) ;
+
+$script = <<'EOF' ;
+
+use Filter::exec qw(tr '[A-E][I-M]' '[a-e][i-m]') ;
+use Filter::exec qw(tr '[N-Z]' '[n-z]') ;
+
+EOF
+
+$script .= <<'EOF' ;
+
+$A = 2 ;
+PRINT "A = $A\N" ;
+
+PRINT "HELLO JOE\N" ;
+PRINT <<EOM ;
+MARY HAD
+A
+LITTLE
+LAMB
+EOM
+PRINT "A (AGAIN) = $A\N" ;
+EOF
+
+my $filename = 'sh.test' ;
+writeFile($filename, $script) ;
+
+my $expected_output = <<'EOM' ;
+a = 2
+Hello joe
+mary Had
+a
+little
+lamb
+a (aGain) = 2
+EOM
+
+$a = `$Perl $Inc $filename 2>&1` ;
+
+print "1..2\n" ;
+ok(1, ($? >> 8) == 0) ;
+ok(2, $a eq $expected_output) ;
+
+unlink $filename ;
+
--- /dev/null
+
+# check that the filters are destroyed in the correct order by
+# installing two different types of filter. If they don't get destroyed
+# in the correct order we should get a "filter_del can only delete in
+# reverse order" error
+
+# skip this set of tests is running on anything less than 5.004_55
+if ($] < 5.004_55) {
+ print "1..0\n";
+ exit 0;
+}
+
+use strict;
+use warnings;
+
+require "./filter-util.pl" ;
+
+use vars qw( $Inc $Perl) ;
+
+my $file = "tee.test" ;
+my $module = "Try";
+my $tee1 = "tee1" ;
+
+
+writeFile("${module}.pm", <<EOM, <<'EOM') ;
+package ${module} ;
+
+EOM
+use Filter::Util::Call ;
+sub import {
+ filter_add(
+ sub {
+
+ my ($status) ;
+
+ if (($status = filter_read()) > 0) {
+ s/ABC/DEF/g
+ }
+ $status ;
+ } ) ;
+}
+
+1 ;
+EOM
+
+my $fil1 = <<"EOM";
+use $module ;
+
+print "ABC ABC\n" ;
+
+EOM
+
+writeFile($file, <<"EOM", $fil1) ;
+use Filter::tee '>$tee1' ;
+EOM
+
+my $a = `$Perl $Inc $file 2>&1` ;
+
+print "1..3\n" ;
+
+ok(1, ($? >> 8) == 0) ;
+#print "|$a|\n";
+ok(2, $a eq <<EOM) ;
+DEF DEF
+EOM
+
+ok(3, $fil1 eq readFile($tee1)) ;
+
+unlink $file or die "Cannot remove $file: $!\n" ;
+unlink $tee1 or die "Cannot remove $tee1: $!\n" ;
--- /dev/null
+eval " use Test::More " ;
+
+if ($@)
+{
+ print "1..0 # Skip: Test::More required for testing POD\n" ;
+ exit 0;
+}
+
+eval "use Test::Pod 1.00";
+
+if ($@)
+{
+ print "1..0 # Skip: Test::Pod 1.00 required for testing POD\n" ;
+ exit 0;
+}
+
+all_pod_files_ok();
+
--- /dev/null
+
+use strict;
+use warnings;
+use Config;
+
+BEGIN
+{
+ my $foundTR = 0 ;
+ if ($^O eq 'MSWin32') {
+ # Check if tr is installed
+ foreach (split ";", $ENV{PATH}) {
+ if (-e "$_/tr.exe") {
+ $foundTR = 1;
+ last ;
+ }
+ }
+ }
+ else {
+ $foundTR = 1
+ if $Config{'tr'} ne '' ;
+ }
+
+ if (! $foundTR) {
+ print "1..0 # Skipping tr not found on this system.\n" ;
+ exit 0 ;
+ }
+}
+
+require "filter-util.pl" ;
+
+use vars qw( $Inc $Perl $script ) ;
+
+$script = <<'EOF' ;
+
+use Filter::sh q(tr '[A-E][I-M]' '[a-e][i-m]') ;
+use Filter::sh q(tr '[N-Z]' '[n-z]') ;
+
+EOF
+
+$script .= <<'EOF' ;
+
+$A = 2 ;
+PRINT "A = $A\N" ;
+
+PRINT "HELLO JOE\N" ;
+PRINT <<EOM ;
+MARY HAD
+A
+LITTLE
+LAMB
+EOM
+PRINT "A (AGAIN) = $A\N" ;
+EOF
+
+my $filename = 'sh.test' ;
+writeFile($filename, $script) ;
+
+my $expected_output = <<'EOM' ;
+a = 2
+Hello joe
+mary Had
+a
+little
+lamb
+a (aGain) = 2
+EOM
+
+my $a = `$Perl $Inc $filename 2>&1` ;
+
+print "1..2\n" ;
+ok(1, ($? >> 8) == 0) ;
+ok(2, $a eq $expected_output) ;
+
+unlink $filename ;
+
--- /dev/null
+
+use strict;
+use warnings;
+
+require "./filter-util.pl" ;
+
+use vars qw( $Inc $Perl $tee1) ;
+
+my $file = "tee.test" ;
+$tee1 = "tee1" ;
+my $tee2 = "tee2" ;
+
+
+my $out1 = <<"EOF" ;
+use Filter::tee '>$tee1' ;
+EOF
+
+my $out2 = <<"EOF" ;
+use Filter::tee '>>$tee2' ;
+EOF
+
+my $out3 = <<'EOF' ;
+
+$a = 1 ;
+print "a = $a\n" ;
+
+use Carp ;
+require "./joe" ;
+
+print <<EOM ;
+hello
+horray
+
+EOM
+
+exit 0 ;
+
+EOF
+
+my $out4 = <<'EOM' ;
+Here is the news
+EOM
+
+writeFile($file, $out1, $out2, $out3) ;
+writeFile('joe', 'print "joe\n"') ;
+writeFile($tee2, $out4) ;
+
+my $a = `$Perl $Inc $file 2>&1` ;
+
+print "1..5\n" ;
+
+ok(1, ($? >> 8) == 0) ;
+ok(2, $a eq <<EOM) ;
+a = 1
+joe
+hello
+horray
+
+EOM
+
+ok(3, $out2 . $out3 eq readFile($tee1)) ;
+ok(4, $out4 . $out3 eq readFile($tee2)) ;
+
+if ($< == 0)
+ { ok (5, 1) }
+else {
+ chmod 0444, $tee1 ;
+ $a = `$Perl $Inc $file 2>&1` ;
+
+ ok(5, $a =~ /cannot open file 'tee1':/) ;
+}
+
+unlink $file or die "Cannot remove $file: $!\n" ;
+unlink 'joe' or die "Cannot remove joe: $!\n" ;
+unlink $tee1 or die "Cannot remove $tee1: $!\n" ;
+unlink $tee2 or die "Cannot remove $tee2: $!\n" ;
--- /dev/null
+use ExtUtils::MakeMaker;
+
+
+WriteMakefile(
+ NAME => 'Filter::tee',
+ VERSION_FROM => 'tee.pm',
+);
--- /dev/null
+package Filter::tee ;
+
+require 5.002;
+require DynaLoader;
+use strict;
+use warnings;
+use vars qw( @ISA $VERSION);
+@ISA = qw(DynaLoader);
+$VERSION = "1.02" ;
+
+bootstrap Filter::tee ;
+
+1;
+__END__
+
+=head1 NAME
+
+Filter::tee - tee source filter
+
+=head1 SYNOPSIS
+
+ use Filter::tee 'filename' ;
+ use Filter::tee '>filename' ;
+ use Filter::tee '>>filename' ;
+
+=head1 DESCRIPTION
+
+This filter copies all text from the line after the C<use> in the
+current source file to the file specified by the parameter
+C<filename>.
+
+By default and when the filename is prefixed with a '>' the output file
+will be emptied first if it already exists.
+
+If the output filename is prefixed with '>>' it will be opened for
+appending.
+
+This filter is useful as a debugging aid when developing other source
+filters.
+
+=head1 AUTHOR
+
+Paul Marquess
+
+=head1 DATE
+
+20th June 1995.
+
+=cut
+
--- /dev/null
+/*
+ * Filename : tee.xs
+ *
+ * Author : Paul Marquess
+ * Date : 26th March 2000
+ * Version : 1.01
+ *
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include "../Call/ppport.h"
+
+static I32
+filter_tee(pTHX_ int idx, SV *buf_sv, int maxlen)
+{
+ I32 len;
+ PerlIO * fil = (PerlIO*) SvIV(FILTER_DATA(idx)) ;
+ int old_len = SvCUR(buf_sv) ;
+
+ if ( (len = FILTER_READ(idx+1, buf_sv, maxlen)) <=0 ) {
+ /* error or eof */
+ PerlIO_close(fil) ;
+ filter_del(filter_tee); /* remove me from filter stack */
+ return len;
+ }
+
+ /* write to the tee'd file */
+ PerlIO_write(fil, SvPVX(buf_sv) + old_len, len - old_len) ;
+
+ return SvCUR(buf_sv);
+}
+
+MODULE = Filter::tee PACKAGE = Filter::tee
+
+PROTOTYPES: DISABLE
+
+void
+import(module, filename)
+ SV * module = NO_INIT
+ char * filename
+ CODE:
+ SV * stream = newSViv(0) ;
+ PerlIO * fil ;
+ char * mode = "wb" ;
+
+ filter_add(filter_tee, stream);
+ /* check for append */
+ if (*filename == '>') {
+ ++ filename ;
+ if (*filename == '>') {
+ ++ filename ;
+ mode = "ab" ;
+ }
+ }
+ if ((fil = PerlIO_open(filename, mode)) == NULL)
+ croak("Filter::tee - cannot open file '%s': %s",
+ filename, Strerror(errno)) ;
+
+ /* save the tee'd file handle */
+ SvIV_set(stream, (IV)fil) ;
+
--- /dev/null
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+Format: 1.0
+Source: libfilter-perl
+Binary: libfilter-perl
+Architecture: any
+Version: 1.34-1
+Maintainer: Colin Watson <cjwatson@debian.org>
+Homepage: http://www.cpan.org/modules/by-module/Filter/
+Standards-Version: 3.7.3
+Build-Depends: debhelper (>= 4.0.0), perl (>= 5.8.0-3)
+Files:
+ 49606303d20b90f07d697220272bf59a 40756 libfilter-perl_1.34.orig.tar.gz
+ 4ec7cbfd940c73269ea3f95631a273c1 3714 libfilter-perl_1.34-1.diff.gz
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.6 (GNU/Linux)
+Comment: Colin Watson <cjwatson@debian.org> -- Debian developer
+
+iD8DBQFHvUJo9t0zAhD6TNERAuJaAJ4pRsyefu55LOYBwjVGjhxw7L1+PACcCAPY
+YzF09Hf9s9fFieGiEoJqmlk=
+=QGNe
+-----END PGP SIGNATURE-----
--- /dev/null
+Format: 1.0
+Source: libfilter-perl
+Version: 1.34-1maemo1
+Binary: libfilter-perl
+Maintainer: Colin Watson <cjwatson@debian.org>
+Architecture: any
+Standards-Version: 3.7.3
+Build-Depends: debhelper (>= 4.0.0), perl (>= 5.8.0-3)
+Files:
+ 49606303d20b90f07d697220272bf59a 40756 libfilter-perl_1.34.orig.tar.gz
+ b9011f11e2d873d4ed358b7b272339bc 3794 libfilter-perl_1.34-1maemo1.diff.gz
--- /dev/null
+Format: 1.7
+Date: Wed, 14 Apr 2010 07:27:21 +0100
+Source: libfilter-perl
+Binary: libfilter-perl
+Architecture: source armel
+Version: 1.34-1maemo1
+Distribution: fremantle
+Urgency: low
+Maintainer: Colin Watson <cjwatson@debian.org>
+Changed-By: Nito Martinez <Nito@Qindel.ES>
+Description:
+ libfilter-perl - Perl source filters
+Changes:
+ libfilter-perl (1.34-1maemo1) fremantle; urgency=low
+ .
+ * New Maemo packaging
+Files:
+ d955462ed8b935d2552df5eca63e5f14 380 perl optional libfilter-perl_1.34-1maemo1.dsc
+ b9011f11e2d873d4ed358b7b272339bc 3794 perl optional libfilter-perl_1.34-1maemo1.diff.gz
+ 8c41866bd43f754328fdf57ad3f89abb 71078 perl optional libfilter-perl_1.34-1maemo1_armel.deb
--- /dev/null
+---
+version: 0.30
+date: Sun Jan 29 12:18:02 PST 2006
+changes:
+- Use faster runtime code in `field`.
+---
+version: 0.29
+date: Thu Jan 19 08:12:06 PST 2006
+changes:
+- Squelch redefine warnings
+---
+version: 0.28
+date: Thu Jan 19 07:39:30 PST 2006
+changes:
+- Test patch from Nicholas for older perls
+---
+version: 0.27
+date: Wed Jan 18 14:14:52 PST 2006
+changes:
+- The check to make sure Spiffy is loaded before 'base' was flawed.
+ Added new tests, and commented out the flawed code until I can figure
+ out how to do the check properly. The check is just a helper so it
+ shouldn't hurt not to have it.
+---
+version: 0.26
+date: Sat Jan 14 05:41:05 PST 2006
+changes:
+- Don't sign the distribution tarball
+---
+version: 0.25
+date: Mon Jan 9 20:35:39 PST 2006
+changes:
+- Make Spiffy modules play nice with autouse
+---
+version: 0.24
+date: Sat Apr 30 23:12:28 PDT 2005
+changes:
+- Refactored -Base to once and only once
+- Remove some cruft
+- Got export algorithm working better
+---
+version: 0.23
+date: Sun Apr 17 19:01:11 PDT 2005
+changes:
+- Add a blank return to super
+- Add the mixin method
+---
+version: 0.22
+date: Tue Jan 11 07:22:47 PST 2005
+changes:
+- allow new() to be called from object reference
+- make -weak and -init work together
+- add tests for -Base filtering
+---
+version: 0.21
+date: Wed Dec 15 04:40:46 PST 2004
+changes:
+- Get rid of spiffy_constructor altogether
+- Don't use goto in super() anymore, due to irreversible changes in perl 5.8.6
+- Generate custom fields base on input. The field function returns the
+ generated code for debugging puposes. (Dave Rolsky)
+- field supports -weaken and -init flags.
+- Caching in all_my_bases to speed things up. (Chris Dent)
+- Filtering now does strict/warnings, '1;\n', and private subs defined with
+ 'my sub ...'.
+- Add -filter_dump and -filter_save options for filter debugging
+---
+version: 0.20
+date: Sat Jul 24 22:11:48 PDT 2004
+changes:
+- call super from eval
+- -XXX implies :XXX
+---
+version: 0.19
+date: Sun Jul 11 01:41:38 PDT 2004
+changes:
+- mixin support
+- don't export spiffy_constructor by default
+- Don't export XXX stuff until -XXX used
+- add support for roles and import lists with mixins
+- super works with AUTOLOAD
+---
+version: 0.18
+date: Wed Jun 2 15:05:05 PDT 2004
+changes:
+- Allow 'use base' to work with Spiffy and non-Spiffy
+- Allow DATA filehandle to work with source filtering
+- Support @EXPORT_BASE
+---
+version: 0.17
+date: Tue May 11 17:09:00 PDT 2004
+changes:
+- Don't filter a file twice.
+- Make super nestable.
+- Data::Dumper support
+---
+version: 0.16
+date: Fri May 7 00:57:06 PDT 2004
+changes:
+- Added filtering
+- fixed super
+- overhauled documentation
+---
+version: 0.15
+date: Sun Mar 21 01:54:07 PST 2004
+changes:
+- Make parse_arguments work in scalar context
+---
+version: 0.14
+date: Sun Mar 21 01:54:07 PST 2004
+changes:
+- add support for field and const
+- field -package Foo 'field1';
+---
+version: 0.13
+date: Sat Mar 13 09:13:01 PST 2004
+changes:
+- Works with base.pm
+---
+version: 0.12
+date: Mon Mar 8 11:34:57 PST 2004
+changes:
+- Foo::Bar->base;
+---
+version: 0.11
+date: Tue Mar 2 09:16:30 PST 2004
+changes:
+- Add super powers
+---
+version: 0.11
+date: Thu Feb 12 21:36:13 CST 2004
+changes:
+- Use Exporter to export things
--- /dev/null
+Changes
+inc/Module/Install.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/Spiffy.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/autoload.t
+t/base.t
+t/base2.t
+t/cascade.t
+t/const.t
+t/early.t
+t/export1.t
+t/export2.t
+t/export3.t
+t/export4.t
+t/export5.t
+t/export6.t
+t/export7.t
+t/exporter.t
+t/field.t
+t/field2.t
+t/field3.t
+t/filter.t
+t/filter2.t
+t/filter3.t
+t/Filter4.pm
+t/filter4.t
+t/Filter5.pm
+t/filter5.t
+t/mixin.t
+t/mixin2.t
+t/mixin3.t
+t/new.t
+t/NonSpiffy.pm
+t/package.t
+t/parse.t
+t/Something.pm
+t/stub.t
+t/super.t
+t/super2.t
+t/Thing.pm
--- /dev/null
+
+no_index:
+ directory:
+ - inc
+ - t
+generated_by: Module::Install version 0.54
+distribution_type: module
+version: 0.25
+name: Spiffy
+author: "Ingy d\xC3\xB6t Net <ingy@cpan.org>"
+license: perl
+requires:
+ Scalar::Util: 0
+ perl: 5.6.1
+ Filter::Util::Call: 0
+abstract: Spiffy Perl Interface Framework For You
--- /dev/null
+use inc::Module::Install;
+
+name 'Spiffy';
+all_from 'lib/Spiffy.pm';
+
+requires perl => '5.6.1';
+requires Filter::Util::Call => '0';
+requires Scalar::Util => '0';
+
+WriteAll;
--- /dev/null
+NAME
+ Spiffy - Spiffy Perl Interface Framework For You
+
+SYNOPSIS
+ package Keen;
+ use Spiffy -Base;
+ field 'mirth';
+ const mood => ':-)';
+
+ sub happy {
+ if ($self->mood eq ':-(') {
+ $self->mirth(-1);
+ print "Cheer up!";
+ }
+ super;
+ }
+
+DESCRIPTION
+ "Spiffy" is a framework and methodology for doing object oriented (OO)
+ programming in Perl. Spiffy combines the best parts of Exporter.pm,
+ base.pm, mixin.pm and SUPER.pm into one magic foundation class. It
+ attempts to fix all the nits and warts of traditional Perl OO, in a
+ clean, straightforward and (perhaps someday) standard way.
+
+ Spiffy borrows ideas from other OO languages like Python, Ruby, Java and
+ Perl 6. It also adds a few tricks of its own.
+
+ If you take a look on CPAN, there are a ton of OO related modules. When
+ starting a new project, you need to pick the set of modules that makes
+ most sense, and then you need to use those modules in each of your
+ classes. Spiffy, on the other hand, has everything you'll probably need
+ in one module, and you only need to use it once in one of your classes.
+ If you make Spiffy.pm the base class of the basest class in your
+ project, Spiffy will automatically pass all of its magic to all of your
+ subclasses. You may eventually forget that you're even using it!
+
+ The most striking difference between Spiffy and other Perl object
+ oriented base classes, is that it has the ability to export things. If
+ you create a subclass of Spiffy, all the things that Spiffy exports will
+ automatically be exported by your subclass, in addition to any more
+ things that you want to export. And if someone creates a subclass of
+ your subclass, all of those things will be exported automatically, and
+ so on. Think of it as "Inherited Exportation", and it uses the familiar
+ Exporter.pm specification syntax.
+
+ To use Spiffy or any subclass of Spiffy as a base class of your class,
+ you specify the "-base" argument to the "use" command.
+
+ use MySpiffyBaseModule -base;
+
+ You can also use the traditional "use base 'MySpiffyBaseModule';" syntax
+ and everything will work exactly the same. The only caveat is that
+ Spiffy.pm must already be loaded. That's because Spiffy rewires base.pm
+ on the fly to do all the Spiffy magics.
+
+ Spiffy has support for Ruby-like mixins with Perl6-like roles. Just like
+ "base" you can use either of the following invocations:
+
+ use mixin 'MySpiffyBaseModule';
+ use MySpiffyBaseModule -mixin;
+
+ The second version will only work if the class being mixed in is a
+ subclass of Spiffy. The first version will work in all cases, as long as
+ Spiffy has already been loaded.
+
+ To limit the methods that get mixed in, use roles. (Hint: they work just
+ like an Exporter list):
+
+ use MySpiffyBaseModule -mixin => qw(:basics x y !foo);
+
+ In object oriented Perl almost every subroutine is a method. Each method
+ gets the object passed to it as its first argument. That means
+ practically every subroutine starts with the line:
+
+ my $self = shift;
+
+ Spiffy provides a simple, optional filter mechanism to insert that line
+ for you, resulting in cleaner code. If you figure an average method has
+ 10 lines of code, that's 10% of your code! To turn this option on, you
+ just use the "-Base" option instead of the "-base" option, or add the
+ "-selfless" option. If source filtering makes you queazy, don't use the
+ feature. I personally find it addictive in my quest for writing squeaky
+ clean, maintainable code.
+
+ A useful feature of Spiffy is that it exports two functions: "field" and
+ "const" that can be used to declare the attributes of your class, and
+ automatically generate accessor methods for them. The only difference
+ between the two functions is that "const" attributes can not be
+ modified; thus the accessor is much faster.
+
+ One interesting aspect of OO programming is when a method calls the same
+ method from a parent class. This is generally known as calling a super
+ method. Perl's facility for doing this is butt ugly:
+
+ sub cleanup {
+ my $self = shift;
+ $self->scrub;
+ $self->SUPER::cleanup(@_);
+ }
+
+ Spiffy makes it, er, super easy to call super methods. You just use the
+ "super" function. You don't need to pass it any arguments because it
+ automatically passes them on for you. Here's the same function with
+ Spiffy:
+
+ sub cleanup {
+ $self->scrub;
+ super;
+ }
+
+ Spiffy has a special method for parsing arguments called
+ "parse_arguments", that it also uses for parsing its own arguments. You
+ declare which arguments are boolean (singletons) and which ones are
+ paired, with two special methods called "boolean_arguments" and
+ "paired_arguments". Parse arguments pulls out the booleans and pairs and
+ returns them in an anonymous hash, followed by a list of the unmatched
+ arguments.
+
+ Finally, Spiffy can export a few debugging functions "WWW", "XXX", "YYY"
+ and "ZZZ". Each of them produces a YAML dump of its arguments. WWW warns
+ the output, XXX dies with the output, YYY prints the output, and ZZZ
+ confesses the output. If YAML doesn't suit your needs, you can switch
+ all the dumps to Data::Dumper format with the "-dumper" option.
+
+ That's Spiffy!
+
+Spiffy EXPORTING
+ Spiffy implements a completely new idea in Perl. Modules that act both
+ as object oriented classes and that also export functions. But it takes
+ the concept of Exporter.pm one step further; it walks the entire @ISA
+ path of a class and honors the export specifications of each module.
+ Since Spiffy calls on the Exporter module to do this, you can use all
+ the fancy interface features that Exporter has, including tags and
+ negation.
+
+ Spiffy considers all the arguments that don't begin with a dash to
+ comprise the export specification.
+
+ package Vehicle;
+ use Spiffy -base;
+ our $SERIAL_NUMBER = 0;
+ our @EXPORT = qw($SERIAL_NUMBER);
+ our @EXPORT_BASE = qw(tire horn);
+
+ package Bicycle;
+ use Vehicle -base, '!field';
+ $self->inflate(tire);
+
+ In this case, "Bicycle-"isa('Vehicle')> and also all the things that
+ "Vehicle" and "Spiffy" export, will go into "Bicycle", except "field".
+
+ Exporting can be very helpful when you've designed a system with
+ hundreds of classes, and you want them all to have access to some
+ functions or constants or variables. Just export them in your main base
+ class and every subclass will get the functions they need.
+
+ You can do almost everything that Exporter does because Spiffy delegates
+ the job to Exporter (after adding some Spiffy magic). Spiffy offers a
+ @EXPORT_BASE variable which is like @EXPORT, but only for usages that
+ use "-base".
+
+Spiffy MIXINs & ROLEs
+ If you've done much OO programming in Perl you've probably used Multiple
+ Inheritance (MI), and if you've done much MI you've probably run into
+ weird problems and headaches. Some languages like Ruby, attempt to
+ resolve MI issues using a technique called mixins. Basically, all Ruby
+ classes use only Single Inheritance (SI), and then *mixin* functionality
+ from other modules if they need to.
+
+ Mixins can be thought of at a simplistic level as *importing* the
+ methods of another class into your subclass. But from an implementation
+ standpoint that's not the best way to do it. Spiffy does what Ruby does.
+ It creates an empty anonymous class, imports everything into that class,
+ and then chains the new class into your SI ISA path. In other words, if
+ you say:
+
+ package A;
+ use B -base;
+ use C -mixin;
+ use D -mixin;
+
+ You end up with a single inheritance chain of classes like this:
+
+ A << A-D << A-C << B;
+
+ "A-D" and "A-C" are the actual package names of the generated classes.
+ The nice thing about this style is that mixing in C doesn't clobber any
+ methods in A, and D doesn't conflict with A or C either. If you mixed in
+ a method in C that was also in A, you can still get to it by using
+ "super".
+
+ When Spiffy mixes in C, it pulls in all the methods in C that do not
+ begin with an underscore. Actually it goes farther than that. If C is a
+ subclass it will pull in every method that C "can" do through
+ inheritance. This is very powerful, maybe too powerful.
+
+ To limit what you mixin, Spiffy borrows the concept of Roles from Perl6.
+ The term role is used more loosely in Spiffy though. It's much like an
+ import list that the Exporter module uses, and you can use groups (tags)
+ and negation. If the first element of your list uses negation, Spiffy
+ will start with all the methods that your mixin class can do.
+
+ use E -mixin => qw(:tools walk !run !:sharp_tools);
+
+ In this example, "walk" and "run" are methods that E can do, and "tools"
+ and "sharp_tools" are roles of class E. How does class E define these
+ roles? It very simply defines methods called "_role_tools" and
+ "_role_sharp_tools" which return lists of more methods. (And possibly
+ other roles!) The neat thing here is that since roles are just methods,
+ they too can be inherited. Take that Perl6!
+
+Spiffy FILTERING
+ By using the "-Base" flag instead of "-base" you never need to write the
+ line:
+
+ my $self = shift;
+
+ This statement is added to every subroutine in your class by using a
+ source filter. The magic is simple and fast, so there is litte
+ performance penalty for creating clean code on par with Ruby and Python.
+
+ package Example;
+ use Spiffy -Base;
+
+ sub crazy {
+ $self->nuts;
+ }
+ sub wacky { }
+ sub new() {
+ bless [], shift;
+ }
+
+ is exactly the same as:
+
+ package Example;
+ use Spiffy -base;
+ use strict;use warnings;
+ sub crazy {my $self = shift;
+ $self->nuts;
+ }
+ sub wacky {my $self = shift; }
+ sub new {
+ bless [], shift;
+ }
+ ;1;
+
+ Note that the empty parens after the subroutine "new" keep it from
+ having a $self added. Also note that the extra code is added to existing
+ lines to ensure that line numbers are not altered.
+
+ "-Base" also turns on the strict and warnings pragmas, and adds that
+ annoying '1;' line to your module.
+
+PRIVATE METHODS
+ Spiffy now has support for private methods when you use the '-Base'
+ filter mechanism. You just declare the subs with the "my" keyword, and
+ call them with a '$' in front. Like this:
+
+ package Keen;
+ use SomethingSpiffy -Base;
+
+ # normal public method
+ sub swell {
+ $self->$stinky;
+ }
+
+ # private lexical method. uncallable from outside this file.
+ my sub stinky {
+ ...
+ }
+
+Spiffy DEBUGGING
+ The XXX function is very handy for debugging because you can insert it
+ almost anywhere, and it will dump your data in nice clean YAML. Take the
+ following statement:
+
+ my @stuff = grep { /keen/ } $self->find($a, $b);
+
+ If you have a problem with this statement, you can debug it in any of
+ the following ways:
+
+ XXX my @stuff = grep { /keen/ } $self->find($a, $b);
+ my @stuff = XXX grep { /keen/ } $self->find($a, $b);
+ my @stuff = grep { /keen/ } XXX $self->find($a, $b);
+ my @stuff = grep { /keen/ } $self->find(XXX $a, $b);
+
+ XXX is easy to insert and remove. It is also a tradition to mark
+ uncertain areas of code with XXX. This will make the debugging dumpers
+ easy to spot if you forget to take them out.
+
+ WWW and YYY are nice because they dump their arguments and then return
+ the arguments. This way you can insert them into many places and still
+ have the code run as before. Use ZZZ when you need to die with both a
+ YAML dump and a full stack trace.
+
+ The debugging functions are exported by default if you use the "-base"
+ option, but only if you have previously used the "-XXX" option. To
+ export all 4 functions use the export tag:
+
+ use SomeSpiffyModule ':XXX';
+
+ To force the debugging functions to use Data::Dumper instead of YAML:
+
+ use SomeSpiffyModule -dumper;
+
+Spiffy FUNCTIONS
+ This section describes the functions the Spiffy exports. The "field",
+ "const", "stub" and "super" functions are only exported when you use the
+ "-base" or "-Base" options.
+
+ * field
+ Defines accessor methods for a field of your class:
+
+ package Example;
+ use Spiffy -Base;
+
+ field 'foo';
+ field bar => [];
+
+ sub lalala {
+ $self->foo(42);
+ push @{$self->{bar}}, $self->foo;
+ }
+
+ The first parameter passed to "field" is the name of the attribute
+ being defined. Accessors can be given an optional default value.
+ This value will be returned if no value for the field has been set
+ in the object.
+
+ * const
+ const bar => 42;
+
+ The "const" function is similar to <field> except that it is
+ immutable. It also does not store data in the object. You probably
+ always want to give a "const" a default value, otherwise the
+ generated method will be somewhat useless.
+
+ * stub
+ stub 'cigar';
+
+ The "stub" function generates a method that will die with an
+ appropriate message. The idea is that subclasses must implement
+ these methods so that the stub methods don't get called.
+
+ * super
+ If this function is called without any arguments, it will call the
+ same method that it is in, higher up in the ISA tree, passing it all
+ the same arguments. If it is called with arguments, it will use
+ those arguments with $self in the front. In other words, it just
+ works like you'd expect.
+
+ sub foo {
+ super; # Same as $self->SUPER::foo(@_);
+ super('hello'); # Same as $self->SUPER::foo('hello');
+ $self->bar(42);
+ }
+
+ sub new() {
+ my $self = super;
+ $self->init;
+ return $self;
+ }
+
+ "super" will simply do nothing if there is no super method. Finally,
+ "super" does the right thing in AUTOLOAD subroutines.
+
+Spiffy METHODS
+ This section lists all of the methods that any subclass of Spiffy
+ automatically inherits.
+
+ * mixin
+ A method to mixin a class at runtime. Takes the same arguments as
+ "use mixin ...". Makes the target class a mixin of the caller.
+
+ $self->mixin('SomeClass');
+ $object->mixin('SomeOtherClass' => 'some_method');
+
+ * parse_arguments
+ This method takes a list of arguments and groups them into pairs. It
+ allows for boolean arguments which may or may not have a value
+ (defaulting to 1). The method returns a hash reference of all the
+ pairs as keys and values in the hash. Any arguments that cannot be
+ paired, are returned as a list. Here is an example:
+
+ sub boolean_arguments { qw(-has_spots -is_yummy) }
+ sub paired_arguments { qw(-name -size) }
+ my ($pairs, @others) = $self->parse_arguments(
+ 'red', 'white',
+ -name => 'Ingy',
+ -has_spots =>
+ -size => 'large',
+ 'black',
+ -is_yummy => 0,
+ );
+
+ After this call, $pairs will contain:
+
+ {
+ -name => 'Ingy',
+ -has_spots => 1,
+ -size => 'large',
+ -is_yummy => 0,
+ }
+
+ and @others will contain 'red', 'white', and 'black'.
+
+ * boolean_arguments
+ Returns the list of arguments that are recognized as being boolean.
+ Override this method to define your own list.
+
+ * paired_arguments
+ Returns the list of arguments that are recognized as being paired.
+ Override this method to define your own list.
+
+Spiffy ARGUMENTS
+ When you "use" the Spiffy module or a subclass of it, you can pass it a
+ list of arguments. These arguments are parsed using the
+ "parse_arguments" method described above. The special argument "-base",
+ is used to make the current package a subclass of the Spiffy module
+ being used.
+
+ Any non-paired parameters act like a normal import list; just like those
+ used with the Exporter module.
+
+USING Spiffy WITH base.pm
+ The proper way to use a Spiffy module as a base class is with the
+ "-base" parameter to the "use" statement. This differs from typical
+ modules where you would want to "use base".
+
+ package Something;
+ use Spiffy::Module -base;
+ use base 'NonSpiffy::Module';
+
+ Now it may be hard to keep track of what's Spiffy and what is not.
+ Therefore Spiffy has actually been made to work with base.pm. You can
+ say:
+
+ package Something;
+ use base 'Spiffy::Module';
+ use base 'NonSpiffy::Module';
+
+ "use base" is also very useful when your class is not an actual module
+ (a separate file) but just a package in some file that has already been
+ loaded. "base" will work whether the class is a module or not, while the
+ "-base" syntax cannot work that way, since "use" always tries to load a
+ module.
+
+ base.pm Caveats
+ To make Spiffy work with base.pm, a dirty trick was played. Spiffy swaps
+ "base::import" with its own version. If the base modules are not Spiffy,
+ Spiffy calls the original base::import. If the base modules are Spiffy,
+ then Spiffy does its own thing.
+
+ There are two caveats.
+
+ * Spiffy must be loaded first.
+ If Spiffy is not loaded and "use base" is invoked on a Spiffy
+ module, Spiffy will die with a useful message telling the author to
+ read this documentation. That's because Spiffy needed to do the
+ import swap beforehand.
+
+ If you get this error, simply put a statement like this up front in
+ your code:
+
+ use Spiffy ();
+
+ * No Mixing
+ "base.pm" can take multiple arguments. And this works with Spiffy as
+ long as all the base classes are Spiffy, or they are all non-Spiffy.
+ If they are mixed, Spiffy will die. In this case just use separate
+ "use base" statements.
+
+Spiffy TODO LIST
+ Spiffy is a wonderful way to do OO programming in Perl, but it is still
+ a work in progress. New things will be added, and things that don't work
+ well, might be removed.
+
+AUTHOR
+ Ingy döt Net <ingy@cpan.org>
+
+COPYRIGHT
+ Copyright (c) 2006. Ingy döt Net. All rights reserved. Copyright (c)
+ 2004. Brian Ingerson. All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+ See <http://www.perl.com/perl/misc/Artistic.html>
+
--- /dev/null
+libspiffy-perl (0.30-1maemo1) fremantle; urgency=low
+
+ * New Maemo packaging
+
+ -- Nito Martinez <Nito@Qindel.ES> Wed, 14 Apr 2010 07:08:42 +0100
+
+
+llibspiffy-perl (0.30-1) unstable; urgency=low
+
+ * Take over for the Debian Perl Group with maintainer's permission
+ (http://lists.debian.org/debian-perl/2008/06/msg00039.html)
+ * debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser
+ field (source stanza); Homepage field (source stanza). Changed:
+ Maintainer set to Debian Perl Group <pkg-perl-
+ maintainers@lists.alioth.debian.org> (was: Florian Ragwitz
+ <rafl@debian.org>); Florian Ragwitz <rafl@debian.org> moved to
+ Uploaders.
+ * Add debian/watch.
+
+ * New upstream release.
+ * debian/copyright: add upstream source location; copy author/copyright
+ information verbatim from upstream README.
+ * Add /me to Uploaders.
+ * Set Standards-Version to 3.8.0 (no changes).
+ * Set debhelper compatibility level to 5.
+ * Refresh debian/rules, no functional changes. Don't install README (text
+ version of the POD documentation).
+ * Convert broken odieresis chars in manpage (that come from UTF-8 encoded
+ module) to plain old *roff sequence (closes: #441828).
+
+ -- gregor herrmann <gregoa@debian.org> Tue, 17 Jun 2008 18:14:05 +0200
+
+libspiffy-perl (0.29-1.1) unstable; urgency=low
+
+ * Non-maintainer upload.
+ * debian/rules: Don't FTBFS when perl is smart enough not to create
+ empty dirs. (Closes: #467959)
+
+ -- Marc 'HE' Brockschmidt <he@debian.org> Sat, 05 Apr 2008 19:08:56 +0200
+
+libspiffy-perl (0.29-1) unstable; urgency=low
+
+ * New maintainer with acknowledgement from the old maintainer.
+ * New upstream release (Closes: #328431).
+ * Cleaned up debian/rules a bit.
+ * Enabled tests.
+ * Bumped up Standards-Version.
+
+ -- Florian Ragwitz <rafl@debian.org> Tue, 24 Jan 2006 08:37:19 +0100
+
+libspiffy-perl (0.21-1) unstable; urgency=low
+
+ * Initial Release.
+
+ -- Nick Phillips <nwp@debian.org> Fri, 17 Dec 2004 20:38:09 +1300
+
--- /dev/null
+Source: libspiffy-perl
+Section: perl
+Priority: optional
+Build-Depends: debhelper (>= 5)
+Build-Depends-Indep: perl (>= 5.8.0-7)
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: Florian Ragwitz <rafl@debian.org>,
+ gregor herrmann <gregoa@debian.org>
+Standards-Version: 3.8.0
+Homepage: http://search.cpan.org/dist/Spiffy/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libspiffy-perl/
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libspiffy-perl/
+
+Package: libspiffy-perl
+Architecture: all
+Depends: ${perl:Depends}, ${misc:Depends}, libfilter-perl, libscalar-list-utils-perl
+Description: Spiffy Perl Interface Framework For You
+ "Spiffy" is a framework and methodology for doing object oriented (OO)
+ programming in Perl. Spiffy combines the best parts of Exporter.pm,
+ base.pm, mixin.pm and SUPER.pm into one magic foundation class. It
+ attempts to fix all the nits and warts of traditional Perl OO, in a
+ clean, straightforward and (perhaps someday) standard way.
+ .
+ Spiffy borrows ideas from other OO languages like Python, Ruby,
+ Java and Perl 6. It also adds a few tricks of its own.
+ .
+ If you take a look on CPAN, there are a ton of OO related modules. When
+ starting a new project, you need to pick the set of modules that makes
+ most sense, and then you need to use those modules in each of your
+ classes. Spiffy, on the other hand, has everything you'll probably need
+ in one module, and you only need to use it once in one of your classes.
+ If you make Spiffy.pm the base class of the basest class in your
+ project, Spiffy will automatically pass all of its magic to all of your
+ subclasses. You may eventually forget that you're even using it!
--- /dev/null
+This is the debian package for the Spiffy module.
+It was created by Nick Phillips <nwp@debian.org> with help from
+dh-make-perl.
+
+Upstream source location: http://search.cpan.org/dist/Spiffy/
+
+AUTHOR
+ Ingy döt Net <ingy@cpan.org>
+
+COPYRIGHT
+ Copyright (c) 2006. Ingy döt Net. All rights reserved. Copyright (c)
+ 2004. Brian Ingerson. All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+Perl is distributed under your choice of the GNU General Public License or
+the Artistic License. On Debian GNU/Linux systems, the complete text of the
+GNU General Public License can be found in `/usr/share/common-licenses/GPL'
+and the Artistic Licence in `/usr/share/common-licenses/Artistic'.
--- /dev/null
+#!/usr/bin/make -f
+# This debian/rules file is provided as a template for normal perl
+# packages. It was created by Marc Brockschmidt <marc@dch-faq.de> for
+# the Debian Perl Group (http://pkg-perl.alioth.debian.org/) but may
+# be used freely wherever it is useful.
+
+# Uncomment this to turn on verbose mode.
+#export DH_VERBOSE=1
+
+# If set to a true value then MakeMaker's prompt function will
+# always return the default without waiting for user input.
+export PERL_MM_USE_DEFAULT=1
+
+PERL ?= /usr/bin/perl
+PACKAGE = $(shell dh_listpackages)
+TMP = $(CURDIR)/debian/$(PACKAGE)
+
+build: build-stamp
+build-stamp:
+ dh_testdir
+ $(PERL) Makefile.PL INSTALLDIRS=vendor
+ $(MAKE)
+ $(MAKE) test
+ touch $@
+
+clean:
+ dh_testdir
+ dh_testroot
+ dh_clean build-stamp install-stamp
+ [ ! -f Makefile ] || $(MAKE) realclean
+
+install: install-stamp
+install-stamp: build-stamp
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ $(MAKE) install DESTDIR=$(TMP) PREFIX=/usr
+
+ # convert broken *roff from UTF-8 encoded modules
+ sed -i -e 's/A\\\*~X/\\\[:o\]/' $(TMP)/usr/share/man/man3/Spiffy.3pm
+
+ [ ! -d $(TMP)/usr/lib/perl5 ] || \
+ rmdir --ignore-fail-on-non-empty --parents --verbose \
+ $(TMP)/usr/lib/perl5
+ touch $@
+
+binary-arch:
+# We have nothing to do here for an architecture-independent package
+
+binary-indep: build install
+ dh_testdir
+ dh_testroot
+ dh_installdocs
+ dh_installchangelogs Changes
+ dh_perl
+ dh_compress
+ dh_fixperms
+ dh_installdeb
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install
--- /dev/null
+version=3
+http://search.cpan.org/dist/Spiffy/ .+/Spiffy-v?(\d[\d_.-]+)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)$
--- /dev/null
+#line 1 "/Users/ingy/src/ingy/Spiffy/inc/Module/Install.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install.pm"
+package Module::Install;
+
+use 5.004;
+use strict 'vars';
+use vars qw{$VERSION};
+BEGIN {
+ # Don't forget to update Module::Install::Admin too!
+ $VERSION = '0.54';
+}
+
+# inc::Module::Install must be loaded first
+unless ( $INC{join('/', inc => split(/::/, __PACKAGE__)).'.pm'} ) {
+ die <<"END_DIE";
+Please invoke ${\__PACKAGE__} with:
+
+ use inc::${\__PACKAGE__};
+
+not:
+
+ use ${\__PACKAGE__};
+
+END_DIE
+}
+
+use Cwd ();
+use FindBin;
+use File::Find ();
+use File::Path ();
+
+*inc::Module::Install::VERSION = *VERSION;
+@inc::Module::Install::ISA = 'Module::Install';
+
+sub autoload {
+ my $self = shift;
+ my $caller = $self->_caller;
+ my $cwd = Cwd::cwd();
+ my $sym = "$caller\::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 $caller - $sym";
+ unshift @_, ($self, $1);
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
+}
+
+sub import {
+ my $class = shift;
+ my $self = $class->new(@_);
+
+ 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"};
+ }
+
+ *{$self->_caller . "::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"};
+}
+
+sub preload {
+ my ($self) = @_;
+
+ unless ( $self->{extentions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $admin->load_all_extensions;
+ }
+
+ my %seen_method;
+ foreach my $obj ( @exts ) {
+ while (my ($method, $glob) = each %{ref($obj) . '::'}) {
+ next unless defined *{$glob}{CODE};
+ next if $method =~ /^_/;
+ next if $method eq uc($method);
+ $seen_method{$method}++;
+ }
+ }
+
+ my $caller = $self->_caller;
+ foreach my $name (sort keys %seen_method) {
+ *{"${caller}::$name"} = sub {
+ ${"${caller}::AUTOLOAD"} = "${caller}::$name";
+ goto &{"${caller}::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} ||= '.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";
+
+ bless(\%args, $class);
+}
+
+sub call {
+ my $self = shift;
+ my $method = shift;
+ my $obj = $self->load($method) or return;
+
+ unshift @_, $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_obj) = @_;
+
+ unshift @INC, $self->{prefix}
+ unless grep { $_ eq $self->{prefix} } @INC;
+
+ local @INC = ($path, @INC);
+ 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_obj );
+ }
+
+ $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;
+ return if $1 eq $self->{dispatch};
+
+ $file = "$self->{path}/$1.pm";
+ my $pkg = "$self->{name}::$1"; $pkg =~ s!/!::!g;
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+sub _caller {
+ my $depth = 0;
+ my $caller = caller($depth);
+
+ while ($caller eq __PACKAGE__) {
+ $depth++;
+ $caller = caller($depth);
+ }
+
+ $caller;
+}
+
+1;
--- /dev/null
+#line 1 "inc/Module/Install/Base.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Base.pm"
+package Module::Install::Base;
+
+# Suspend handler for "redefined" warnings
+BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w } };
+
+#line 30
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method (qw(call load)) {
+ *{"$class\::$method"} = sub {
+ +shift->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless(\%args, $class);
+}
+
+#line 48
+
+sub AUTOLOAD {
+ my $self = shift;
+
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 62
+
+sub _top { $_[0]->{_top} }
+
+#line 73
+
+sub admin {
+ my $self = shift;
+ $self->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+sub is_admin {
+ my $self = shift;
+ $self->admin->VERSION;
+}
+
+sub DESTROY {}
+
+package Module::Install::Base::FakeAdmin;
+
+my $Fake;
+sub new { $Fake ||= bless(\@_, $_[0]) }
+sub AUTOLOAD {}
+sub DESTROY {}
+
+1;
+
+# Restore warning handler
+BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->() };
+
+__END__
+
+#line 120
--- /dev/null
+#line 1 "inc/Module/Install/Can.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Can.pm"
+package Module::Install::Can;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+$VERSION = '0.01';
+
+use strict;
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+# check if we can load some module
+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}), '.') {
+ my $abs = File::Spec->catfile($dir, $_[1]);
+ return $abs if (-x $abs or $abs = MM->maybe_command($abs));
+ }
+
+ return;
+}
+
+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;
--- /dev/null
+#line 1 "inc/Module/Install/Fetch.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Fetch.pm"
+package Module::Install::Fetch;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$VERSION = '0.01';
+
+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/, << ".");
+open $host
+user anonymous anonymous\@example.com
+cd $path
+binary
+get $file $file
+quit
+.
+ 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;
--- /dev/null
+#line 1 "inc/Module/Install/Makefile.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Makefile.pm"
+package Module::Install::Makefile;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$VERSION = '0.01';
+
+use strict 'vars';
+use vars '$VERSION';
+
+use ExtUtils::MakeMaker ();
+
+sub Makefile { $_[0] }
+
+sub prompt {
+ shift;
+ goto &ExtUtils::MakeMaker::prompt;
+}
+
+sub makemaker_args {
+ my $self = shift;
+ my $args = ($self->{makemaker_args} ||= {});
+ %$args = ( %$args, @_ ) if @_;
+ $args;
+}
+
+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 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 );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ my $args = $self->makemaker_args;
+
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $args->{NAME} =~ s/-/::/g;
+
+ $args->{test} = {TESTS => $self->tests} if $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 ) {
+ $args->{SIGN} = 1 if $self->sign;
+ }
+ delete $args->{SIGN} unless $self->is_admin;
+
+ # merge both kinds of requires into prereq_pm
+ my $prereq = ($args->{PREREQ_PM} ||= {});
+ %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_,
+ ($self->build_requires, $self->requires) );
+
+ # 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";
+ }
+
+ my %args = map {($_ => $args->{$_})} grep {defined($args->{$_})} keys %$args;
+
+ if ($self->admin->preop) {
+ $args{dist} = $self->admin->preop;
+ }
+
+ ExtUtils::MakeMaker::WriteMakefile(%args);
+
+ $self->fix_up_makefile();
+}
+
+sub fix_up_makefile {
+ my $self = 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' or die $!;
+ my $makefile = do { local $/; <MAKEFILE> };
+ close MAKEFILE;
+
+ $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;
+
+ open MAKEFILE, '> Makefile' or die $!;
+ print MAKEFILE "$preamble$makefile$postamble";
+ close MAKEFILE;
+}
+
+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 286
--- /dev/null
+#line 1 "inc/Module/Install/Metadata.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Metadata.pm"
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw($VERSION @ISA);
+BEGIN {
+ $VERSION = '0.06';
+ @ISA = 'Module::Install::Base';
+}
+
+my @scalar_keys = qw{
+ name module_name abstract author version license
+ distribution_type perl_version tests
+};
+
+my @tuple_keys = qw{
+ build_requires requires recommends bundles
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+
+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 (@tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} unless @_;
+
+ my @rv;
+ while (@_) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ if ( $module eq 'perl' ) {
+ $version =~ s{^(\d+)\.(\d+)\.(\d+)}
+ {$1 + $2/1_000 + $3/1_000_000}e;
+ $self->perl_version($version);
+ next;
+ }
+ my $rv = [ $module, $version ];
+ push @rv, $rv;
+ }
+ push @{ $self->{values}{$key} }, @rv;
+ @rv;
+ };
+}
+
+sub sign {
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and !@_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+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;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+
+ # The remaining probes read from POD sections; if the file
+ # has an accompanying .pod, use that instead
+ my $pod = $file;
+ if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+ $file = $pod;
+ }
+
+ $self->author_from($file) unless $self->author;
+ $self->license_from($file) unless $self->license;
+ $self->abstract_from($file) unless $self->abstract;
+}
+
+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} };
+}
+
+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', 0 );
+
+ require YAML;
+ my $data = YAML::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 {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+}
+
+sub abstract_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+sub _slurp {
+ my ( $self, $file ) = @_;
+
+ local *FH;
+ open FH, "< $file" or die "Cannot open $file.pod: $!";
+ do { local $/; <FH> };
+}
+
+sub perl_version_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ ^
+ use \s*
+ v?
+ ([\d\.]+)
+ \s* ;
+ /ixms
+ )
+ {
+ $self->perl_version($1);
+ }
+ else {
+ warn "Cannot determine perl version info from $file\n";
+ return;
+ }
+}
+
+sub author_from {
+ my ( $self, $file ) = @_;
+ my $content = $self->_slurp($file);
+ 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<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ }
+ else {
+ warn "Cannot determine author info from $file\n";
+ }
+}
+
+sub license_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ 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 itself' => 'perl',
+ 'GNU public license' => 'gpl',
+ 'GNU lesser public license' => 'gpl',
+ 'BSD license' => 'bsd',
+ 'Artistic license' => 'artistic',
+ 'GPL' => 'gpl',
+ 'LGPL' => 'lgpl',
+ 'BSD' => 'bsd',
+ 'Artistic' => 'artistic',
+ );
+ while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $file\n";
+ return 'unknown';
+}
+
+1;
--- /dev/null
+#line 1 "inc/Module/Install/Win32.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/Win32.pm"
+package Module::Install::Win32;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+$VERSION = '0.02';
+
+use strict;
+
+# 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 (
+ $Config::Config{make} and
+ $Config::Config{make} =~ /^nmake\b/i and
+ $^O eq 'MSWin32' 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,
+ );
+
+ if (!$rv) {
+ die << '.';
+
+-------------------------------------------------------------------------------
+
+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.
+
+-------------------------------------------------------------------------------
+.
+ }
+}
+
+1;
+
+__END__
+
--- /dev/null
+#line 1 "inc/Module/Install/WriteAll.pm - /Users/ingy/local/lib/perl5/site_perl/5.8.6/Module/Install/WriteAll.pm"
+package Module::Install::WriteAll;
+use Module::Install::Base; @ISA = qw(Module::Install::Base);
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ if ($0 =~ /Build.PL$/i) {
+ $self->Build->write;
+ }
+ else {
+ $self->check_nmake if $args{check_nmake};
+ $self->makemaker_args( PL_FILES => {} )
+ unless $self->makemaker_args->{'PL_FILES'};
+
+ if ($args{inline}) {
+ $self->Inline->write;
+ }
+ else {
+ $self->Makefile->write;
+ }
+ }
+}
+
+1;
--- /dev/null
+package Spiffy;
+use strict;
+use 5.006001;
+use warnings;
+use Carp;
+require Exporter;
+our $VERSION = '0.30';
+our @EXPORT = ();
+our @EXPORT_BASE = qw(field const stub super);
+our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
+our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
+
+my $stack_frame = 0;
+my $dump = 'yaml';
+my $bases_map = {};
+
+sub WWW; sub XXX; sub YYY; sub ZZZ;
+
+# This line is here to convince "autouse" into believing we are autousable.
+sub can {
+ ($_[1] eq 'import' and caller()->isa('autouse'))
+ ? \&Exporter::import # pacify autouse's equality test
+ : $_[0]->SUPER::can($_[1]) # normal case
+}
+
+# TODO
+#
+# Exported functions like field and super should be hidden so as not to
+# be confused with methods that can be inherited.
+#
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+ my $self = bless {}, $class;
+ while (@_) {
+ my $method = shift;
+ $self->$method(shift);
+ }
+ return $self;
+}
+
+my $filtered_files = {};
+my $filter_dump = 0;
+my $filter_save = 0;
+our $filter_result = '';
+sub import {
+ no strict 'refs';
+ no warnings;
+ my $self_package = shift;
+
+ # XXX Using parse_arguments here might cause confusion, because the
+ # subclass's boolean_arguments and paired_arguments can conflict, causing
+ # difficult debugging. Consider using something truly local.
+ my ($args, @export_list) = do {
+ local *boolean_arguments = sub {
+ qw(
+ -base -Base -mixin -selfless
+ -XXX -dumper -yaml
+ -filter_dump -filter_save
+ )
+ };
+ local *paired_arguments = sub { qw(-package) };
+ $self_package->parse_arguments(@_);
+ };
+ return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list)
+ if $args->{-mixin};
+
+ $filter_dump = 1 if $args->{-filter_dump};
+ $filter_save = 1 if $args->{-filter_save};
+ $dump = 'yaml' if $args->{-yaml};
+ $dump = 'dumper' if $args->{-dumper};
+
+ local @EXPORT_BASE = @EXPORT_BASE;
+
+ if ($args->{-XXX}) {
+ push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}}
+ unless grep /^XXX$/, @EXPORT_BASE;
+ }
+
+ spiffy_filter()
+ if ($args->{-selfless} or $args->{-Base}) and
+ not $filtered_files->{(caller($stack_frame))[1]}++;
+
+ my $caller_package = $args->{-package} || caller($stack_frame);
+ push @{"$caller_package\::ISA"}, $self_package
+ if $args->{-Base} or $args->{-base};
+
+ for my $class (@{all_my_bases($self_package)}) {
+ next unless $class->isa('Spiffy');
+ my @export = grep {
+ not defined &{"$caller_package\::$_"};
+ } ( @{"$class\::EXPORT"},
+ ($args->{-Base} or $args->{-base})
+ ? @{"$class\::EXPORT_BASE"} : (),
+ );
+ my @export_ok = grep {
+ not defined &{"$caller_package\::$_"};
+ } @{"$class\::EXPORT_OK"};
+
+ # Avoid calling the expensive Exporter::export
+ # if there is nothing to do (optimization)
+ my %exportable = map { ($_, 1) } @export, @export_ok;
+ next unless keys %exportable;
+
+ my @export_save = @{"$class\::EXPORT"};
+ my @export_ok_save = @{"$class\::EXPORT_OK"};
+ @{"$class\::EXPORT"} = @export;
+ @{"$class\::EXPORT_OK"} = @export_ok;
+ my @list = grep {
+ (my $v = $_) =~ s/^[\!\:]//;
+ $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
+ } @export_list;
+ Exporter::export($class, $caller_package, @list);
+ @{"$class\::EXPORT"} = @export_save;
+ @{"$class\::EXPORT_OK"} = @export_ok_save;
+ }
+}
+
+sub spiffy_filter {
+ require Filter::Util::Call;
+ my $done = 0;
+ Filter::Util::Call::filter_add(
+ sub {
+ return 0 if $done;
+ my ($data, $end) = ('', '');
+ while (my $status = Filter::Util::Call::filter_read()) {
+ return $status if $status < 0;
+ if (/^__(?:END|DATA)__\r?$/) {
+ $end = $_;
+ last;
+ }
+ $data .= $_;
+ $_ = '';
+ }
+ $_ = $data;
+ my @my_subs;
+ s[^(sub\s+\w+\s+\{)(.*\n)]
+ [${1}my \$self = shift;$2]gm;
+ s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
+ [${1}${2}]gm;
+ s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
+ [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
+ my $preclare = '';
+ if (@my_subs) {
+ $preclare = join ',', map "\$$_", @my_subs;
+ $preclare = "my($preclare);";
+ }
+ $_ = "use strict;use warnings;$preclare${_};1;\n$end";
+ if ($filter_dump) { print; exit }
+ if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
+ $done = 1;
+ }
+ );
+}
+
+sub base {
+ push @_, -base;
+ goto &import;
+}
+
+sub all_my_bases {
+ my $class = shift;
+
+ return $bases_map->{$class}
+ if defined $bases_map->{$class};
+
+ my @bases = ($class);
+ no strict 'refs';
+ for my $base_class (@{"${class}::ISA"}) {
+ push @bases, @{all_my_bases($base_class)};
+ }
+ my $used = {};
+ $bases_map->{$class} = [grep {not $used->{$_}++} @bases];
+}
+
+my %code = (
+ sub_start =>
+ "sub {\n",
+ set_default =>
+ " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
+ init =>
+ " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
+ " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
+ weak_init =>
+ " return do {\n" .
+ " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
+ " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
+ " \$_[0]->{%s};\n" .
+ " } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
+ return_if_get =>
+ " return \$_[0]->{%s} unless \$#_ > 0;\n",
+ set =>
+ " \$_[0]->{%s} = \$_[1];\n",
+ weaken =>
+ " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
+ sub_end =>
+ " return \$_[0]->{%s};\n}\n",
+);
+
+sub field {
+ my $package = caller;
+ my ($args, @values) = do {
+ no warnings;
+ local *boolean_arguments = sub { (qw(-weak)) };
+ local *paired_arguments = sub { (qw(-package -init)) };
+ Spiffy->parse_arguments(@_);
+ };
+ my ($field, $default) = @values;
+ $package = $args->{-package} if defined $args->{-package};
+ die "Cannot have a default for a weakened field ($field)"
+ if defined $default && $args->{-weak};
+ return if defined &{"${package}::$field"};
+ require Scalar::Util if $args->{-weak};
+ my $default_string =
+ ( ref($default) eq 'ARRAY' and not @$default )
+ ? '[]'
+ : (ref($default) eq 'HASH' and not keys %$default )
+ ? '{}'
+ : default_as_code($default);
+
+ my $code = $code{sub_start};
+ if ($args->{-init}) {
+ my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
+ $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
+ }
+ $code .= sprintf $code{set_default}, $field, $default_string, $field
+ if defined $default;
+ $code .= sprintf $code{return_if_get}, $field;
+ $code .= sprintf $code{set}, $field;
+ $code .= sprintf $code{weaken}, $field, $field
+ if $args->{-weak};
+ $code .= sprintf $code{sub_end}, $field;
+
+ my $sub = eval $code;
+ die $@ if $@;
+ no strict 'refs';
+ *{"${package}::$field"} = $sub;
+ return $code if defined wantarray;
+}
+
+sub default_as_code {
+ require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
+ my $code = Data::Dumper::Dumper(shift);
+ $code =~ s/^\$VAR1 = //;
+ $code =~ s/;$//;
+ return $code;
+}
+
+sub const {
+ my $package = caller;
+ my ($args, @values) = do {
+ no warnings;
+ local *paired_arguments = sub { (qw(-package)) };
+ Spiffy->parse_arguments(@_);
+ };
+ my ($field, $default) = @values;
+ $package = $args->{-package} if defined $args->{-package};
+ no strict 'refs';
+ return if defined &{"${package}::$field"};
+ *{"${package}::$field"} = sub { $default }
+}
+
+sub stub {
+ my $package = caller;
+ my ($args, @values) = do {
+ no warnings;
+ local *paired_arguments = sub { (qw(-package)) };
+ Spiffy->parse_arguments(@_);
+ };
+ my ($field, $default) = @values;
+ $package = $args->{-package} if defined $args->{-package};
+ no strict 'refs';
+ return if defined &{"${package}::$field"};
+ *{"${package}::$field"} =
+ sub {
+ require Carp;
+ Carp::confess
+ "Method $field in package $package must be subclassed";
+ }
+}
+
+sub parse_arguments {
+ my $class = shift;
+ my ($args, @values) = ({}, ());
+ my %booleans = map { ($_, 1) } $class->boolean_arguments;
+ my %pairs = map { ($_, 1) } $class->paired_arguments;
+ while (@_) {
+ my $elem = shift;
+ if (defined $elem and defined $booleans{$elem}) {
+ $args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
+ ? shift
+ : 1;
+ }
+ elsif (defined $elem and defined $pairs{$elem} and @_) {
+ $args->{$elem} = shift;
+ }
+ else {
+ push @values, $elem;
+ }
+ }
+ return wantarray ? ($args, @values) : $args;
+}
+
+sub boolean_arguments { () }
+sub paired_arguments { () }
+
+# get a unique id for any node
+sub id {
+ if (not ref $_[0]) {
+ return 'undef' if not defined $_[0];
+ \$_[0] =~ /\((\w+)\)$/o or die;
+ return "$1-S";
+ }
+ require overload;
+ overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die;
+ return $1;
+}
+
+#===============================================================================
+# It's super, man.
+#===============================================================================
+package DB;
+{
+ no warnings 'redefine';
+ sub super_args {
+ my @dummy = caller(@_ ? $_[0] : 2);
+ return @DB::args;
+ }
+}
+
+package Spiffy;
+sub super {
+ my $method;
+ my $frame = 1;
+ while ($method = (caller($frame++))[3]) {
+ $method =~ s/.*::// and last;
+ }
+ my @args = DB::super_args($frame);
+ @_ = @_ ? ($args[0], @_) : @args;
+ my $class = ref $_[0] ? ref $_[0] : $_[0];
+ my $caller_class = caller;
+ my $seen = 0;
+ my @super_classes = reverse grep {
+ ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
+ } reverse @{all_my_bases($class)};
+ for my $super_class (@super_classes) {
+ no strict 'refs';
+ next if $super_class eq $class;
+ if (defined &{"${super_class}::$method"}) {
+ ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
+ if $method eq 'AUTOLOAD';
+ return &{"${super_class}::$method"};
+ }
+ }
+ return;
+}
+
+#===============================================================================
+# This code deserves a spanking, because it is being very naughty.
+# It is exchanging base.pm's import() for its own, so that people
+# can use base.pm with Spiffy modules, without being the wiser.
+#===============================================================================
+my $real_base_import;
+my $real_mixin_import;
+
+BEGIN {
+ require base unless defined $INC{'base.pm'};
+ $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm';
+ $real_base_import = \&base::import;
+ $real_mixin_import = \&mixin::import;
+ no warnings;
+ *base::import = \&spiffy_base_import;
+ *mixin::import = \&spiffy_mixin_import;
+}
+
+# my $i = 0;
+# while (my $caller = caller($i++)) {
+# next unless $caller eq 'base' or $caller eq 'mixin';
+# croak <<END;
+# Spiffy.pm must be loaded before calling 'use base' or 'use mixin' with a
+# Spiffy module. See the documentation of Spiffy.pm for details.
+# END
+# }
+
+sub spiffy_base_import {
+ my @base_classes = @_;
+ shift @base_classes;
+ no strict 'refs';
+ goto &$real_base_import
+ unless grep {
+ eval "require $_" unless %{"$_\::"};
+ $_->isa('Spiffy');
+ } @base_classes;
+ my $inheritor = caller(0);
+ for my $base_class (@base_classes) {
+ next if $inheritor->isa($base_class);
+ croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
+ "See the documentation of Spiffy.pm for details\n "
+ unless $base_class->isa('Spiffy');
+ $stack_frame = 1; # tell import to use different caller
+ import($base_class, '-base');
+ $stack_frame = 0;
+ }
+}
+
+sub mixin {
+ my $self = shift;
+ my $target_class = ref($self);
+ spiffy_mixin_import($target_class, @_)
+}
+
+sub spiffy_mixin_import {
+ my $target_class = shift;
+ $target_class = caller(0)
+ if $target_class eq 'mixin';
+ my $mixin_class = shift
+ or die "Nothing to mixin";
+ eval "require $mixin_class";
+ my @roles = @_;
+ my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
+ my %methods = spiffy_mixin_methods($mixin_class, @roles);
+ no strict 'refs';
+ no warnings;
+ @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
+ @{"$target_class\::ISA"} = ($pseudo_class);
+ for (keys %methods) {
+ *{"$pseudo_class\::$_"} = $methods{$_};
+ }
+}
+
+sub spiffy_mixin_methods {
+ my $mixin_class = shift;
+ no strict 'refs';
+ my %methods = spiffy_all_methods($mixin_class);
+ map {
+ $methods{$_}
+ ? ($_, \ &{"$methods{$_}\::$_"})
+ : ($_, \ &{"$mixin_class\::$_"})
+ } @_
+ ? (get_roles($mixin_class, @_))
+ : (keys %methods);
+}
+
+sub get_roles {
+ my $mixin_class = shift;
+ my @roles = @_;
+ while (grep /^!*:/, @roles) {
+ @roles = map {
+ s/!!//g;
+ /^!:(.*)/ ? do {
+ my $m = "_role_$1";
+ map("!$_", $mixin_class->$m);
+ } :
+ /^:(.*)/ ? do {
+ my $m = "_role_$1";
+ ($mixin_class->$m);
+ } :
+ ($_)
+ } @roles;
+ }
+ if (@roles and $roles[0] =~ /^!/) {
+ my %methods = spiffy_all_methods($mixin_class);
+ unshift @roles, keys(%methods);
+ }
+ my %roles;
+ for (@roles) {
+ s/!!//g;
+ delete $roles{$1}, next
+ if /^!(.*)/;
+ $roles{$_} = 1;
+ }
+ keys %roles;
+}
+
+sub spiffy_all_methods {
+ no strict 'refs';
+ my $class = shift;
+ return if $class eq 'Spiffy';
+ my %methods = map {
+ ($_, $class)
+ } grep {
+ defined &{"$class\::$_"} and not /^_/
+ } keys %{"$class\::"};
+ my %super_methods;
+ %super_methods = spiffy_all_methods(${"$class\::ISA"}[0])
+ if @{"$class\::ISA"};
+ %{{%super_methods, %methods}};
+}
+
+
+# END of naughty code.
+#===============================================================================
+# Debugging support
+#===============================================================================
+sub spiffy_dump {
+ no warnings;
+ if ($dump eq 'dumper') {
+ require Data::Dumper;
+ $Data::Dumper::Sortkeys = 1;
+ $Data::Dumper::Indent = 1;
+ return Data::Dumper::Dumper(@_);
+ }
+ require YAML;
+ $YAML::UseVersion = 0;
+ return YAML::Dump(@_) . "...\n";
+}
+
+sub at_line_number {
+ my ($file_path, $line_number) = (caller(1))[1,2];
+ " at $file_path line $line_number\n";
+}
+
+sub WWW {
+ warn spiffy_dump(@_) . at_line_number;
+ return wantarray ? @_ : $_[0];
+}
+
+sub XXX {
+ die spiffy_dump(@_) . at_line_number;
+}
+
+sub YYY {
+ print spiffy_dump(@_) . at_line_number;
+ return wantarray ? @_ : $_[0];
+}
+
+sub ZZZ {
+ require Carp;
+ Carp::confess spiffy_dump(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Spiffy - Spiffy Perl Interface Framework For You
+
+=head1 SYNOPSIS
+
+ package Keen;
+ use Spiffy -Base;
+ field 'mirth';
+ const mood => ':-)';
+
+ sub happy {
+ if ($self->mood eq ':-(') {
+ $self->mirth(-1);
+ print "Cheer up!";
+ }
+ super;
+ }
+
+=head1 DESCRIPTION
+
+"Spiffy" is a framework and methodology for doing object oriented (OO)
+programming in Perl. Spiffy combines the best parts of Exporter.pm,
+base.pm, mixin.pm and SUPER.pm into one magic foundation class. It
+attempts to fix all the nits and warts of traditional Perl OO, in a
+clean, straightforward and (perhaps someday) standard way.
+
+Spiffy borrows ideas from other OO languages like Python, Ruby,
+Java and Perl 6. It also adds a few tricks of its own.
+
+If you take a look on CPAN, there are a ton of OO related modules. When
+starting a new project, you need to pick the set of modules that makes
+most sense, and then you need to use those modules in each of your
+classes. Spiffy, on the other hand, has everything you'll probably need
+in one module, and you only need to use it once in one of your classes.
+If you make Spiffy.pm the base class of the basest class in your
+project, Spiffy will automatically pass all of its magic to all of your
+subclasses. You may eventually forget that you're even using it!
+
+The most striking difference between Spiffy and other Perl object
+oriented base classes, is that it has the ability to export things.
+If you create a subclass of Spiffy, all the things that Spiffy
+exports will automatically be exported by your subclass, in addition to
+any more things that you want to export. And if someone creates a
+subclass of your subclass, all of those things will be exported
+automatically, and so on. Think of it as "Inherited Exportation", and it
+uses the familiar Exporter.pm specification syntax.
+
+To use Spiffy or any subclass of Spiffy as a base class of your class,
+you specify the C<-base> argument to the C<use> command.
+
+ use MySpiffyBaseModule -base;
+
+You can also use the traditional C<use base 'MySpiffyBaseModule';>
+syntax and everything will work exactly the same. The only caveat is
+that Spiffy.pm must already be loaded. That's because Spiffy rewires
+base.pm on the fly to do all the Spiffy magics.
+
+Spiffy has support for Ruby-like mixins with Perl6-like roles. Just like
+C<base> you can use either of the following invocations:
+
+ use mixin 'MySpiffyBaseModule';
+ use MySpiffyBaseModule -mixin;
+
+The second version will only work if the class being mixed in is a
+subclass of Spiffy. The first version will work in all cases, as long
+as Spiffy has already been loaded.
+
+To limit the methods that get mixed in, use roles. (Hint: they work just like
+an Exporter list):
+
+ use MySpiffyBaseModule -mixin => qw(:basics x y !foo);
+
+In object oriented Perl almost every subroutine is a method. Each method
+gets the object passed to it as its first argument. That means
+practically every subroutine starts with the line:
+
+ my $self = shift;
+
+Spiffy provides a simple, optional filter mechanism to insert that line
+for you, resulting in cleaner code. If you figure an average method has
+10 lines of code, that's 10% of your code! To turn this option on, you
+just use the C<-Base> option instead of the C<-base> option, or add the
+C<-selfless> option. If source filtering makes you queazy, don't use the
+feature. I personally find it addictive in my quest for writing squeaky
+clean, maintainable code.
+
+A useful feature of Spiffy is that it exports two functions: C<field>
+and C<const> that can be used to declare the attributes of your class,
+and automatically generate accessor methods for them. The only
+difference between the two functions is that C<const> attributes can not
+be modified; thus the accessor is much faster.
+
+One interesting aspect of OO programming is when a method calls the same
+method from a parent class. This is generally known as calling a super
+method. Perl's facility for doing this is butt ugly:
+
+ sub cleanup {
+ my $self = shift;
+ $self->scrub;
+ $self->SUPER::cleanup(@_);
+ }
+
+Spiffy makes it, er, super easy to call super methods. You just use
+the C<super> function. You don't need to pass it any arguments
+because it automatically passes them on for you. Here's the same
+function with Spiffy:
+
+ sub cleanup {
+ $self->scrub;
+ super;
+ }
+
+Spiffy has a special method for parsing arguments called
+C<parse_arguments>, that it also uses for parsing its own arguments. You
+declare which arguments are boolean (singletons) and which ones are
+paired, with two special methods called C<boolean_arguments> and
+C<paired_arguments>. Parse arguments pulls out the booleans and pairs
+and returns them in an anonymous hash, followed by a list of the
+unmatched arguments.
+
+Finally, Spiffy can export a few debugging functions C<WWW>, C<XXX>,
+C<YYY> and C<ZZZ>. Each of them produces a YAML dump of its arguments.
+WWW warns the output, XXX dies with the output, YYY prints the output,
+and ZZZ confesses the output. If YAML doesn't suit your needs, you can
+switch all the dumps to Data::Dumper format with the C<-dumper> option.
+
+That's Spiffy!
+
+=head1 Spiffy EXPORTING
+
+Spiffy implements a completely new idea in Perl. Modules that act both
+as object oriented classes and that also export functions. But it
+takes the concept of Exporter.pm one step further; it walks the entire
+C<@ISA> path of a class and honors the export specifications of each
+module. Since Spiffy calls on the Exporter module to do this, you can
+use all the fancy interface features that Exporter has, including tags
+and negation.
+
+Spiffy considers all the arguments that don't begin with a dash to
+comprise the export specification.
+
+ package Vehicle;
+ use Spiffy -base;
+ our $SERIAL_NUMBER = 0;
+ our @EXPORT = qw($SERIAL_NUMBER);
+ our @EXPORT_BASE = qw(tire horn);
+
+ package Bicycle;
+ use Vehicle -base, '!field';
+ $self->inflate(tire);
+
+In this case, C<Bicycle->isa('Vehicle')> and also all the things
+that C<Vehicle> and C<Spiffy> export, will go into C<Bicycle>,
+except C<field>.
+
+Exporting can be very helpful when you've designed a system with
+hundreds of classes, and you want them all to have access to some
+functions or constants or variables. Just export them in your main base
+class and every subclass will get the functions they need.
+
+You can do almost everything that Exporter does because Spiffy delegates
+the job to Exporter (after adding some Spiffy magic). Spiffy offers a
+C<@EXPORT_BASE> variable which is like C<@EXPORT>, but only for usages
+that use C<-base>.
+
+=head1 Spiffy MIXINs & ROLEs
+
+If you've done much OO programming in Perl you've probably used Multiple
+Inheritance (MI), and if you've done much MI you've probably run into
+weird problems and headaches. Some languages like Ruby, attempt to
+resolve MI issues using a technique called mixins. Basically, all Ruby
+classes use only Single Inheritance (SI), and then I<mixin>
+functionality from other modules if they need to.
+
+Mixins can be thought of at a simplistic level as I<importing> the
+methods of another class into your subclass. But from an implementation
+standpoint that's not the best way to do it. Spiffy does what Ruby
+does. It creates an empty anonymous class, imports everything into that
+class, and then chains the new class into your SI ISA path. In other
+words, if you say:
+
+ package A;
+ use B -base;
+ use C -mixin;
+ use D -mixin;
+
+You end up with a single inheritance chain of classes like this:
+
+ A << A-D << A-C << B;
+
+C<A-D> and C<A-C> are the actual package names of the generated
+classes. The nice thing about this style is that mixing in C doesn't
+clobber any methods in A, and D doesn't conflict with A or C either. If
+you mixed in a method in C that was also in A, you can still get to it
+by using C<super>.
+
+When Spiffy mixes in C, it pulls in all the methods in C that do not
+begin with an underscore. Actually it goes farther than that. If C is a
+subclass it will pull in every method that C C<can> do through
+inheritance. This is very powerful, maybe too powerful.
+
+To limit what you mixin, Spiffy borrows the concept of Roles from
+Perl6. The term role is used more loosely in Spiffy though. It's much
+like an import list that the Exporter module uses, and you can use
+groups (tags) and negation. If the first element of your list uses
+negation, Spiffy will start with all the methods that your mixin
+class can do.
+
+ use E -mixin => qw(:tools walk !run !:sharp_tools);
+
+In this example, C<walk> and C<run> are methods that E can do, and
+C<tools> and C<sharp_tools> are roles of class E. How does class E
+define these roles? It very simply defines methods called C<_role_tools>
+and C<_role_sharp_tools> which return lists of more methods. (And
+possibly other roles!) The neat thing here is that since roles are just
+methods, they too can be inherited. Take B<that> Perl6!
+
+=head1 Spiffy FILTERING
+
+By using the C<-Base> flag instead of C<-base> you never need to write the
+line:
+
+ my $self = shift;
+
+This statement is added to every subroutine in your class by using a source
+filter. The magic is simple and fast, so there is litte performance penalty
+for creating clean code on par with Ruby and Python.
+
+ package Example;
+ use Spiffy -Base;
+
+ sub crazy {
+ $self->nuts;
+ }
+ sub wacky { }
+ sub new() {
+ bless [], shift;
+ }
+
+is exactly the same as:
+
+ package Example;
+ use Spiffy -base;
+ use strict;use warnings;
+ sub crazy {my $self = shift;
+ $self->nuts;
+ }
+ sub wacky {my $self = shift; }
+ sub new {
+ bless [], shift;
+ }
+ ;1;
+
+Note that the empty parens after the subroutine C<new> keep it from
+having a $self added. Also note that the extra code is added to existing
+lines to ensure that line numbers are not altered.
+
+C<-Base> also turns on the strict and warnings pragmas, and adds that
+annoying '1;' line to your module.
+
+=head1 PRIVATE METHODS
+
+Spiffy now has support for private methods when you use the '-Base' filter
+mechanism. You just declare the subs with the C<my> keyword, and call them
+with a C<'$'> in front. Like this:
+
+ package Keen;
+ use SomethingSpiffy -Base;
+
+ # normal public method
+ sub swell {
+ $self->$stinky;
+ }
+
+ # private lexical method. uncallable from outside this file.
+ my sub stinky {
+ ...
+ }
+
+=head1 Spiffy DEBUGGING
+
+The XXX function is very handy for debugging because you can insert it
+almost anywhere, and it will dump your data in nice clean YAML. Take the
+following statement:
+
+ my @stuff = grep { /keen/ } $self->find($a, $b);
+
+If you have a problem with this statement, you can debug it in any of the
+following ways:
+
+ XXX my @stuff = grep { /keen/ } $self->find($a, $b);
+ my @stuff = XXX grep { /keen/ } $self->find($a, $b);
+ my @stuff = grep { /keen/ } XXX $self->find($a, $b);
+ my @stuff = grep { /keen/ } $self->find(XXX $a, $b);
+
+XXX is easy to insert and remove. It is also a tradition to mark
+uncertain areas of code with XXX. This will make the debugging dumpers
+easy to spot if you forget to take them out.
+
+WWW and YYY are nice because they dump their arguments and then return the
+arguments. This way you can insert them into many places and still have the
+code run as before. Use ZZZ when you need to die with both a YAML dump and a
+full stack trace.
+
+The debugging functions are exported by default if you use the C<-base>
+option, but only if you have previously used the C<-XXX> option. To
+export all 4 functions use the export tag:
+
+ use SomeSpiffyModule ':XXX';
+
+To force the debugging functions to use Data::Dumper instead of YAML:
+
+ use SomeSpiffyModule -dumper;
+
+=head1 Spiffy FUNCTIONS
+
+This section describes the functions the Spiffy exports. The C<field>,
+C<const>, C<stub> and C<super> functions are only exported when you use
+the C<-base> or C<-Base> options.
+
+=over 4
+
+=item * field
+
+Defines accessor methods for a field of your class:
+
+ package Example;
+ use Spiffy -Base;
+
+ field 'foo';
+ field bar => [];
+
+ sub lalala {
+ $self->foo(42);
+ push @{$self->{bar}}, $self->foo;
+ }
+
+The first parameter passed to C<field> is the name of the attribute
+being defined. Accessors can be given an optional default value.
+This value will be returned if no value for the field has been set
+in the object.
+
+=item * const
+
+ const bar => 42;
+
+The C<const> function is similar to <field> except that it is immutable.
+It also does not store data in the object. You probably always want to
+give a C<const> a default value, otherwise the generated method will be
+somewhat useless.
+
+=item * stub
+
+ stub 'cigar';
+
+The C<stub> function generates a method that will die with an
+appropriate message. The idea is that subclasses must implement these
+methods so that the stub methods don't get called.
+
+=item * super
+
+If this function is called without any arguments, it will call the same
+method that it is in, higher up in the ISA tree, passing it all the
+same arguments. If it is called with arguments, it will use those
+arguments with C<$self> in the front. In other words, it just works
+like you'd expect.
+
+ sub foo {
+ super; # Same as $self->SUPER::foo(@_);
+ super('hello'); # Same as $self->SUPER::foo('hello');
+ $self->bar(42);
+ }
+
+ sub new() {
+ my $self = super;
+ $self->init;
+ return $self;
+ }
+
+C<super> will simply do nothing if there is no super method. Finally,
+C<super> does the right thing in AUTOLOAD subroutines.
+
+=back
+
+=head1 Spiffy METHODS
+
+This section lists all of the methods that any subclass of Spiffy
+automatically inherits.
+
+=over 4
+
+=item * mixin
+
+A method to mixin a class at runtime. Takes the same arguments as C<use
+mixin ...>. Makes the target class a mixin of the caller.
+
+ $self->mixin('SomeClass');
+ $object->mixin('SomeOtherClass' => 'some_method');
+
+=item * parse_arguments
+
+This method takes a list of arguments and groups them into pairs. It
+allows for boolean arguments which may or may not have a value
+(defaulting to 1). The method returns a hash reference of all the pairs
+as keys and values in the hash. Any arguments that cannot be paired, are
+returned as a list. Here is an example:
+
+ sub boolean_arguments { qw(-has_spots -is_yummy) }
+ sub paired_arguments { qw(-name -size) }
+ my ($pairs, @others) = $self->parse_arguments(
+ 'red', 'white',
+ -name => 'Ingy',
+ -has_spots =>
+ -size => 'large',
+ 'black',
+ -is_yummy => 0,
+ );
+
+After this call, C<$pairs> will contain:
+
+ {
+ -name => 'Ingy',
+ -has_spots => 1,
+ -size => 'large',
+ -is_yummy => 0,
+ }
+
+and C<@others> will contain 'red', 'white', and 'black'.
+
+=item * boolean_arguments
+
+Returns the list of arguments that are recognized as being boolean. Override
+this method to define your own list.
+
+=item * paired_arguments
+
+Returns the list of arguments that are recognized as being paired. Override
+this method to define your own list.
+
+=back
+
+=head1 Spiffy ARGUMENTS
+
+When you C<use> the Spiffy module or a subclass of it, you can pass it a
+list of arguments. These arguments are parsed using the
+C<parse_arguments> method described above. The special argument
+C<-base>, is used to make the current package a subclass of the Spiffy
+module being used.
+
+Any non-paired parameters act like a normal import list; just like those
+used with the Exporter module.
+
+=head1 USING Spiffy WITH base.pm
+
+The proper way to use a Spiffy module as a base class is with the C<-base>
+parameter to the C<use> statement. This differs from typical modules where you
+would want to C<use base>.
+
+ package Something;
+ use Spiffy::Module -base;
+ use base 'NonSpiffy::Module';
+
+Now it may be hard to keep track of what's Spiffy and what is not.
+Therefore Spiffy has actually been made to work with base.pm. You can
+say:
+
+ package Something;
+ use base 'Spiffy::Module';
+ use base 'NonSpiffy::Module';
+
+C<use base> is also very useful when your class is not an actual module (a
+separate file) but just a package in some file that has already been loaded.
+C<base> will work whether the class is a module or not, while the C<-base>
+syntax cannot work that way, since C<use> always tries to load a module.
+
+=head2 base.pm Caveats
+
+To make Spiffy work with base.pm, a dirty trick was played. Spiffy swaps
+C<base::import> with its own version. If the base modules are not Spiffy,
+Spiffy calls the original base::import. If the base modules are Spiffy,
+then Spiffy does its own thing.
+
+There are two caveats.
+
+=over 4
+
+=item * Spiffy must be loaded first.
+
+If Spiffy is not loaded and C<use base> is invoked on a Spiffy module,
+Spiffy will die with a useful message telling the author to read this
+documentation. That's because Spiffy needed to do the import swap
+beforehand.
+
+If you get this error, simply put a statement like this up front in
+your code:
+
+ use Spiffy ();
+
+=item * No Mixing
+
+C<base.pm> can take multiple arguments. And this works with Spiffy as
+long as all the base classes are Spiffy, or they are all non-Spiffy. If
+they are mixed, Spiffy will die. In this case just use separate C<use
+base> statements.
+
+=back
+
+=head1 Spiffy TODO LIST
+
+Spiffy is a wonderful way to do OO programming in Perl, but it is still
+a work in progress. New things will be added, and things that don't work
+well, might be removed.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+Copyright (c) 2004. Brian Ingerson. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
--- /dev/null
+package Filter4;
+use Spiffy -Base;
+# comment
+
+sub foo {
+ my $x = $self->$bar;
+}
+
+sub one { }
+sub uno {}
+my sub bar {
+ if (1) {
+ my $y = 1;
+ }
+}
+
+sub baz() {
+ my $z = 1;
+}
+
+my sub bam {
+ $self->$bar(42);
+}
--- /dev/null
+package Filter5;
+use Spiffy -Base;
+my sub xxx {
+ $self->$xxx;
+ $self->$yyy;
+}
+my sub yyy {
+ $self->$xxx;
+ $self->$yyy
+}
--- /dev/null
+package NonSpiffy;
+
+use Filter4; # Filter4 /is/ Spiffy
+
+1;
--- /dev/null
+package Something;
+use strict;
+sub thing { Something->new(@_) }
+our @EXPORT = qw(thing);
+use Thing -base;
+
+field color => 'blue';
+
+sub cool {}
+
+1;
--- /dev/null
+package Thing;
+use strict;
+use Spiffy -base;
+use base 'Spiffy';
+our @EXPORT = qw(thing);
+
+field volume => 11;
+
+sub thing { Thing->new(@_) }
+
+1;
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+use Spiffy ();
+
+package A;
+use Spiffy -Base;
+
+sub AUTOLOAD {
+ super;
+ join '+', $A::AUTOLOAD, @_;
+}
+
+package B;
+use base 'A';
+
+sub AUTOLOAD {
+ super;
+}
+
+package C;
+use base 'B';
+
+sub AUTOLOAD {
+ super;
+}
+
+package main;
+use Test::More tests => 1;
+
+is(C->foo(42), 'C::foo+42');
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package XXX;
+BEGIN {require Thing}
+use base 'Thing';
+
+package Foo;
+use base 'Spiffy';
+BEGIN { @Foo::EXPORT=qw(xxx) }
+sub xxx {}
+
+package Bar;
+use base 'Foo', 'Thing';
+
+package Boo;
+BEGIN { @Boo::EXPORT=qw(xxx) }
+sub xxx {}
+
+package Goo;
+use base 'Boo';
+
+package Something;
+use base 'Spiffy';
+BEGIN { @Something::EXPORT = qw(qwerty) }
+sub qwerty {}
+
+package SomethingGood;
+use base 'Something';
+
+package main;
+use Test::More tests => 24;
+
+ok(Thing->isa('Spiffy'));
+ok(defined &XXX::thing);
+ok(defined &XXX::field);
+ok(defined &XXX::const);
+
+ok(defined &Foo::field);
+ok(defined &Foo::const);
+ok(defined &Foo::xxx);
+
+ok(Bar->isa('Spiffy'));
+ok(Bar->isa('Foo'));
+ok(Bar->isa('Thing'));
+ok(defined &Bar::field);
+ok(defined &Bar::const);
+ok(defined &Bar::xxx);
+ok(defined &Bar::thing);
+
+ok(not Boo->isa('Spiffy'));
+ok(defined &Boo::xxx);
+
+ok(not Goo->isa('Spiffy'));
+ok(Goo->isa('Boo'));
+ok(not defined &Goo::xxx);
+
+ok(SomethingGood->isa('Something'));
+ok(SomethingGood->isa('Spiffy'));
+ok(not SomethingGood->isa('Thing'));
+ok(not defined &SomethingGood::thing);
+
+ok(not @Spiffy::ISA);
--- /dev/null
+use Test::More tests => 1;
+
+use lib 't';
+
+eval <<'...';
+package Foo;
+use base 'NonSpiffy';
+...
+
+is $@, '';
--- /dev/null
+use lib 'lib';
+
+package Foo;
+use strict;
+use Spiffy -base;
+use Cwd;
+our @EXPORT = qw(cwd);
+
+package Bar;
+use strict;
+Foo->base;
+our @EXPORT = qw(doodle);
+sub doodle {}
+sub poodle {}
+
+package Baz;
+use strict;
+Bar->base;
+
+package main;
+use strict;
+use Test::More tests => 12;
+
+ok(not defined &Foo::import);
+ok(defined &Foo::cwd);
+ok(not defined &Foo::doodle);
+ok(not defined &Foo::poodle);
+
+ok(not defined &Bar::import);
+ok(defined &Bar::cwd);
+ok(defined &Bar::doodle);
+ok(defined &Bar::poodle);
+
+ok(not defined &Baz::import);
+ok(defined &Baz::cwd);
+ok(defined &Baz::doodle);
+ok(not defined &Baz::poodle);
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package XXX;
+use Spiffy -base;
+const foo => 42;
+
+package main;
+use Test::More tests => 3;
+
+my $xxx = XXX->new;
+is($xxx->foo, 42);
+is($xxx->foo(69), 42);
+is($xxx->foo, 42);
--- /dev/null
+use Test::More tests => 1;
+
+use lib 't';
+
+SKIP: {
+ skip 'XXX - fix later', 1;
+ eval <<'...';
+
+package Foo;
+use base 'Filter4';
+
+...
+
+ like $@, qr/\QSpiffy.pm must be loaded before calling 'use base'/,
+ "Caught attempt to use 'base' on Spiffy module before loading Spiffy";
+}
--- /dev/null
+package Foo;
+use strict;
+use Test::More tests => 20;
+use lib 't';
+use Something;
+
+ok(not defined &Foo::import);
+ok(defined &Foo::thing);
+ok(ref(thing) eq 'Something');
+ok(thing()->can('cool'));
+ok(thing()->isa('Something'));
+ok(thing()->isa('Thing'));
+ok(thing()->isa('Spiffy'));
+is(join('-', @Foo::ISA), '');
+ok(not defined &Foo::field);
+ok(not defined &Foo::spiffy_constructor);
+
+ok(not defined &Something::import);
+ok(defined &Something::thing);
+ok(defined &Something::field);
+ok(not defined &Something::spiffy_constructor);
+is(join('-', @Something::ISA), 'Thing');
+
+ok(not defined &Thing::import);
+ok(defined &Thing::thing);
+ok(defined &Thing::field);
+ok(not defined &Thing::spiffy_constructor);
+is(join('-', @Thing::ISA), 'Spiffy');
--- /dev/null
+use lib 't';
+use strict;
+use warnings;
+package A;
+use Spiffy -base;
+BEGIN {@A::EXPORT = qw($A1 $A2)}
+$A::A1 = 5;
+$A::A2 = 10;
+
+package B;
+use base 'A';
+BEGIN {@B::EXPORT = qw($A2 $A3)}
+$B::A2 = 15;
+$B::A3 = 20;
+
+package main;
+use strict;
+use Test::More tests => 6;
+BEGIN {B->import}
+ok(defined $main::A1);
+ok(defined $main::A2);
+ok(defined $main::A3);
+is($main::A1, 5);
+is($main::A2, 15);
+is($main::A3, 20);
--- /dev/null
+use lib 't';
+use strict;
+use warnings;
+
+package A;
+use Spiffy -base;
+BEGIN {@A::EXPORT_OK = qw($A1 $A2)}
+$A::A1 = 5;
+$A::A2 = 10;
+
+package B;
+use base 'A';
+BEGIN {@B::EXPORT_OK = qw($A2 $A3)}
+$B::A2 = 15;
+$B::A3 = 20;
+
+package main;
+no warnings;
+use Test::More tests => 7;
+BEGIN {B->import(qw($A1 $A2 $A3 $A4))}
+ok(defined $main::A1);
+ok(defined $main::A2);
+ok(defined $main::A3);
+ok(not defined $main::A4);
+is($A1, 5);
+is($A2, 10);
+is($A3, 20);
--- /dev/null
+use lib 't';
+use strict;
+use warnings;
+
+package A;
+# Exporter before 5.8.4 needs the tag as the first thing imported
+use Spiffy -base, qw(:XXX const);
+
+package B;
+use base 'A';
+
+package C;
+use Spiffy -XXX, -base;
+
+package D;
+use Spiffy -base;
+
+package E;
+use Spiffy -base, 'XXX';
+
+package F;
+use Spiffy -base;
+use Spiffy 'XXX';
+
+package main;
+use Test::More tests => 24;
+
+ok(not defined &A::field);
+ok(defined &A::const);
+ok(defined &A::XXX);
+ok(defined &A::YYY);
+
+ok(defined &B::field);
+ok(defined &B::const);
+ok(not defined &B::XXX);
+ok(not defined &B::YYY);
+
+ok(defined &C::field);
+ok(defined &C::const);
+ok(defined &C::XXX);
+ok(defined &C::YYY);
+
+ok(defined &D::field);
+ok(defined &D::const);
+ok(not defined &D::XXX);
+ok(not defined &D::YYY);
+
+ok(not defined &E::field);
+ok(not defined &E::const);
+ok(defined &E::XXX);
+ok(not defined &E::YYY);
+
+ok(defined &F::field);
+ok(defined &F::const);
+ok(defined &F::XXX);
+ok(not defined &F::YYY);
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package A;
+use Spiffy -base;
+BEGIN {@A::EXPORT_OK = qw(dude)}
+const dude => 10;
+
+package B;
+use base 'A';
+BEGIN {
+ @B::EXPORT_OK = qw(dude);
+ const dude => 20;
+}
+
+package C;
+BEGIN {B->import('dude')}
+
+package main;
+no warnings;
+use Test::More tests => 2;
+ok(defined $C::{dude});
+is(C::dude(), 20);
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package A;
+use Spiffy -Base, ':XXX';
+
+package B;
+use Spiffy -Base, ':XXX', 'field';
+
+package main;
+use Test::More tests => 4;
+ok(not defined &A::field);
+ok(defined &B::field);
+ok(defined &A::XXX);
+ok(defined &B::XXX);
--- /dev/null
+use Test::More;
+
+plan tests => 4;
+
+package B;
+use Spiffy -Base, -XXX;
+
+package A;
+use Spiffy -Base;
+
+package main;
+
+ok(not defined &A::XXX);
+ok(defined &A::field);
+
+ok(defined &B::XXX);
+ok(defined &B::field);
--- /dev/null
+package Foo;
+use Spiffy -base;
+
+package autouse;
+
+use Test::More tests => 1;
+
+is 'Foo'->can('import'), \&Exporter::import,
+ 'Spiffy modules support autouse';
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+use Spiffy ();
+
+package Bar;
+
+package Foo;
+use base 'Spiffy';
+sub new {
+ my $self = super;
+ field -package => 'Bar', 'xxx';
+}
+
+use Test::More tests => 4;
+
+Foo->new;
+ok(not defined $Foo::{-package});
+ok(not defined &Foo::Bar);
+ok(not defined &Foo::xxx);
+ok(defined &Bar::xxx);
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package Foo;
+use Spiffy -base;
+field one => [];
+field two => {};
+field three => [1..4];
+field four => {1..4};
+
+package main;
+use Test::More tests => 5;
+use Spiffy 'id';
+
+my $f1 = Foo->new;
+my $f2 = Foo->new;
+ok(id($f1->one) ne id($f2->one));
+ok(id($f1->two) ne id($f2->two));
+is(scalar(@{$f1->three}), 4);
+is_deeply($f1->three, $f2->three);
+is_deeply($f1->four, $f2->four);
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package Foo;
+use Spiffy -Base;
+my $test1 = field test1 => [];
+my $test2 = field test2 => {};
+my $test3 = field test3 => [1..4];
+my $test4 = field test4 => {1..4};
+my $test5 = field test5 => -weaken;
+my $test6 = field test6 => -init => '$self->setup(@_)';
+my $test7 = field test7 => -weak => -init => '$self->setup(@_)';
+
+package main;
+use Test::More tests => 7;
+
+my @expected = map { s/\r//g; $_ } split /\.\.\.\r?\n/, join '', <DATA>;
+
+my $i = 1;
+for my $expected (@expected) {
+ is(eval '$test' . $i++, $expected);
+}
+
+__DATA__
+sub {
+ $_[0]->{test1} = []
+ unless exists $_[0]->{test1};
+ return $_[0]->{test1} unless $#_ > 0;
+ $_[0]->{test1} = $_[1];
+ return $_[0]->{test1};
+}
+...
+sub {
+ $_[0]->{test2} = {}
+ unless exists $_[0]->{test2};
+ return $_[0]->{test2} unless $#_ > 0;
+ $_[0]->{test2} = $_[1];
+ return $_[0]->{test2};
+}
+...
+sub {
+ $_[0]->{test3} = [
+ 1,
+ 2,
+ 3,
+ 4
+ ]
+
+ unless exists $_[0]->{test3};
+ return $_[0]->{test3} unless $#_ > 0;
+ $_[0]->{test3} = $_[1];
+ return $_[0]->{test3};
+}
+...
+sub {
+ $_[0]->{test4} = {
+ '1' => 2,
+ '3' => 4
+ }
+
+ unless exists $_[0]->{test4};
+ return $_[0]->{test4} unless $#_ > 0;
+ $_[0]->{test4} = $_[1];
+ return $_[0]->{test4};
+}
+...
+sub {
+ $_[0]->{test5} = '-weaken'
+
+ unless exists $_[0]->{test5};
+ return $_[0]->{test5} unless $#_ > 0;
+ $_[0]->{test5} = $_[1];
+ return $_[0]->{test5};
+}
+...
+sub {
+ return $_[0]->{test6} = do { my $self = $_[0]; $self->setup(@_) }
+ unless $#_ > 0 or defined $_[0]->{test6};
+ return $_[0]->{test6} unless $#_ > 0;
+ $_[0]->{test6} = $_[1];
+ return $_[0]->{test6};
+}
+...
+sub {
+ return do {
+ $_[0]->{test7} = do { my $self = $_[0]; $self->setup(@_) };
+ Scalar::Util::weaken($_[0]->{test7}) if ref $_[0]->{test7};
+ $_[0]->{test7};
+ } unless $#_ > 0 or defined $_[0]->{test7};
+ return $_[0]->{test7} unless $#_ > 0;
+ $_[0]->{test7} = $_[1];
+ Scalar::Util::weaken($_[0]->{test7}) if ref $_[0]->{test7};
+ return $_[0]->{test7};
+}
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package XXX;
+use Spiffy -Base; #, '-filter_dump';
+
+const name => 'world';
+
+sub foo {
+ "Hello, " . $self->name;
+}
+
+sub bar() {
+ my $self = shift;
+ return $self;
+}
+
+package main;
+use Test::More tests => 2;
+
+my $xxx = XXX->new;
+is($xxx->foo, 'Hello, world');
+is(XXX::bar(42), 42);
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package YYY;
+use Spiffy -Base;
+
+package XXX;
+use Spiffy -Base;
+
+const name => 'world';
+
+sub foo {
+ "Hello, " . $self->name;
+}
+
+sub bar() {
+ my $self = shift;
+ return $self;
+}
+
+package main;
+use Test::More tests => 2;
+
+my $xxx = XXX->new;
+is($xxx->foo, 'Hello, world');
+is(XXX::bar(42), 42);
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package BOX;
+use Spiffy -Base;
+
+package main;
+use Test::More tests => 3;
+
+is(scalar <BOX::DATA>, "one\n");
+is(scalar <BOX::DATA>, "two\n");
+is(scalar <BOX::DATA>, "three\n");
+
+sub foo {
+ $self->foo;
+}
+
+package BOX;
+__DATA__
+one
+two
+three
--- /dev/null
+use lib 't', 'lib';
+use strict;
+
+use Test::More tests => 1;
+use Spiffy '-filter_save';
+use Filter4;
+
+my $result = $Spiffy::filter_result;
+my $expected = do { local $/; <DATA> };
+$result =~ s/\r//g;
+$expected =~ s/\r//g;
+is($result, $expected);
+
+__DATA__
+use strict;use warnings;my($bar,$bam);# comment
+
+sub foo {my $self = shift;
+ my $x = $self->$bar;
+}
+
+sub one {my $self = shift; }
+sub uno {my $self = shift;}
+$bar = sub {my $self = shift;
+ if (1) {
+ my $y = 1;
+ }
+};
+
+sub baz {
+ my $z = 1;
+}
+
+$bam = sub {my $self = shift;
+ $self->$bar(42);
+};
+;1;
--- /dev/null
+use lib 't', 'lib';
+use strict;
+
+use Test::More tests => 1;
+use Spiffy -filter_save;
+use Filter5;
+
+my $result = $Spiffy::filter_result;
+my $expected = do { local $/; <DATA> };
+$result =~ s/\r//g;
+$expected =~ s/\r//g;
+is($result, $expected);
+
+__DATA__
+use strict;use warnings;my($xxx,$yyy);$xxx = sub {my $self = shift;
+ $self->$xxx;
+ $self->$yyy;
+};
+$yyy = sub {my $self = shift;
+ $self->$xxx;
+ $self->$yyy
+};
+;1;
--- /dev/null
+use lib 't', 'lib';
+use strict;
+no strict 'refs';
+use warnings;
+
+package A;
+use Spiffy -base;
+field 'foo' => 17;
+
+package X;
+sub extra {99}
+
+package BB;
+use base 'X';
+sub xxx {42}
+sub yyy {}
+sub _zzz {}
+
+package C;
+use base 'A';
+use mixin 'BB';
+
+package main;
+use Test::More tests => 10;
+
+my $c = C->new;
+ok($c->can('foo'));
+is($c->foo, 17);
+ok($c->can('extra'));
+is($c->extra, 99);
+ok($c->can('xxx'));
+is($c->xxx, 42);
+ok(not $c->can('_zzz'));
+is(@{C::ISA}, 1);
+is(${C::ISA}[0], 'C-BB');
+is(${"C-BB::ISA"}[0], 'A');
--- /dev/null
+use lib 't', 'lib';
+use Spiffy ();
+package A;
+sub _role_a { qw(a1 a2 a3) }
+sub a1 {'a1' }
+sub a2 {'a2' }
+sub a3 {'a3' }
+sub _role_A { qw(A1 A2 A3) }
+sub A1 {'A1' }
+sub A2 {'A2' }
+sub A3 {'A3' }
+sub _role_aA { qw(:a :A foo) }
+sub foo {'foo'}
+
+package BB;
+use base 'A';
+
+package X;
+use mixin A => qw(:a !a2);
+
+package X2;
+use mixin BB => qw(:a !a2);
+
+package X3;
+use mixin A => qw(!:A A2);
+
+package X4;
+use mixin A => qw(:aA !a1 !a1 !A1);
+
+package X5;
+use mixin A => qw(!:a !:A);
+
+package main;
+use Test::More tests => 32;
+
+ok(X->can('a1'));
+ok(not X->can('a2'));
+ok(X->can('a3'));
+ok(not X->can('A1'));
+is(X->a1, 'a1');
+is(X->a3, 'a3');
+
+ok(X2->can('a1'));
+ok(not X2->can('a2'));
+ok(X2->can('a3'));
+ok(not X2->can('A1'));
+is(X2->a1, 'a1');
+is(X2->a3, 'a3');
+
+ok(X3->can('a1'));
+ok(X3->can('a2'));
+ok(X3->can('a3'));
+ok(not X3->can('A1'));
+ok(X3->can('A2'));
+ok(not X3->can('A3'));
+
+ok(not X4->can('a1'));
+ok(X4->can('a2'));
+ok(X4->can('a3'));
+ok(not X4->can('A1'));
+ok(X4->can('A2'));
+ok(X4->can('A3'));
+ok(X4->can('foo'));
+
+ok(not X5->can('a1'));
+ok(not X5->can('a2'));
+ok(not X5->can('a3'));
+ok(not X5->can('A1'));
+ok(not X5->can('A2'));
+ok(not X5->can('A3'));
+ok(X5->can('foo'));
--- /dev/null
+use lib 't', 'lib';
+package A;
+use Spiffy -Base;
+
+package B;
+use Spiffy -Base;
+field foo => 42;
+
+
+package main;
+use Test::More tests => 1;
+
+my $a = A->new;
+$a->mixin('B');
+is($a->foo, 42);
--- /dev/null
+use lib 't';
+use strict;
+use warnings;
+package A;
+use Spiffy -base;
+field 'x';
+field 'y';
+
+package main;
+use Test::More tests => 6;
+
+my $a1 = A->new;
+ok(not defined $a1->x);
+ok(not defined $a1->y);
+my $a2 = A->new(x => 5);
+is($a2->x, 5);
+ok(not defined $a2->y);
+my $a3 = A->new(x => 15, y => 10);
+is($a3->x, 15);
+is($a3->y, 10);
--- /dev/null
+use lib 'lib';
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+package Foo;
+use Spiffy -base => -package => 'Bar';
+
+package main;
+ok(not defined &Foo::field);
+ok(defined &Bar::field);
--- /dev/null
+use lib 'lib';
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Spiffy;
+
+my $args = Spiffy->parse_arguments();
+
+ok(ref $args && ref($args) eq 'HASH');
--- /dev/null
+use lib 't', 'lib';
+use strict;
+use warnings;
+
+package XXX;
+use Spiffy -base;
+stub 'foo';
+
+package YYY;
+use base 'XXX';
+
+package main;
+use Test::More tests => 1;
+
+my $y = YYY->new;
+eval {$y->foo};
+like($@, qr/subclassed/);
--- /dev/null
+use lib 'lib';
+
+package Foo;
+use strict;
+use Spiffy -base;
+field 'xxx';
+field 'dog';
+field 'bog';
+
+sub new {
+ my $self = super;
+ $self->xxx('XXX');
+ return $self;
+}
+
+sub poodle {
+ my $self = shift;
+ my $count = shift;
+ $self->dog("$count poodle");
+}
+
+sub doodle {
+ my $self = shift;
+ my $count = shift;
+ $self->bog("$count doodle");
+}
+
+package Bar;
+use strict;
+BEGIN { Foo->base }
+
+sub poodle {
+ my $self = shift;
+ super;
+ $self->dog($self->dog . ' dogs');
+}
+
+sub doodle {
+ my $self = shift;
+ eval 'eval "super"';
+ $self->bog($self->bog . ' bogs');
+}
+
+package main;
+use strict;
+use Test::More tests => 3;
+
+my $f = Bar->new;
+is($f->{xxx}, 'XXX');
+
+$f->poodle(3);
+is($f->{dog}, '3 poodle dogs');
+
+$f->doodle(4);
+is($f->{bog}, '4 doodle bogs');
--- /dev/null
+use lib 'lib';
+use strict;
+use warnings;
+
+package Alpha;
+use Spiffy -Base;
+
+sub three {
+ print "ok 6\n";
+}
+
+package Foo;
+use base 'Alpha';
+
+sub one {
+ super;
+ print "ok 2\n";
+}
+
+sub two {
+ print "ok 4\n";
+}
+
+package Bar;
+use base 'Foo';
+
+sub one {
+ super;
+ print "ok 3\n";
+}
+
+sub two {
+ super;
+ print "ok 5\n";
+}
+
+package Baz;
+use base 'Bar';
+
+sub one {
+ print "ok 1\n";
+ super;
+}
+
+sub two {
+ super;
+ print "not ok 6\n";
+}
+
+sub three {
+ super;
+ print "ok 7\n";
+}
+
+package main;
+use strict;
+print "1..7\n";
+Baz->new->one;
+Bar->new->two;
+Baz->new->three;
--- /dev/null
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+Format: 1.0
+Source: libspiffy-perl
+Binary: libspiffy-perl
+Architecture: all
+Version: 0.30-1
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: Florian Ragwitz <rafl@debian.org>, gregor herrmann <gregoa@debian.org>
+Homepage: http://search.cpan.org/dist/Spiffy/
+Standards-Version: 3.8.0
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libspiffy-perl/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libspiffy-perl/
+Build-Depends: debhelper (>= 5)
+Build-Depends-Indep: perl (>= 5.8.0-7)
+Checksums-Sha1:
+ 1d8fe20f2fcf1e8efc0a1259217a36f77527b9d6 27631 libspiffy-perl_0.30.orig.tar.gz
+ 6d29464fd453d828b730ce0709396685bb66487a 2922 libspiffy-perl_0.30-1.diff.gz
+Checksums-Sha256:
+ ce9374b6ba271efdc65d199298b04bd3a0c7e6e6504965ed86222dc5c80845b9 27631 libspiffy-perl_0.30.orig.tar.gz
+ 1ccd204cc8c076c6518c09eccdfab0c635cbb3816a4330197c4cb689d662684f 2922 libspiffy-perl_0.30-1.diff.gz
+Files:
+ 49860ccf2127c6d2af3d98560ffae644 27631 libspiffy-perl_0.30.orig.tar.gz
+ 7498a64fc2927cd80579357ca8c6ad22 2922 libspiffy-perl_0.30-1.diff.gz
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.9 (GNU/Linux)
+
+iEYEARECAAYFAkhX4vsACgkQOzKYnQDzz+SeYACeIQQIu695yi3BDqN2+oc/HHDf
+9kQAnjaN+RF5Xz1aX8qfT60csFjOhSbb
+=WZPi
+-----END PGP SIGNATURE-----
--- /dev/null
+Format: 1.0
+Source: libspiffy-perl
+Version: 0.30-1maemo1
+Binary: libspiffy-perl
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Architecture: all
+Standards-Version: 3.8.0
+Build-Depends: debhelper (>= 5)
+Build-Depends-Indep: perl (>= 5.8.0-7)
+Uploaders: Florian Ragwitz <rafl@debian.org>, gregor herrmann <gregoa@debian.org>
+Files:
+ 49860ccf2127c6d2af3d98560ffae644 27631 libspiffy-perl_0.30.orig.tar.gz
+ a3a3a00d05a84b8d1d3100726311c3e0 2999 libspiffy-perl_0.30-1maemo1.diff.gz
--- /dev/null
+Format: 1.7
+Date: Wed, 14 Apr 2010 07:08:42 +0100
+Source: libspiffy-perl
+Binary: libspiffy-perl
+Architecture: source all
+Version: 0.30-1maemo1
+Distribution: fremantle
+Urgency: low
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Changed-By: Nito Martinez <Nito@Qindel.ES>
+Description:
+ libspiffy-perl - Spiffy Perl Interface Framework For You
+Changes:
+ libspiffy-perl (0.30-1maemo1) fremantle; urgency=low
+ .
+ * New Maemo packaging
+Files:
+ 6c7183422d3c4d9d10dd7be14fa8b3e8 508 perl optional libspiffy-perl_0.30-1maemo1.dsc
+ a3a3a00d05a84b8d1d3100726311c3e0 2999 perl optional libspiffy-perl_0.30-1maemo1.diff.gz
+ 3953138558b8d17d3d381afb76757871 26018 perl optional libspiffy-perl_0.30-1maemo1_all.deb
--- /dev/null
+---
+version: 0.54
+date: Wed Nov 29 15:21:02 PST 2006
+changes:
+- Make dependency on Filter::Util::Call explicit in Makefile.PL
+ Thanks to Adriano Ferreira
+---
+version: 0.53
+date: Wed Nov 29 15:21:02 PST 2006
+changes:
+- Changes from miyagawa and crew
+---
+version: 0.52
+date: Mon Jun 19 10:44:53 PDT 2006
+changes:
+- Add use_ok to exports
+---
+version: 0.51
+date: Fri Jun 16 13:05:22 PDT 2006
+changes:
+- Remove build-requires dep of Spiffy for Module::Install::TestBase
+- Add in a patch from the good folk at Socialtext.
+---
+version: 0.50
+date: Mon Jan 30 10:52:52 PST 2006
+changes:
+- No change. 0.49 got borked on the way to CPAN
+---
+version: 0.49
+date: Mon Jan 30 10:52:48 PST 2006
+changes:
+- Added Module::Install::TestBase
+---
+version: 0.48
+date: Sun Jan 29 10:19:46 PST 2006
+changes:
+- Fixed test failures on windows
+---
+version: 0.47
+date: Thu Jan 19 10:59:37 PST 2006
+changes:
+- Depend on newer Spiffy 0.29
+---
+version: 0.46
+date: Sat Jan 14 05:46:31 PST 2006
+changes:
+- Don't sign the distribution tarball
+- Don't require the diffing stuff
+---
+version: 0.45
+date: Mon Jan 9 20:58:04 PST 2006
+changes:
+- Let multilevel inheritance work!
+- no_diff function turns off diffing.
+---
+version: 0.44
+date: Fri Jul 22 23:38:04 PDT 2005
+changes:
+- Bug fix in is_diff from rking
+- Allow Test::Base to be required without trying to run tests
+- allow ONLY|LAST|SKIP with run_* implicit names.
+---
+version: 0.43
+date: Sun Jun 19 03:14:40 PDT 2005
+changes:
+- change Test::Base::Filter::block to current_block.
+- change Test::Base::Filter::arguments to current_arguments.
+- add split and Split filters
+- add join and Join filters
+- add reverse and Reverse filters
+- add hash filter
+- allow (parens) around a data section name for readability.
+- allow regexps on split
+- allow for compact, one-line data sections
+- allow for repeated filters
+- detect sections names automatically
+- import XXX stuff into Filter class
+- add run_compare
+- automatically set no_plan sometimes
+- automatically run run_compare if no plan set at END
+- massive refactoring of all tests
+---
+version: 0.42
+date: Tue Jun 14 09:31:25 PDT 2005
+changes:
+- Make any block method callable with a dummy AUTOLOAD
+---
+version: 0.41
+date: Sun Jun 12 15:49:15 PDT 2005
+changes:
+- Add first_block() function
+- Split Test::Base::Filter into a separate module
+---
+version: 0.40
+date: Sat Jun 11 20:55:42 PDT 2005
+changes:
+- Change name from Test::Chunks to more lofty Test::Base
+- Change concept of "chunks" to "blocks"
+---
+version: 0.38
+date: Wed Jun 8 00:33:00 PDT 2005
+changes:
+- Allow simple substitutions on $_ in filters defined in `main::`
+- Add a filter_arguments() function
+- Fixed a undef warning in `is()`
+---
+version: 0.37
+date: Tue Jun 7 11:04:07 PDT 2005
+changes:
+- Implement rking style diff_is
+- Add filters: exec_perl_stdout
+---
+version: 0.36
+date: Sun Jun 5 11:49:54 PDT 2005
+changes:
+- add tie_output support
+- suppress warning in accessor
+- support backslash escapes in filter arguments
+- New filters: unchomp chop append eval_stdout eval_stderr eval_all
+- Add join string to join filter
+- Add a Test-Less index
+---
+version: 0.35
+date: Thu Jun 2 17:46:30 PDT 2005
+changes:
+- Subtle filter bug fixed
+---
+version: 0.34
+date: Sat May 28 23:55:49 PDT 2005
+changes:
+- Allow "late" call of `filters`.
+- Allow for appending filters that are predefined.
+---
+version: 0.33
+date: Sat May 28 23:55:41 PDT 2005
+changes:
+- Support `next_chunk` iterator.
+---
+version: 0.32
+date: Tue May 24 08:03:57 PDT 2005
+changes:
+- Add a method to access filter arguments
+- Curry `use` args to Test::More
+- Change base64 filter to base64_decode base64_encode
+- Apply filter just before dispatch in run()
+- Apply filters in order
+- Default to Test::Chunks inline classes for subclassing modules (for
+ Filter and Chunks)
+---
+version: 0.31
+date: Mon May 23 20:48:28 PDT 2005
+changes:
+- Guess names for chunk_class and filter_class. Easier subclassing.
+---
+version: 0.30
+date: Mon May 23 16:39:23 PDT 2005
+changes:
+- Further delay filtering by no running filters when chunks is called in
+ scalar context.
+---
+version: 0.29
+date: Sun May 22 21:30:02 PDT 2005
+changes:
+- add filters_delay function
+- add run_filters method to Test::Chunks::Chunk
+- Refactor many methods into Test::Chunks::Chunk
+- Expose internals to the filter methods by providing a `chunk` method to the
+ Filter object.
+---
+version: 0.28
+date: Wed May 11 17:13:19 PDT 2005
+changes:
+- Make running of the filters be lazy to avoid undesired side effects when not
+ running all tests. May want to be even lazier in the future...
+---
+version: 0.27
+date: Tue May 10 17:01:18 PDT 2005
+changes:
+- Added run_unlike
+---
+version: 0.26
+date: Mon May 9 07:57:58 PDT 2005
+changes:
+- Embed perl code in a test specification. This is still experimental and
+ undocumented.
+---
+version: 0.25
+date:
+changes:
+- Add `LAST` special section name to stop at a certain test.
+- Add test for strict/warnings filter.
+- Change 'description' method to 'name'.
+- Add a description method for the multiline description.
+---
+version: 0.24
+date: Thu May 5 01:54:29 PDT 2005
+changes:
+- Refactored delimiter default handling
+---
+version: 0.23
+date: Thu May 5 00:33:32 PDT 2005
+changes:
+- Make Test::Chunks more subclassable
+- Add join filter
+- General Refactorings
+---
+version: 0.22
+date: Tue May 3 12:32:39 PDT 2005
+changes:
+- Support a grepping feature for `chunks()`
+- Ignore chunks that don't contain a specified data section for `run_*`
+ functions.
+---
+version: 0.21
+date: Mon May 2 12:29:48 PDT 2005
+changes:
+- Deprecate filters_map and just use filters with a map.
+---
+version: 0.20
+date: Mon May 2 00:08:17 PDT 2005
+changes:
+- Added list context to filters. Very powerful stuff.
+---
+version: 0.19
+date: Sat Apr 30 17:27:09 PDT 2005
+changes:
+- Add regexp flag tests
+- Change -XXX to :XXX and use better Spiffy 0.24
+---
+version: 0.18
+date: Sat Apr 30 17:27:09 PDT 2005
+changes:
+- Support run_is_deeply
+---
+version: 0.17
+date: Sat Apr 30 12:16:03 PDT 2005
+changes:
+- Allow user filters to be plain functions
+- Add run_like
+- Add regexp and get_url filters
+- Allow run* functions to work as methods
+- Remove diff_is() until implemented
+---
+version: 0.16
+date: Fri Apr 29 20:04:24 PDT 2005
+changes:
+- added run_is for common equality tests
+- strict and dumper filters
+- Can't use `Spiffy -XXX` until Spiffy exporting is fixed.
+---
+version: 0.15
+date: Wed Apr 27 23:50:50 PDT 2005
+changes:
+- export everything Test::More does.
+- croak if things get called in the wrong order.
+---
+version: 0.14
+date: Wed Apr 27 12:22:45 PDT 2005
+changes:
+- Move filters into the Test::Chunks::Filter class
+---
+version: 0.13
+date: Mon Apr 25 11:14:27 PDT 2005
+changes:
+- add eval, yaml, list and lines filters
+- support a filter_map for more flexibility
+---
+version: 0.12
+date: Fri Apr 22 00:12:21 PDT 2005
+changes:
+- finished the tests
+- automagically add strict and warnings to every test script
+---
+version: 0.11
+date: Thu Apr 21 11:26:32 PDT 2005
+changes:
+- added delimiters() spec_file() spec_string() filters() functions
+- implemented nice filters system
+- lots more tests
+- finished the doc
+---
+version: 0.10
+date: Wed Apr 20 18:05:42 PDT 2005
+changes:
+- Initial version of Test::Chunks
--- /dev/null
+Changes
+inc/Module/Install.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/Module/Install/TestBase.pm
+lib/Test/Base.pm
+lib/Test/Base/Filter.pm
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+t/append.t
+t/arguments.t
+t/array.t
+t/autoload.t
+t/base64.t
+t/BaseTest.pm
+t/blocks-scalar.t
+t/blocks_grep.t
+t/chomp.t
+t/chop.t
+t/compact.t
+t/compile.t
+t/delimiters.t
+t/description.t
+t/diff_is.t
+t/dos_spec
+t/dumper.t
+t/embed_perl.t
+t/escape.t
+t/eval.t
+t/eval_all.t
+t/eval_stderr.t
+t/eval_stdout.t
+t/export.t
+t/filter_arguments.t
+t/filter_delay.t
+t/filter_functions.t
+t/filters-append.t
+t/filters.t
+t/filters_map.t
+t/first_block.t
+t/flatten.t
+t/get_url.t
+t/hash.t
+t/head.t
+t/internals.t
+t/is.t
+t/jit-run.t
+t/join-deep.t
+t/join.t
+t/last.t
+t/late.t
+t/lazy-filters.t
+t/lines.t
+t/list.t
+t/main_filters.t
+t/multi-level-inherit.t
+t/name.t
+t/next.t
+t/no_diff.t
+t/no_plan.t
+t/normalize.t
+t/only-with-implicit.t
+t/only.t
+t/oo.t
+t/oo_run.t
+t/parentheses.t
+t/prepend.t
+t/preserve-order.t
+t/prototypes.t
+t/quick-plan.t
+t/quick_test.t
+t/read_file.t
+t/regexp.t
+t/repeated-filters.t
+t/require.t
+t/reserved_names.t
+t/reverse-deep.t
+t/reverse.t
+t/run-args.t
+t/run_compare.t
+t/run_is.t
+t/run_is_deeply.t
+t/run_like.t
+t/run_unlike.t
+t/sample-file.txt
+t/simple.t
+t/skip.t
+t/slice.t
+t/sort-deep.t
+t/sort.t
+t/spec1
+t/spec2
+t/spec_file.t
+t/spec_string.t
+t/split-deep.t
+t/split-regexp.t
+t/split.t
+t/strict-warnings.t
+t/strict-warnings.test
+t/strict.t
+t/subclass-autoclass.t
+t/subclass-import.t
+t/Subclass.pm
+t/subclass.t
+t/subclass_late.t
+t/tail.t
+t/Test-Less/index.txt
+t/TestA.pm
+t/TestB.pm
+t/TestBass.pm
+t/TestC.pm
+t/tie_output.t
+t/trim.t
+t/unchomp.t
+t/use-test-more.t
+t/write_file.t
+t/xxx.t
+t/yaml.t
+t/zero-blocks.t
--- /dev/null
+abstract: A Data Driven Testing Framework
+author: "Ingy d\xC3\xB6t Net <ingy@cpan.org>"
+distribution_type: module
+generated_by: Module::Install version 0.64
+license: perl
+name: Test-Base
+no_index:
+ directory:
+ - inc
+ - t
+requires:
+ Filter::Util::Call: 0
+ Spiffy: 0.30
+ Test::More: 0.62
+ perl: 5.6.1
+version: 0.54
--- /dev/null
+use inc::Module::Install;
+
+name 'Test-Base';
+all_from 'lib/Test/Base.pm';
+
+requires perl => '5.6.1';
+requires Spiffy => '0.30';
+requires Test::More => '0.62';
+requires Filter::Util::Call => '0';
+
+clean_files 't/output';
+
+WriteAll;
--- /dev/null
+NAME
+ Test::Base - A Data Driven Testing Framework
+
+SYNOPSIS
+ A new test module:
+
+ # lib/MyProject/Test.pm
+ package MyProject::Test;
+ use Test::Base -Base;
+
+ use MyProject;
+
+ package MyProject::Test::Filter;
+ use Test::Base::Filter -base;
+
+ sub my_filter {
+ return MyProject->do_something(shift);
+ }
+
+ A sample test:
+
+ # t/sample.t
+ use MyProject::Test;
+
+ plan tests => 1 * blocks;
+
+ run_is input => 'expected';
+
+ sub local_filter {
+ s/my/your/;
+ }
+
+ __END__
+
+ === Test one (the name of the test)
+ --- input my_filter local_filter
+ my
+ input
+ lines
+ --- expected
+ expected
+ output
+
+ === Test two
+ This is an optional description
+ of this particular test.
+ --- input my_filter
+ other
+ input
+ lines
+ --- expected
+ other expected
+ output
+
+DESCRIPTION
+ Testing is usually the ugly part of Perl module authoring. Perl gives
+ you a standard way to run tests with Test::Harness, and basic testing
+ primitives with Test::More. After that you are pretty much on your own
+ to develop a testing framework and philosophy. Test::More encourages you
+ to make your own framework by subclassing Test::Builder, but that is not
+ trivial.
+
+ Test::Base gives you a way to write your own test framework base class
+ that *is* trivial. In fact it is as simple as two lines:
+
+ package MyTestFramework;
+ use Test::Base -Base;
+
+ A module called "MyTestFramework.pm" containing those two lines, will
+ give all the power of Test::More and all the power of Test::Base to
+ every test file that uses it. As you build up the capabilities of
+ "MyTestFramework", your tests will have all of that power as well.
+
+ "MyTestFramework" becomes a place for you to put all of your reusable
+ testing bits. As you write tests, you will see patterns and duplication,
+ and you can "upstream" them into "MyTestFramework". Of course, you don't
+ have to subclass Test::Base at all. You can use it directly in many
+ applications, including everywhere you would use Test::More.
+
+ Test::Base concentrates on offering reusable data driven patterns, so
+ that you can write tests with a minimum of code. At the heart of all
+ testing you have inputs, processes and expected outputs. Test::Base
+ provides some clean ways for you to express your input and expected
+ output data, so you can spend your time focusing on that rather than
+ your code scaffolding.
+
+EXPORTED FUNCTIONS
+ Test::Base extends Test::More and exports all of its functions. So you
+ can basically write your tests the same as Test::More. Test::Base also
+ exports many functions of its own:
+
+ is(actual, expected, [test-name])
+ This is the equivalent of Test::More's "is" function with one
+ interesting twist. If your actual and expected results differ and the
+ output is multi-line, this function will show you a unified diff format
+ of output. Consider the benefit when looking for the one character that
+ is different in hundreds of lines of output!
+
+ Diff output requires the optional "Text::Diff" CPAN module. If you don't
+ have this module, the "is()" function will simply give you normal
+ Test::More output. To disable diffing altogether, set the
+ "TEST_SHOW_NO_DIFFS" environment variable (or $ENV{TEST_SHOW_NO_DIFFS})
+ to a true value. You can also call the "no_diff" function as a shortcut.
+
+ blocks( [data-section-name] )
+ The most important function is "blocks". In list context it returns a
+ list of "Test::Base::Block" objects that are generated from the test
+ specification in the "DATA" section of your test file. In scalar context
+ it returns the number of objects. This is useful to calculate your
+ Test::More plan.
+
+ Each Test::Base::Block object has methods that correspond to the names
+ of that object's data sections. There is also a "name" and a
+ "description" method for accessing those parts of the block if they were
+ specified.
+
+ The "blocks" function can take an optional single argument, that
+ indicates to only return the blocks that contain a particular named data
+ section. Otherwise "blocks" returns all blocks.
+
+ my @all_of_my_blocks = blocks;
+
+ my @just_the_foo_blocks = blocks('foo');
+
+ next_block()
+ You can use the next_block function to iterate over all the blocks.
+
+ while (my $block = next_block) {
+ ...
+ }
+
+ It returns undef after all blocks have been iterated over. It can then
+ be called again to reiterate.
+
+ first_block()
+ Returns the first block or undef if there are none. It resets the
+ iterator to the "next_block" function.
+
+ run(&subroutine)
+ There are many ways to write your tests. You can reference each block
+ individually or you can loop over all the blocks and perform a common
+ operation. The "run" function does the looping for you, so all you need
+ to do is pass it a code block to execute for each block.
+
+ The "run" function takes a subroutine as an argument, and calls the sub
+ one time for each block in the specification. It passes the current
+ block object to the subroutine.
+
+ run {
+ my $block = shift;
+ is(process($block->foo), $block->bar, $block->name);
+ };
+
+ run_is([data_name1, data_name2])
+ Many times you simply want to see if two data sections are equivalent in
+ every block, probably after having been run through one or more filters.
+ With the "run_is" function, you can just pass the names of any two data
+ sections that exist in every block, and it will loop over every block
+ comparing the two sections.
+
+ run_is 'foo', 'bar';
+
+ If no data sections are given "run_is" will try to detect them
+ automatically.
+
+ NOTE: Test::Base will silently ignore any blocks that don't contain both
+ sections.
+
+ run_is_deeply([data_name1, data_name2])
+ Like "run_is" but uses "is_deeply" for complex data structure
+ comparison.
+
+ run_like([data_name, regexp | data_name]);
+ The "run_like" function is similar to "run_is" except the second
+ argument is a regular expression. The regexp can either be a "qr{}"
+ object or a data section that has been filtered into a regular
+ expression.
+
+ run_like 'foo', qr{<html.*};
+ run_like 'foo', 'match';
+
+ run_unlike([data_name, regexp | data_name]);
+ The "run_unlike" function is similar to "run_like", except the opposite.
+
+ run_unlike 'foo', qr{<html.*};
+ run_unlike 'foo', 'no_match';
+
+ run_compare(data_name1, data_name2)
+ The "run_compare" function is like the "run_is", "run_is_deeply" and the
+ "run_like" functions all rolled into one. It loops over each relevant
+ block and determines what type of comparison to do.
+
+ NOTE: If you do not specify either a plan, or run any tests, the
+ "run_compare" function will automatically be run.
+
+ delimiters($block_delimiter, $data_delimiter)
+ Override the default delimiters of "===" and "---".
+
+ spec_file($file_name)
+ By default, Test::Base reads its input from the DATA section. This
+ function tells it to get the spec from a file instead.
+
+ spec_string($test_data)
+ By default, Test::Base reads its input from the DATA section. This
+ function tells it to get the spec from a string that has been prepared
+ somehow.
+
+ filters( @filters_list or $filters_hashref )
+ Specify a list of additional filters to be applied to all blocks. See
+ FILTERS below.
+
+ You can also specify a hash ref that maps data section names to an array
+ ref of filters for that data type.
+
+ filters {
+ xxx => [qw(chomp lines)],
+ yyy => ['yaml'],
+ zzz => 'eval',
+ };
+
+ If a filters list has only one element, the array ref is optional.
+
+ filters_delay( [1 | 0] );
+ By default Test::Base::Block objects are have all their filters run
+ ahead of time. There are testing situations in which it is advantageous
+ to delay the filtering. Calling this function with no arguments or a
+ true value, causes the filtering to be delayed.
+
+ use Test::Base;
+ filters_delay;
+ plan tests => 1 * blocks;
+ for my $block (blocks) {
+ ...
+ $block->run_filters;
+ ok($block->is_filtered);
+ ...
+ }
+
+ In the code above, the filters are called manually, using the
+ "run_filters" method of Test::Base::Block. In functions like "run_is",
+ where the tests are run automatically, filtering is delayed until right
+ before the test.
+
+ filter_arguments()
+ Return the arguments after the equals sign on a filter.
+
+ sub my_filter {
+ my $args = filter_arguments;
+ # is($args, 'whazzup');
+ ...
+ }
+
+ __DATA__
+ === A test
+ --- data my_filter=whazzup
+
+ tie_output()
+ You can capture STDOUT and STDERR for operations with this function:
+
+ my $out = '';
+ tie_output(*STDOUT, $buffer);
+ print "Hey!\n";
+ print "Che!\n";
+ untie *STDOUT;
+ is($out, "Hey!\nChe!\n");
+
+ no_diff()
+ Turn off diff support for is() in a test file.
+
+ default_object()
+ Returns the default Test::Base object. This is useful if you feel the
+ need to do an OO operation in otherwise functional test code. See OO
+ below.
+
+ WWW() XXX() YYY() ZZZ()
+ These debugging functions are exported from the Spiffy.pm module. See
+ Spiffy for more info.
+
+ croak() carp() cluck() confess()
+ You can use the functions from the Carp module without needing to import
+ them. Test::Base does it for you by default.
+
+TEST SPECIFICATION
+ Test::Base allows you to specify your test data in an external file, the
+ DATA section of your program or from a scalar variable containing all
+ the text input.
+
+ A *test specification* is a series of text lines. Each test (or block)
+ is separated by a line containing the block delimiter and an optional
+ test "name". Each block is further subdivided into named sections with a
+ line containing the data delimiter and the data section name. A
+ "description" of the test can go on lines after the block delimiter but
+ before the first data section.
+
+ Here is the basic layout of a specification:
+
+ === <block name 1>
+ <optional block description lines>
+ --- <data section name 1> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name 2> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name n> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+
+ === <block name 2>
+ <optional block description lines>
+ --- <data section name 1> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name 2> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name n> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+
+ Here is a code example:
+
+ use Test::Base;
+
+ delimiters qw(### :::);
+
+ # test code here
+
+ __END__
+
+ ### Test One
+ We want to see if foo and bar
+ are really the same...
+ ::: foo
+ a foo line
+ another foo line
+
+ ::: bar
+ a bar line
+ another bar line
+
+ ### Test Two
+
+ ::: foo
+ some foo line
+ some other foo line
+
+ ::: bar
+ some bar line
+ some other bar line
+
+ ::: baz
+ some baz line
+ some other baz line
+
+ This example specifies two blocks. They both have foo and bar data
+ sections. The second block has a baz component. The block delimiter is
+ "###" and the data delimiter is ":::".
+
+ The default block delimiter is "===" and the default data delimiter is
+ "---".
+
+ There are some special data section names used for control purposes:
+
+ --- SKIP
+ --- ONLY
+ --- LAST
+
+ A block with a SKIP section causes that test to be ignored. This is
+ useful to disable a test temporarily.
+
+ A block with an ONLY section causes only that block to be used. This is
+ useful when you are concentrating on getting a single test to pass. If
+ there is more than one block with ONLY, the first one will be chosen.
+
+ Because ONLY is very useful for debugging and sometimes you forgot to
+ remove the ONLY flag before commiting to the VCS or uploading to CPAN,
+ Test::Base by default gives you a diag message saying *I found ONLY ...
+ maybe you're debugging?*. If you don't like it, use "no_diag_on_only".
+
+ A block with a LAST section makes that block the last one in the
+ specification. All following blocks will be ignored.
+
+FILTERS
+ The real power in writing tests with Test::Base comes from its filtering
+ capabilities. Test::Base comes with an ever growing set of useful
+ generic filters than you can sequence and apply to various test blocks.
+ That means you can specify the block serialization in the most readable
+ format you can find, and let the filters translate it into what you
+ really need for a test. It is easy to write your own filters as well.
+
+ Test::Base allows you to specify a list of filters to each data section
+ of each block. The default filters are "norm" and "trim". These filters
+ will be applied (in order) to the data after it has been parsed from the
+ specification and before it is set into its Test::Base::Block object.
+
+ You can add to the default filter list with the "filters" function. You
+ can specify additional filters to a specific block by listing them after
+ the section name on a data section delimiter line.
+
+ Example:
+
+ use Test::Base;
+
+ filters qw(foo bar);
+ filters { perl => 'strict' };
+
+ sub upper { uc(shift) }
+
+ __END__
+
+ === Test one
+ --- foo trim chomp upper
+ ...
+
+ --- bar -norm
+ ...
+
+ --- perl eval dumper
+ my @foo = map {
+ - $_;
+ } 1..10;
+ \ @foo;
+
+ Putting a "-" before a filter on a delimiter line, disables that filter.
+
+ Scalar vs List
+ Each filter can take either a scalar or a list as input, and will return
+ either a scalar or a list. Since filters are chained together, it is
+ important to learn which filters expect which kind of input and return
+ which kind of output.
+
+ For example, consider the following filter list:
+
+ norm trim lines chomp array dumper eval
+
+ The data always starts out as a single scalar string. "norm" takes a
+ scalar and returns a scalar. "trim" takes a list and returns a list, but
+ a scalar is a valid list. "lines" takes a scalar and returns a list.
+ "chomp" takes a list and returns a list. "array" takes a list and
+ returns a scalar (an anonymous array reference containing the list
+ elements). "dumper" takes a list and returns a scalar. "eval" takes a
+ scalar and creates a list.
+
+ A list of exactly one element works fine as input to a filter requiring
+ a scalar, but any other list will cause an exception. A scalar in list
+ context is considered a list of one element.
+
+ Data accessor methods for blocks will return a list of values when used
+ in list context, and the first element of the list in scalar context.
+ This is usually "the right thing", but be aware.
+
+ The Stock Filters
+ Test::Base comes with large set of stock filters. They are in the
+ "Test::Base::Filter" module. See Test::Base::Filter for a listing and
+ description of these filters.
+
+ Rolling Your Own Filters
+ Creating filter extensions is very simple. You can either write a
+ *function* in the "main" namespace, or a *method* in the
+ "Test::Base::Filter" namespace or a subclass of it. In either case the
+ text and any extra arguments are passed in and you return whatever you
+ want the new value to be.
+
+ Here is a self explanatory example:
+
+ use Test::Base;
+
+ filters 'foo', 'bar=xyz';
+
+ sub foo {
+ transform(shift);
+ }
+
+ sub Test::Base::Filter::bar {
+ my $self = shift; # The Test::Base::Filter object
+ my $data = shift;
+ my $args = $self->current_arguments;
+ my $current_block_object = $self->block;
+ # transform $data in a barish manner
+ return $data;
+ }
+
+ If you use the method interface for a filter, you can access the block
+ internals by calling the "block" method on the filter object.
+
+ Normally you'll probably just use the functional interface, although all
+ the builtin filters are methods.
+
+ Note that filters defined in the "main" namespace can look like:
+
+ sub filter9 {
+ s/foo/bar/;
+ }
+
+ since Test::Base automatically munges the input string into $_ variable
+ and checks the return value of the function to see if it looks like a
+ number. If you must define a filter that returns just a single number,
+ do it in a different namespace as a method. These filters don't allow
+ the simplistic $_ munging.
+
+OO
+ Test::Base has a nice functional interface for simple usage. Under the
+ hood everything is object oriented. A default Test::Base object is
+ created and all the functions are really just method calls on it.
+
+ This means if you need to get fancy, you can use all the object oriented
+ stuff too. Just create new Test::Base objects and use the functions as
+ methods.
+
+ use Test::Base;
+ my $blocks1 = Test::Base->new;
+ my $blocks2 = Test::Base->new;
+
+ $blocks1->delimiters(qw(!!! @@@))->spec_file('test1.txt');
+ $blocks2->delimiters(qw(### $$$))->spec_string($test_data);
+
+ plan tests => $blocks1->blocks + $blocks2->blocks;
+
+ # ... etc
+
+THE "Test::Base::Block" CLASS
+ In Test::Base, blocks are exposed as Test::Base::Block objects. This
+ section lists the methods that can be called on a Test::Base::Block
+ object. Of course, each data section name is also available as a method.
+
+ name()
+ This is the optional short description of a block, that is specified on
+ the block separator line.
+
+ description()
+ This is an optional long description of the block. It is the text taken
+ from between the block separator and the first data section.
+
+ seq_num()
+ Returns a sequence number for this block. Sequence numbers begin with 1.
+
+ blocks_object()
+ Returns the Test::Base object that owns this block.
+
+ run_filters()
+ Run the filters on the data sections of the blocks. You don't need to
+ use this method unless you also used the "filters_delay" function.
+
+ is_filtered()
+ Returns true if filters have already been run for this block.
+
+ original_values()
+ Returns a hash of the original, unfiltered values of each data section.
+
+SUBCLASSING
+ One of the nicest things about Test::Base is that it is easy to
+ subclass. This is very important, because in your personal project, you
+ will likely want to extend Test::Base with your own filters and other
+ reusable pieces of your test framework.
+
+ Here is an example of a subclass:
+
+ package MyTestStuff;
+ use Test::Base -Base;
+
+ our @EXPORT = qw(some_func);
+
+ sub some_func {
+ (my ($self), @_) = find_my_self(@_);
+ ...
+ }
+
+ package MyTestStuff::Block;
+ use base 'Test::Base::Block';
+
+ sub desc {
+ $self->description(@_);
+ }
+
+ package MyTestStuff::Filter;
+ use base 'Test::Base::Filter';
+
+ sub upper {
+ $self->assert_scalar(@_);
+ uc(shift);
+ }
+
+ Note that you don't have to re-Export all the functions from Test::Base.
+ That happens automatically, due to the powers of Spiffy.
+
+ The first line in "some_func" allows it to be called as either a
+ function or a method in the test code.
+
+DISTRIBUTION SUPPORT
+ You might be thinking that you do not want to use Test::Base in you
+ modules, because it adds an installation dependency. Fear not.
+ Module::Install takes care of that.
+
+ Just write a Makefile.PL that looks something like this:
+
+ use inc::Module::Install;
+
+ name 'Foo';
+ all_from 'lib/Foo.pm';
+
+ use_test_base;
+
+ WriteAll;
+
+ The line with "use_test_base" will automatically bundle all the code the
+ user needs to run Test::Base based tests.
+
+OTHER COOL FEATURES
+ Test::Base automatically adds:
+
+ use strict;
+ use warnings;
+
+ to all of your test scripts and Test::Base subclasses. A Spiffy feature
+ indeed.
+
+HISTORY
+ This module started its life with the horrible and ridicule inducing
+ name "Test::Chunks". It was renamed to "Test::Base" with the hope that
+ it would be seen for the very useful module that it has become. If you
+ are switching from "Test::Chunks" to "Test::Base", simply substitute the
+ concept and usage of "chunks" to "blocks".
+
+AUTHOR
+ Ingy döt Net <ingy@cpan.org>
+
+COPYRIGHT
+ Copyright (c) 2006. Ingy döt Net. All rights reserved. Copyright (c)
+ 2005. Brian Ingerson. All rights reserved.
+
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+ See http://www.perl.com/perl/misc/Artistic.html
+
--- /dev/null
+libtest-base-perl (0.54-1maemo1) fremantle; urgency=low
+
+ * New Maemo packaging
+
+ -- Nito Martinez <Nito@Qindel.ES> Wed, 14 Apr 2010 07:07:08 +0100
+
+
+llibtest-base-perl (0.54-1) unstable; urgency=low
+
+ [ gregor herrmann ]
+ * Take over for the Debian Perl Group with maintainer's permission
+ (http://lists.debian.org/debian-perl/2008/06/msg00039.html)
+ * debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser
+ field (source stanza); Homepage field (source stanza). Changed:
+ Maintainer set to Debian Perl Group <pkg-perl-
+ maintainers@lists.alioth.debian.org> (was: Florian Ragwitz
+ <rafl@debian.org>); Florian Ragwitz <rafl@debian.org> moved to
+ Uploaders.
+ * Add debian/watch.
+
+ [ Damyan Ivanov ]
+ * New upstream release
+ Make the (build-)dependency on libspiffy-perl versioned
+ * add libyaml-perl to B-D-I enabling additional tests
+ * trim debian/rules using debhelper 7
+ * add myself to Uploaders
+ * Standards-Version: 3.8.0 (no changes needed)
+
+ -- Damyan Ivanov <dmn@debian.org> Tue, 01 Jul 2008 13:30:24 +0300
+
+libtest-base-perl (0.47-1.1) unstable; urgency=low
+
+ * Non-maintainer upload.
+ * Empty dir is gone (closes: #467774)
+ * Fix failing test to skip for now: Maintainer: please look
+ * utf-8-ize debian/changelog
+ * Update Standards-Version (no changes)
+
+ -- Stephen Gran <sgran@debian.org> Sun, 06 Apr 2008 01:56:24 +0100
+
+libtest-base-perl (0.47-1) unstable; urgency=low
+
+ * Initial release.
+
+ -- Florian Ragwitz <rafl@debian.org> Tue, 24 Jan 2006 02:13:08 +0100
--- /dev/null
+Source: libtest-base-perl
+Section: perl
+Priority: optional
+Build-Depends: debhelper7
+Build-Depends-Indep: perl (>= 5.6), libspiffy-perl (>= 0.30),
+ libtest-simple-perl (>= 0.62), libalgorithm-diff-perl, libtext-diff-perl,
+ libyaml-perl
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: Florian Ragwitz <rafl@debian.org>, Damyan Ivanov <dmn@debian.org>
+Standards-Version: 3.8.0
+Homepage: http://search.cpan.org/dist/Test-Base/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libtest-base-perl/
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-base-perl/
+
+Package: libtest-base-perl
+Architecture: all
+Depends: ${perl:Depends}, libspiffy-perl (>= 0.30), libalgorithm-diff-perl, libtext-diff-perl, libtest-simple-perl (>= 0.6.2)
+Description: A data driven testing framework for Perl
+ Testing is usually the ugly part of Perl module authoring. Perl gives you a
+ standard way to run tests with Test::Harness, and basic testing primitives
+ with Test::More. After that you are pretty much on your own to develop a
+ testing framework and philosophy. Test::More encourages you to make your own
+ framework by subclassing Test::Builder, but that is not trivial.
+ .
+ Test::Base gives you a way to write your own test framework base class that is
+ trivial. In fact it is as simple as two lines:
+ package MyTestFramework;
+ use Test::Base -Base;
+ .
+ A module called MyTestFramework.pm containing those two lines, will give all
+ the power of Test::More and all the power of Test::Base to every test file
+ that uses it. As you build up the capabilities of MyTestFramework, your tests
+ will have all of that power as well.
+ .
+ MyTestFramework becomes a place for you to put all of your reusable testing
+ bits. As you write tests, you will see patterns and duplication, and you can
+ "upstream" them into MyTestFramework. Of course, you don't have to subclass
+ Test::Base at all. You can use it directly in many applications, including
+ everywhere you would use Test::More.
+ .
+ Test::Base concentrates on offering reusable data driven patterns, so that you
+ can write tests with a minimum of code. At the heart of all testing you have
+ inputs, processes and expected outputs. Test::Base provides some clean ways
+ for you to express your input and expected output data, so you can spend your
+ time focusing on that rather than your code scaffolding.
--- /dev/null
+This is the debian package for the Test::Base Perl module.
+
+Florian Ragwitz <rafl@debian.org> created this Debian package using
+original Test::Base sources, as found on the Comprehensive Perl Archive
+Network (CPAN) <URL:http://cpan.org/>.
+
+The upstream author is Ingy döt Net <ingy@cpan.org>.
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+Copyright (c) 2005. Brian Ingerson. All rights reserved.
+
+libtest-base-perl may be redistributed under the terms of either the GNU
+General Public License or the Artistic License. On a Debian GNU/Linux
+systems, the complete text of these licenses may be found in the files
+/usr/share/common-licenses/{GPL,Artistic}.
--- /dev/null
+#!/usr/bin/make -f
+
+build: build-stamp
+build-stamp:
+ dh build
+ touch $@
+
+clean:
+ dh $@
+
+install: install-stamp
+install-stamp: build-stamp
+ dh install
+ touch $@
+
+binary-arch:
+
+binary-indep: install
+ dh $@
+
+binary: binary-arch binary-indep
+
+.PHONY: binary binary-arch binary-indep install clean build
--- /dev/null
+version=3
+http://search.cpan.org/dist/Test-Base/ .+/Test-Base-v?(\d[\d_.-]+)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)$
--- /dev/null
+#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.004;
+use strict 'vars';
+
+use vars qw{$VERSION};
+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.64';
+}
+
+# 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 and (stat($0))[9] > time ) {
+ die << "END_DIE";
+Your installer $0 has a modification time in the future.
+
+This is known to create infinite loops in make.
+
+Please correct this, then run $0 again.
+
+END_DIE
+}
+
+use Cwd ();
+use File::Find ();
+use File::Path ();
+use FindBin;
+
+*inc::Module::Install::VERSION = *VERSION;
+@inc::Module::Install::ISA = __PACKAGE__;
+
+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";
+ unshift @_, ($self, $1);
+ goto &{$self->can('call')} unless uc($1) eq $1;
+ };
+}
+
+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"};
+}
+
+sub preload {
+ my ($self) = @_;
+
+ unless ( $self->{extensions} ) {
+ $self->load_extensions(
+ "$self->{prefix}/$self->{path}", $self
+ );
+ }
+
+ my @exts = @{$self->{extensions}};
+ unless ( @exts ) {
+ my $admin = $self->{admin};
+ @exts = $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";
+
+ 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 { 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) ) {
+ open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!";
+ my $in_pod = 0;
+ while ( <PKGFILE> ) {
+ $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;
+ }
+ }
+ close PKGFILE;
+ }
+
+ push @found, [ $file, $pkg ];
+ }, $path ) if -d $path;
+
+ @found;
+}
+
+sub _caller {
+ my $depth = 0;
+ my $call = caller($depth);
+ while ( $call eq __PACKAGE__ ) {
+ $depth++;
+ $call = caller($depth);
+ }
+ return $call;
+}
+
+1;
--- /dev/null
+#line 1
+package Module::Install::Base;
+
+$VERSION = '0.64';
+
+# Suspend handler for "redefined" warnings
+BEGIN {
+ my $w = $SIG{__WARN__};
+ $SIG{__WARN__} = sub { $w };
+}
+
+### This is the ONLY module that shouldn't have strict on
+# use strict;
+
+#line 41
+
+sub new {
+ my ($class, %args) = @_;
+
+ foreach my $method ( qw(call load) ) {
+ *{"$class\::$method"} = sub {
+ shift()->_top->$method(@_);
+ } unless defined &{"$class\::$method"};
+ }
+
+ bless( \%args, $class );
+}
+
+#line 61
+
+sub AUTOLOAD {
+ my $self = shift;
+ local $@;
+ my $autoload = eval { $self->_top->autoload } or return;
+ goto &$autoload;
+}
+
+#line 76
+
+sub _top { $_[0]->{_top} }
+
+#line 89
+
+sub admin {
+ $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new;
+}
+
+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 138
--- /dev/null
+#line 1
+package Module::Install::Can;
+
+use strict;
+use Module::Install::Base;
+use Config ();
+### This adds a 5.005 Perl version dependency.
+### This is a bug and will be fixed.
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.64';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# 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}), '.') {
+ 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 157
--- /dev/null
+#line 1
+package Module::Install::Fetch;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.64';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+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;
--- /dev/null
+#line 1
+package Module::Install::Makefile;
+
+use strict 'vars';
+use Module::Install::Base;
+use ExtUtils::MakeMaker ();
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.64';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+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, @_ ) if @_;
+ $args;
+}
+
+# For mm args that take multiple space-seperated args,
+# append an argument to the current list.
+sub makemaker_append {
+ my $self = shift;
+ 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 );
+}
+
+sub write {
+ my $self = shift;
+ die "&Makefile->write() takes no arguments\n" if @_;
+
+ my $args = $self->makemaker_args;
+ $args->{DISTNAME} = $self->name;
+ $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args);
+ $args->{VERSION} = $self->version || $self->determine_VERSION($args);
+ $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->build_requires, $self->requires) );
+
+ # 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";
+ }
+
+ my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args;
+ if ($self->admin->preop) {
+ $args{dist} = $self->admin->preop;
+ }
+
+ 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 $/; <MAKEFILE> };
+ 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 334
--- /dev/null
+#line 1
+package Module::Install::Metadata;
+
+use strict 'vars';
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.64';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+my @scalar_keys = qw{
+ name module_name abstract author version license
+ distribution_type perl_version tests
+};
+
+my @tuple_keys = qw{
+ build_requires requires recommends bundles
+};
+
+sub Meta { shift }
+sub Meta_ScalarKeys { @scalar_keys }
+sub Meta_TupleKeys { @tuple_keys }
+
+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 (@tuple_keys) {
+ *$key = sub {
+ my $self = shift;
+ return $self->{values}{$key} unless @_;
+
+ my @rv;
+ while (@_) {
+ my $module = shift or last;
+ my $version = shift || 0;
+ if ( $module eq 'perl' ) {
+ $version =~ s{^(\d+)\.(\d+)\.(\d+)}
+ {$1 + $2/1_000 + $3/1_000_000}e;
+ $self->perl_version($version);
+ next;
+ }
+ my $rv = [ $module, $version ];
+ push @rv, $rv;
+ }
+ push @{ $self->{values}{$key} }, @rv;
+ @rv;
+ };
+}
+
+sub sign {
+ my $self = shift;
+ return $self->{'values'}{'sign'} if defined wantarray and !@_;
+ $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 );
+ return $self;
+}
+
+sub dynamic_config {
+ my $self = shift;
+ unless ( @_ ) {
+ warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n";
+ return $self;
+ }
+ $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0;
+ return $self;
+}
+
+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;
+ die "all_from: cannot find $file from $name" unless -e $file;
+ }
+
+ $self->version_from($file) unless $self->version;
+ $self->perl_version_from($file) unless $self->perl_version;
+
+ # The remaining probes read from POD sections; if the file
+ # has an accompanying .pod, use that instead
+ my $pod = $file;
+ if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) {
+ $file = $pod;
+ }
+
+ $self->author_from($file) unless $self->author;
+ $self->license_from($file) unless $self->license;
+ $self->abstract_from($file) unless $self->abstract;
+}
+
+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', 0 );
+
+ require YAML;
+ my $data = YAML::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 {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->version( ExtUtils::MM_Unix->parse_version($file) );
+}
+
+sub abstract_from {
+ my ( $self, $file ) = @_;
+ require ExtUtils::MM_Unix;
+ $self->abstract(
+ bless(
+ { DISTNAME => $self->name },
+ 'ExtUtils::MM_Unix'
+ )->parse_abstract($file)
+ );
+}
+
+sub _slurp {
+ my ( $self, $file ) = @_;
+
+ local *FH;
+ open FH, "< $file" or die "Cannot open $file.pod: $!";
+ do { local $/; <FH> };
+}
+
+sub perl_version_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ m/
+ ^
+ use \s*
+ v?
+ ([\d_\.]+)
+ \s* ;
+ /ixms
+ )
+ {
+ my $v = $1;
+ $v =~ s{_}{}g;
+ $self->perl_version($1);
+ }
+ else {
+ warn "Cannot determine perl version info from $file\n";
+ return;
+ }
+}
+
+sub author_from {
+ my ( $self, $file ) = @_;
+ my $content = $self->_slurp($file);
+ 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<lt>}{<}g;
+ $author =~ s{E<gt>}{>}g;
+ $self->author($author);
+ }
+ else {
+ warn "Cannot determine author info from $file\n";
+ }
+}
+
+sub license_from {
+ my ( $self, $file ) = @_;
+
+ if (
+ $self->_slurp($file) =~ 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 itself' => 'perl',
+ 'GNU public license' => 'gpl',
+ 'GNU lesser public license' => 'gpl',
+ 'BSD license' => 'bsd',
+ 'Artistic license' => 'artistic',
+ 'GPL' => 'gpl',
+ 'LGPL' => 'lgpl',
+ 'BSD' => 'bsd',
+ 'Artistic' => 'artistic',
+ );
+ while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) {
+ $pattern =~ s{\s+}{\\s+}g;
+ if ( $license_text =~ /\b$pattern\b/i ) {
+ $self->license($license);
+ return 1;
+ }
+ }
+ }
+
+ warn "Cannot determine license info from $file\n";
+ return 'unknown';
+}
+
+1;
--- /dev/null
+#line 1
+package Module::Install::Win32;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.64';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+# 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,
+ );
+
+ if (!$rv) {
+ die <<'END_MESSAGE';
+
+-------------------------------------------------------------------------------
+
+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;
--- /dev/null
+#line 1
+package Module::Install::WriteAll;
+
+use strict;
+use Module::Install::Base;
+
+use vars qw{$VERSION $ISCORE @ISA};
+BEGIN {
+ $VERSION = '0.64';
+ $ISCORE = 1;
+ @ISA = qw{Module::Install::Base};
+}
+
+sub WriteAll {
+ my $self = shift;
+ my %args = (
+ meta => 1,
+ sign => 0,
+ inline => 0,
+ check_nmake => 1,
+ @_
+ );
+
+ $self->sign(1) if $args{sign};
+ $self->Meta->write if $args{meta};
+ $self->admin->WriteAll(%args) if $self->is_admin;
+
+ if ( $0 =~ /Build.PL$/i ) {
+ $self->Build->write;
+ } else {
+ $self->check_nmake if $args{check_nmake};
+ unless ( $self->makemaker_args->{'PL_FILES'} ) {
+ $self->makemaker_args( PL_FILES => {} );
+ }
+ if ($args{inline}) {
+ $self->Inline->write;
+ } else {
+ $self->Makefile->write;
+ }
+ }
+}
+
+1;
--- /dev/null
+package Module::Install::TestBase;
+use strict;
+use warnings;
+
+use Module::Install::Base;
+
+use vars qw($VERSION @ISA);
+BEGIN {
+ $VERSION = '0.11';
+ @ISA = 'Module::Install::Base';
+}
+
+sub use_test_base {
+ my $self = shift;
+ $self->include('Test::Base');
+ $self->include('Test::Base::Filter');
+ $self->include('Spiffy');
+ $self->include('Test::More');
+ $self->include('Test::Builder');
+ $self->include('Test::Builder::Module');
+}
+
+1;
+
+=head1 NAME
+
+Module::Install::TestBase - Module::Install Support for Test::Base
+
+=head1 SYNOPSIS
+
+ use inc::Module::Install;
+
+ name 'Foo';
+ all_from 'lib/Foo.pm';
+
+ use_test_base;
+
+ WriteAll;
+
+=head1 DESCRIPTION
+
+This module adds the C<use_test_base> directive to Module::Install.
+
+Now you can get full Test-Base support for you module with no external
+dependency on Test::Base.
+
+Just add this line to your Makefile.PL:
+
+ use_test_base;
+
+That's it. Really. Now Test::Base is bundled into your module, so that
+it is no longer any burden on the person installing your module.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See L<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
--- /dev/null
+# TODO:
+#
+package Test::Base;
+use 5.006001;
+use Spiffy 0.30 -Base;
+use Spiffy ':XXX';
+our $VERSION = '0.54';
+
+my @test_more_exports;
+BEGIN {
+ @test_more_exports = qw(
+ ok isnt like unlike is_deeply cmp_ok
+ skip todo_skip pass fail
+ eq_array eq_hash eq_set
+ plan can_ok isa_ok diag
+ use_ok
+ $TODO
+ );
+}
+
+use Test::More import => \@test_more_exports;
+use Carp;
+
+our @EXPORT = (@test_more_exports, qw(
+ is no_diff
+
+ blocks next_block first_block
+ delimiters spec_file spec_string
+ filters filters_delay filter_arguments
+ run run_compare run_is run_is_deeply run_like run_unlike
+ WWW XXX YYY ZZZ
+ tie_output no_diag_on_only
+
+ find_my_self default_object
+
+ croak carp cluck confess
+));
+
+field '_spec_file';
+field '_spec_string';
+field _filters => [qw(norm trim)];
+field _filters_map => {};
+field spec =>
+ -init => '$self->_spec_init';
+field block_list =>
+ -init => '$self->_block_list_init';
+field _next_list => [];
+field block_delim =>
+ -init => '$self->block_delim_default';
+field data_delim =>
+ -init => '$self->data_delim_default';
+field _filters_delay => 0;
+field _no_diag_on_only => 0;
+
+field block_delim_default => '===';
+field data_delim_default => '---';
+
+my $default_class;
+my $default_object;
+my $reserved_section_names = {};
+
+sub default_object {
+ $default_object ||= $default_class->new;
+ return $default_object;
+}
+
+my $import_called = 0;
+sub import() {
+ $import_called = 1;
+ my $class = (grep /^-base$/i, @_)
+ ? scalar(caller)
+ : $_[0];
+ if (not defined $default_class) {
+ $default_class = $class;
+ }
+# else {
+# croak "Can't use $class after using $default_class"
+# unless $default_class->isa($class);
+# }
+
+ unless (grep /^-base$/i, @_) {
+ my @args;
+ for (my $ii = 1; $ii <= $#_; ++$ii) {
+ if ($_[$ii] eq '-package') {
+ ++$ii;
+ } else {
+ push @args, $_[$ii];
+ }
+ }
+ Test::More->import(import => \@test_more_exports, @args)
+ if @args;
+ }
+
+ _strict_warnings();
+ goto &Spiffy::import;
+}
+
+# Wrap Test::Builder::plan
+my $plan_code = \&Test::Builder::plan;
+my $Have_Plan = 0;
+{
+ no warnings 'redefine';
+ *Test::Builder::plan = sub {
+ $Have_Plan = 1;
+ goto &$plan_code;
+ };
+}
+
+my $DIED = 0;
+$SIG{__DIE__} = sub { $DIED = 1; die @_ };
+
+sub block_class { $self->find_class('Block') }
+sub filter_class { $self->find_class('Filter') }
+
+sub find_class {
+ my $suffix = shift;
+ my $class = ref($self) . "::$suffix";
+ return $class if $class->can('new');
+ $class = __PACKAGE__ . "::$suffix";
+ return $class if $class->can('new');
+ eval "require $class";
+ return $class if $class->can('new');
+ die "Can't find a class for $suffix";
+}
+
+sub check_late {
+ if ($self->{block_list}) {
+ my $caller = (caller(1))[3];
+ $caller =~ s/.*:://;
+ croak "Too late to call $caller()"
+ }
+}
+
+sub find_my_self() {
+ my $self = ref($_[0]) eq $default_class
+ ? splice(@_, 0, 1)
+ : default_object();
+ return $self, @_;
+}
+
+sub blocks() {
+ (my ($self), @_) = find_my_self(@_);
+
+ croak "Invalid arguments passed to 'blocks'"
+ if @_ > 1;
+ croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
+ if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
+
+ my $blocks = $self->block_list;
+
+ my $section_name = shift || '';
+ my @blocks = $section_name
+ ? (grep { exists $_->{$section_name} } @$blocks)
+ : (@$blocks);
+
+ return scalar(@blocks) unless wantarray;
+
+ return (@blocks) if $self->_filters_delay;
+
+ for my $block (@blocks) {
+ $block->run_filters
+ unless $block->is_filtered;
+ }
+
+ return (@blocks);
+}
+
+sub next_block() {
+ (my ($self), @_) = find_my_self(@_);
+ my $list = $self->_next_list;
+ if (@$list == 0) {
+ $list = [@{$self->block_list}, undef];
+ $self->_next_list($list);
+ }
+ my $block = shift @$list;
+ if (defined $block and not $block->is_filtered) {
+ $block->run_filters;
+ }
+ return $block;
+}
+
+sub first_block() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_next_list([]);
+ $self->next_block;
+}
+
+sub filters_delay() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_filters_delay(defined $_[0] ? shift : 1);
+}
+
+sub no_diag_on_only() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_no_diag_on_only(defined $_[0] ? shift : 1);
+}
+
+sub delimiters() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->check_late;
+ my ($block_delimiter, $data_delimiter) = @_;
+ $block_delimiter ||= $self->block_delim_default;
+ $data_delimiter ||= $self->data_delim_default;
+ $self->block_delim($block_delimiter);
+ $self->data_delim($data_delimiter);
+ return $self;
+}
+
+sub spec_file() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->check_late;
+ $self->_spec_file(shift);
+ return $self;
+}
+
+sub spec_string() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->check_late;
+ $self->_spec_string(shift);
+ return $self;
+}
+
+sub filters() {
+ (my ($self), @_) = find_my_self(@_);
+ if (ref($_[0]) eq 'HASH') {
+ $self->_filters_map(shift);
+ }
+ else {
+ my $filters = $self->_filters;
+ push @$filters, @_;
+ }
+ return $self;
+}
+
+sub filter_arguments() {
+ $Test::Base::Filter::arguments;
+}
+
+sub have_text_diff {
+ eval { require Text::Diff; 1 } &&
+ $Text::Diff::VERSION >= 0.35 &&
+ $Algorithm::Diff::VERSION >= 1.15;
+}
+
+sub is($$;$) {
+ (my ($self), @_) = find_my_self(@_);
+ my ($actual, $expected, $name) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ if ($ENV{TEST_SHOW_NO_DIFFS} or
+ not defined $actual or
+ not defined $expected or
+ $actual eq $expected or
+ not($self->have_text_diff) or
+ $expected !~ /\n./s
+ ) {
+ Test::More::is($actual, $expected, $name);
+ }
+ else {
+ $name = '' unless defined $name;
+ ok $actual eq $expected,
+ $name . "\n" . Text::Diff::diff(\$expected, \$actual);
+ }
+}
+
+sub run(&;$) {
+ (my ($self), @_) = find_my_self(@_);
+ my $callback = shift;
+ for my $block (@{$self->block_list}) {
+ $block->run_filters unless $block->is_filtered;
+ &{$callback}($block);
+ }
+}
+
+my $name_error = "Can't determine section names";
+sub _section_names {
+ return @_ if @_ == 2;
+ my $block = $self->first_block
+ or croak $name_error;
+ my @names = grep {
+ $_ !~ /^(ONLY|LAST|SKIP)$/;
+ } @{$block->{_section_order}[0] || []};
+ croak "$name_error. Need two sections in first block"
+ unless @names == 2;
+ return @names;
+}
+
+sub _assert_plan {
+ plan('no_plan') unless $Have_Plan;
+}
+
+sub END {
+ run_compare() unless $Have_Plan or $DIED or not $import_called;
+}
+
+sub run_compare() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and exists($block->{$y});
+ $block->run_filters unless $block->is_filtered;
+ if (ref $block->$x) {
+ is_deeply($block->$x, $block->$y,
+ $block->name ? $block->name : ());
+ }
+ elsif (ref $block->$y eq 'Regexp') {
+ my $regexp = ref $y ? $y : $block->$y;
+ like($block->$x, $regexp, $block->name ? $block->name : ());
+ }
+ else {
+ is($block->$x, $block->$y, $block->name ? $block->name : ());
+ }
+ }
+}
+
+sub run_is() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and exists($block->{$y});
+ $block->run_filters unless $block->is_filtered;
+ is($block->$x, $block->$y,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub run_is_deeply() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and exists($block->{$y});
+ $block->run_filters unless $block->is_filtered;
+ is_deeply($block->$x, $block->$y,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub run_like() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and defined($y);
+ $block->run_filters unless $block->is_filtered;
+ my $regexp = ref $y ? $y : $block->$y;
+ like($block->$x, $regexp,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub run_unlike() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->_assert_plan;
+ my ($x, $y) = $self->_section_names(@_);
+ for my $block (@{$self->block_list}) {
+ next unless exists($block->{$x}) and defined($y);
+ $block->run_filters unless $block->is_filtered;
+ my $regexp = ref $y ? $y : $block->$y;
+ unlike($block->$x, $regexp,
+ $block->name ? $block->name : ()
+ );
+ }
+}
+
+sub _pre_eval {
+ my $spec = shift;
+ return $spec unless $spec =~
+ s/\A\s*<<<(.*?)>>>\s*$//sm;
+ my $eval_code = $1;
+ eval "package main; $eval_code";
+ croak $@ if $@;
+ return $spec;
+}
+
+sub _block_list_init {
+ my $spec = $self->spec;
+ $spec = $self->_pre_eval($spec);
+ my $cd = $self->block_delim;
+ my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
+ my $blocks = $self->_choose_blocks(@hunks);
+ $self->block_list($blocks); # Need to set early for possible filter use
+ my $seq = 1;
+ for my $block (@$blocks) {
+ $block->blocks_object($self);
+ $block->seq_num($seq++);
+ }
+ return $blocks;
+}
+
+sub _choose_blocks {
+ my $blocks = [];
+ for my $hunk (@_) {
+ my $block = $self->_make_block($hunk);
+ if (exists $block->{ONLY}) {
+ diag "I found ONLY: maybe you're debugging?"
+ unless $self->_no_diag_on_only;
+ return [$block];
+ }
+ next if exists $block->{SKIP};
+ push @$blocks, $block;
+ if (exists $block->{LAST}) {
+ return $blocks;
+ }
+ }
+ return $blocks;
+}
+
+sub _check_reserved {
+ my $id = shift;
+ croak "'$id' is a reserved name. Use something else.\n"
+ if $reserved_section_names->{$id} or
+ $id =~ /^_/;
+}
+
+sub _make_block {
+ my $hunk = shift;
+ my $cd = $self->block_delim;
+ my $dd = $self->data_delim;
+ my $block = $self->block_class->new;
+ $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
+ my $name = $1;
+ my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
+ my $description = shift @parts;
+ $description ||= '';
+ unless ($description =~ /\S/) {
+ $description = $name;
+ }
+ $description =~ s/\s*\z//;
+ $block->set_value(description => $description);
+
+ my $section_map = {};
+ my $section_order = [];
+ while (@parts) {
+ my ($type, $filters, $value) = splice(@parts, 0, 3);
+ $self->_check_reserved($type);
+ $value = '' unless defined $value;
+ $filters = '' unless defined $filters;
+ if ($filters =~ /:(\s|\z)/) {
+ croak "Extra lines not allowed in '$type' section"
+ if $value =~ /\S/;
+ ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
+ $value = '' unless defined $value;
+ $value =~ s/^\s*(.*?)\s*$/$1/;
+ }
+ $section_map->{$type} = {
+ filters => $filters,
+ };
+ push @$section_order, $type;
+ $block->set_value($type, $value);
+ }
+ $block->set_value(name => $name);
+ $block->set_value(_section_map => $section_map);
+ $block->set_value(_section_order => $section_order);
+ return $block;
+}
+
+sub _spec_init {
+ return $self->_spec_string
+ if $self->_spec_string;
+ local $/;
+ my $spec;
+ if (my $spec_file = $self->_spec_file) {
+ open FILE, $spec_file or die $!;
+ $spec = <FILE>;
+ close FILE;
+ }
+ else {
+ $spec = do {
+ package main;
+ no warnings 'once';
+ <DATA>;
+ };
+ }
+ return $spec;
+}
+
+sub _strict_warnings() {
+ require Filter::Util::Call;
+ my $done = 0;
+ Filter::Util::Call::filter_add(
+ sub {
+ return 0 if $done;
+ my ($data, $end) = ('', '');
+ while (my $status = Filter::Util::Call::filter_read()) {
+ return $status if $status < 0;
+ if (/^__(?:END|DATA)__\r?$/) {
+ $end = $_;
+ last;
+ }
+ $data .= $_;
+ $_ = '';
+ }
+ $_ = "use strict;use warnings;$data$end";
+ $done = 1;
+ }
+ );
+}
+
+sub tie_output() {
+ my $handle = shift;
+ die "No buffer to tie" unless @_;
+ tie $handle, 'Test::Base::Handle', $_[0];
+}
+
+sub no_diff {
+ $ENV{TEST_SHOW_NO_DIFFS} = 1;
+}
+
+package Test::Base::Handle;
+
+sub TIEHANDLE() {
+ my $class = shift;
+ bless \ $_[0], $class;
+}
+
+sub PRINT {
+ $$self .= $_ for @_;
+}
+
+#===============================================================================
+# Test::Base::Block
+#
+# This is the default class for accessing a Test::Base block object.
+#===============================================================================
+package Test::Base::Block;
+our @ISA = qw(Spiffy);
+
+our @EXPORT = qw(block_accessor);
+
+sub AUTOLOAD {
+ return;
+}
+
+sub block_accessor() {
+ my $accessor = shift;
+ no strict 'refs';
+ return if defined &$accessor;
+ *$accessor = sub {
+ my $self = shift;
+ if (@_) {
+ Carp::croak "Not allowed to set values for '$accessor'";
+ }
+ my @list = @{$self->{$accessor} || []};
+ return wantarray
+ ? (@list)
+ : $list[0];
+ };
+}
+
+block_accessor 'name';
+block_accessor 'description';
+Spiffy::field 'seq_num';
+Spiffy::field 'is_filtered';
+Spiffy::field 'blocks_object';
+Spiffy::field 'original_values' => {};
+
+sub set_value {
+ no strict 'refs';
+ my $accessor = shift;
+ block_accessor $accessor
+ unless defined &$accessor;
+ $self->{$accessor} = [@_];
+}
+
+sub run_filters {
+ my $map = $self->_section_map;
+ my $order = $self->_section_order;
+ Carp::croak "Attempt to filter a block twice"
+ if $self->is_filtered;
+ for my $type (@$order) {
+ my $filters = $map->{$type}{filters};
+ my @value = $self->$type;
+ $self->original_values->{$type} = $value[0];
+ for my $filter ($self->_get_filters($type, $filters)) {
+ $Test::Base::Filter::arguments =
+ $filter =~ s/=(.*)$// ? $1 : undef;
+ my $function = "main::$filter";
+ no strict 'refs';
+ if (defined &$function) {
+ local $_ = join '', @value;
+ my $old = $_;
+ @value = &$function(@value);
+ if (not(@value) or
+ @value == 1 and $value[0] =~ /\A(\d+|)\z/
+ ) {
+ if ($value[0] && $_ eq $old) {
+ Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't.");
+ }
+ @value = ($_);
+ }
+ }
+ else {
+ my $filter_object = $self->blocks_object->filter_class->new;
+ die "Can't find a function or method for '$filter' filter\n"
+ unless $filter_object->can($filter);
+ $filter_object->current_block($self);
+ @value = $filter_object->$filter(@value);
+ }
+ # Set the value after each filter since other filters may be
+ # introspecting.
+ $self->set_value($type, @value);
+ }
+ }
+ $self->is_filtered(1);
+}
+
+sub _get_filters {
+ my $type = shift;
+ my $string = shift || '';
+ $string =~ s/\s*(.*?)\s*/$1/;
+ my @filters = ();
+ my $map_filters = $self->blocks_object->_filters_map->{$type} || [];
+ $map_filters = [ $map_filters ] unless ref $map_filters;
+ my @append = ();
+ for (
+ @{$self->blocks_object->_filters},
+ @$map_filters,
+ split(/\s+/, $string),
+ ) {
+ my $filter = $_;
+ last unless length $filter;
+ if ($filter =~ s/^-//) {
+ @filters = grep { $_ ne $filter } @filters;
+ }
+ elsif ($filter =~ s/^\+//) {
+ push @append, $filter;
+ }
+ else {
+ push @filters, $filter;
+ }
+ }
+ return @filters, @append;
+}
+
+{
+ %$reserved_section_names = map {
+ ($_, 1);
+ } keys(%Test::Base::Block::), qw( new DESTROY );
+}
+
+__DATA__
+
+=head1 NAME
+
+Test::Base - A Data Driven Testing Framework
+
+=head1 SYNOPSIS
+
+A new test module:
+
+ # lib/MyProject/Test.pm
+ package MyProject::Test;
+ use Test::Base -Base;
+
+ use MyProject;
+
+ package MyProject::Test::Filter;
+ use Test::Base::Filter -base;
+
+ sub my_filter {
+ return MyProject->do_something(shift);
+ }
+
+A sample test:
+
+ # t/sample.t
+ use MyProject::Test;
+
+ plan tests => 1 * blocks;
+
+ run_is input => 'expected';
+
+ sub local_filter {
+ s/my/your/;
+ }
+
+ __END__
+
+ === Test one (the name of the test)
+ --- input my_filter local_filter
+ my
+ input
+ lines
+ --- expected
+ expected
+ output
+
+ === Test two
+ This is an optional description
+ of this particular test.
+ --- input my_filter
+ other
+ input
+ lines
+ --- expected
+ other expected
+ output
+
+=head1 DESCRIPTION
+
+Testing is usually the ugly part of Perl module authoring. Perl gives
+you a standard way to run tests with Test::Harness, and basic testing
+primitives with Test::More. After that you are pretty much on your own
+to develop a testing framework and philosophy. Test::More encourages
+you to make your own framework by subclassing Test::Builder, but that is
+not trivial.
+
+Test::Base gives you a way to write your own test framework base
+class that I<is> trivial. In fact it is as simple as two lines:
+
+ package MyTestFramework;
+ use Test::Base -Base;
+
+A module called C<MyTestFramework.pm> containing those two lines, will
+give all the power of Test::More and all the power of Test::Base to
+every test file that uses it. As you build up the capabilities of
+C<MyTestFramework>, your tests will have all of that power as well.
+
+C<MyTestFramework> becomes a place for you to put all of your reusable
+testing bits. As you write tests, you will see patterns and duplication,
+and you can "upstream" them into C<MyTestFramework>. Of course, you
+don't have to subclass Test::Base at all. You can use it directly in
+many applications, including everywhere you would use Test::More.
+
+Test::Base concentrates on offering reusable data driven patterns, so
+that you can write tests with a minimum of code. At the heart of all
+testing you have inputs, processes and expected outputs. Test::Base
+provides some clean ways for you to express your input and expected
+output data, so you can spend your time focusing on that rather than
+your code scaffolding.
+
+=head1 EXPORTED FUNCTIONS
+
+Test::Base extends Test::More and exports all of its functions. So you
+can basically write your tests the same as Test::More. Test::Base
+also exports many functions of its own:
+
+=head2 is(actual, expected, [test-name])
+
+This is the equivalent of Test::More's C<is> function with one
+interesting twist. If your actual and expected results differ and the
+output is multi-line, this function will show you a unified diff format
+of output. Consider the benefit when looking for the one character that
+is different in hundreds of lines of output!
+
+Diff output requires the optional C<Text::Diff> CPAN module. If you
+don't have this module, the C<is()> function will simply give you normal
+Test::More output. To disable diffing altogether, set the
+C<TEST_SHOW_NO_DIFFS> environment variable (or C<$ENV{TEST_SHOW_NO_DIFFS}>)
+to a true value. You can also call the C<no_diff> function as a shortcut.
+
+=head2 blocks( [data-section-name] )
+
+The most important function is C<blocks>. In list context it returns a
+list of C<Test::Base::Block> objects that are generated from the test
+specification in the C<DATA> section of your test file. In scalar
+context it returns the number of objects. This is useful to calculate
+your Test::More plan.
+
+Each Test::Base::Block object has methods that correspond to the names
+of that object's data sections. There is also a C<name> and a
+C<description> method for accessing those parts of the block if they
+were specified.
+
+The C<blocks> function can take an optional single argument, that
+indicates to only return the blocks that contain a particular named data
+section. Otherwise C<blocks> returns all blocks.
+
+ my @all_of_my_blocks = blocks;
+
+ my @just_the_foo_blocks = blocks('foo');
+
+=head2 next_block()
+
+You can use the next_block function to iterate over all the blocks.
+
+ while (my $block = next_block) {
+ ...
+ }
+
+It returns undef after all blocks have been iterated over. It can then
+be called again to reiterate.
+
+=head2 first_block()
+
+Returns the first block or undef if there are none. It resets the iterator to
+the C<next_block> function.
+
+=head2 run(&subroutine)
+
+There are many ways to write your tests. You can reference each block
+individually or you can loop over all the blocks and perform a common
+operation. The C<run> function does the looping for you, so all you need
+to do is pass it a code block to execute for each block.
+
+The C<run> function takes a subroutine as an argument, and calls the sub
+one time for each block in the specification. It passes the current
+block object to the subroutine.
+
+ run {
+ my $block = shift;
+ is(process($block->foo), $block->bar, $block->name);
+ };
+
+=head2 run_is([data_name1, data_name2])
+
+Many times you simply want to see if two data sections are equivalent in
+every block, probably after having been run through one or more filters.
+With the C<run_is> function, you can just pass the names of any two data
+sections that exist in every block, and it will loop over every block
+comparing the two sections.
+
+ run_is 'foo', 'bar';
+
+If no data sections are given C<run_is> will try to detect them
+automatically.
+
+NOTE: Test::Base will silently ignore any blocks that don't contain
+both sections.
+
+=head2 run_is_deeply([data_name1, data_name2])
+
+Like C<run_is> but uses C<is_deeply> for complex data structure comparison.
+
+=head2 run_like([data_name, regexp | data_name]);
+
+The C<run_like> function is similar to C<run_is> except the second
+argument is a regular expression. The regexp can either be a C<qr{}>
+object or a data section that has been filtered into a regular
+expression.
+
+ run_like 'foo', qr{<html.*};
+ run_like 'foo', 'match';
+
+=head2 run_unlike([data_name, regexp | data_name]);
+
+The C<run_unlike> function is similar to C<run_like>, except the opposite.
+
+ run_unlike 'foo', qr{<html.*};
+ run_unlike 'foo', 'no_match';
+
+=head2 run_compare(data_name1, data_name2)
+
+The C<run_compare> function is like the C<run_is>, C<run_is_deeply> and
+the C<run_like> functions all rolled into one. It loops over each
+relevant block and determines what type of comparison to do.
+
+NOTE: If you do not specify either a plan, or run any tests, the
+C<run_compare> function will automatically be run.
+
+=head2 delimiters($block_delimiter, $data_delimiter)
+
+Override the default delimiters of C<===> and C<--->.
+
+=head2 spec_file($file_name)
+
+By default, Test::Base reads its input from the DATA section. This
+function tells it to get the spec from a file instead.
+
+=head2 spec_string($test_data)
+
+By default, Test::Base reads its input from the DATA section. This
+function tells it to get the spec from a string that has been
+prepared somehow.
+
+=head2 filters( @filters_list or $filters_hashref )
+
+Specify a list of additional filters to be applied to all blocks. See
+L<FILTERS> below.
+
+You can also specify a hash ref that maps data section names to an array
+ref of filters for that data type.
+
+ filters {
+ xxx => [qw(chomp lines)],
+ yyy => ['yaml'],
+ zzz => 'eval',
+ };
+
+If a filters list has only one element, the array ref is optional.
+
+=head2 filters_delay( [1 | 0] );
+
+By default Test::Base::Block objects are have all their filters run
+ahead of time. There are testing situations in which it is advantageous
+to delay the filtering. Calling this function with no arguments or a
+true value, causes the filtering to be delayed.
+
+ use Test::Base;
+ filters_delay;
+ plan tests => 1 * blocks;
+ for my $block (blocks) {
+ ...
+ $block->run_filters;
+ ok($block->is_filtered);
+ ...
+ }
+
+In the code above, the filters are called manually, using the
+C<run_filters> method of Test::Base::Block. In functions like
+C<run_is>, where the tests are run automatically, filtering is delayed
+until right before the test.
+
+=head2 filter_arguments()
+
+Return the arguments after the equals sign on a filter.
+
+ sub my_filter {
+ my $args = filter_arguments;
+ # is($args, 'whazzup');
+ ...
+ }
+
+ __DATA__
+ === A test
+ --- data my_filter=whazzup
+
+=head2 tie_output()
+
+You can capture STDOUT and STDERR for operations with this function:
+
+ my $out = '';
+ tie_output(*STDOUT, $buffer);
+ print "Hey!\n";
+ print "Che!\n";
+ untie *STDOUT;
+ is($out, "Hey!\nChe!\n");
+
+=head2 no_diff()
+
+Turn off diff support for is() in a test file.
+
+=head2 default_object()
+
+Returns the default Test::Base object. This is useful if you feel
+the need to do an OO operation in otherwise functional test code. See
+L<OO> below.
+
+=head2 WWW() XXX() YYY() ZZZ()
+
+These debugging functions are exported from the Spiffy.pm module. See
+L<Spiffy> for more info.
+
+=head2 croak() carp() cluck() confess()
+
+You can use the functions from the Carp module without needing to import
+them. Test::Base does it for you by default.
+
+=head1 TEST SPECIFICATION
+
+Test::Base allows you to specify your test data in an external file,
+the DATA section of your program or from a scalar variable containing
+all the text input.
+
+A I<test specification> is a series of text lines. Each test (or block)
+is separated by a line containing the block delimiter and an optional
+test C<name>. Each block is further subdivided into named sections with
+a line containing the data delimiter and the data section name. A
+C<description> of the test can go on lines after the block delimiter but
+before the first data section.
+
+Here is the basic layout of a specification:
+
+ === <block name 1>
+ <optional block description lines>
+ --- <data section name 1> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name 2> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name n> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+
+ === <block name 2>
+ <optional block description lines>
+ --- <data section name 1> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name 2> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+ --- <data section name n> <filter-1> <filter-2> <filter-n>
+ <test data lines>
+
+Here is a code example:
+
+ use Test::Base;
+
+ delimiters qw(### :::);
+
+ # test code here
+
+ __END__
+
+ ### Test One
+ We want to see if foo and bar
+ are really the same...
+ ::: foo
+ a foo line
+ another foo line
+
+ ::: bar
+ a bar line
+ another bar line
+
+ ### Test Two
+
+ ::: foo
+ some foo line
+ some other foo line
+
+ ::: bar
+ some bar line
+ some other bar line
+
+ ::: baz
+ some baz line
+ some other baz line
+
+This example specifies two blocks. They both have foo and bar data
+sections. The second block has a baz component. The block delimiter is
+C<###> and the data delimiter is C<:::>.
+
+The default block delimiter is C<===> and the default data delimiter
+is C<--->.
+
+There are some special data section names used for control purposes:
+
+ --- SKIP
+ --- ONLY
+ --- LAST
+
+A block with a SKIP section causes that test to be ignored. This is
+useful to disable a test temporarily.
+
+A block with an ONLY section causes only that block to be used. This is
+useful when you are concentrating on getting a single test to pass. If
+there is more than one block with ONLY, the first one will be chosen.
+
+Because ONLY is very useful for debugging and sometimes you forgot to
+remove the ONLY flag before commiting to the VCS or uploading to CPAN,
+Test::Base by default gives you a diag message saying I<I found ONLY
+... maybe you're debugging?>. If you don't like it, use
+C<no_diag_on_only>.
+
+A block with a LAST section makes that block the last one in the
+specification. All following blocks will be ignored.
+
+=head1 FILTERS
+
+The real power in writing tests with Test::Base comes from its
+filtering capabilities. Test::Base comes with an ever growing set
+of useful generic filters than you can sequence and apply to various
+test blocks. That means you can specify the block serialization in
+the most readable format you can find, and let the filters translate
+it into what you really need for a test. It is easy to write your own
+filters as well.
+
+Test::Base allows you to specify a list of filters to each data
+section of each block. The default filters are C<norm> and C<trim>.
+These filters will be applied (in order) to the data after it has been
+parsed from the specification and before it is set into its
+Test::Base::Block object.
+
+You can add to the default filter list with the C<filters> function. You
+can specify additional filters to a specific block by listing them after
+the section name on a data section delimiter line.
+
+Example:
+
+ use Test::Base;
+
+ filters qw(foo bar);
+ filters { perl => 'strict' };
+
+ sub upper { uc(shift) }
+
+ __END__
+
+ === Test one
+ --- foo trim chomp upper
+ ...
+
+ --- bar -norm
+ ...
+
+ --- perl eval dumper
+ my @foo = map {
+ - $_;
+ } 1..10;
+ \ @foo;
+
+Putting a C<-> before a filter on a delimiter line, disables that
+filter.
+
+=head2 Scalar vs List
+
+Each filter can take either a scalar or a list as input, and will return
+either a scalar or a list. Since filters are chained together, it is
+important to learn which filters expect which kind of input and return
+which kind of output.
+
+For example, consider the following filter list:
+
+ norm trim lines chomp array dumper eval
+
+The data always starts out as a single scalar string. C<norm> takes a
+scalar and returns a scalar. C<trim> takes a list and returns a list,
+but a scalar is a valid list. C<lines> takes a scalar and returns a
+list. C<chomp> takes a list and returns a list. C<array> takes a list
+and returns a scalar (an anonymous array reference containing the list
+elements). C<dumper> takes a list and returns a scalar. C<eval> takes a
+scalar and creates a list.
+
+A list of exactly one element works fine as input to a filter requiring
+a scalar, but any other list will cause an exception. A scalar in list
+context is considered a list of one element.
+
+Data accessor methods for blocks will return a list of values when used
+in list context, and the first element of the list in scalar context.
+This is usually "the right thing", but be aware.
+
+=head2 The Stock Filters
+
+Test::Base comes with large set of stock filters. They are in the
+C<Test::Base::Filter> module. See L<Test::Base::Filter> for a listing and
+description of these filters.
+
+=head2 Rolling Your Own Filters
+
+Creating filter extensions is very simple. You can either write a
+I<function> in the C<main> namespace, or a I<method> in the
+C<Test::Base::Filter> namespace or a subclass of it. In either case the
+text and any extra arguments are passed in and you return whatever you
+want the new value to be.
+
+Here is a self explanatory example:
+
+ use Test::Base;
+
+ filters 'foo', 'bar=xyz';
+
+ sub foo {
+ transform(shift);
+ }
+
+ sub Test::Base::Filter::bar {
+ my $self = shift; # The Test::Base::Filter object
+ my $data = shift;
+ my $args = $self->current_arguments;
+ my $current_block_object = $self->block;
+ # transform $data in a barish manner
+ return $data;
+ }
+
+If you use the method interface for a filter, you can access the block
+internals by calling the C<block> method on the filter object.
+
+Normally you'll probably just use the functional interface, although all
+the builtin filters are methods.
+
+Note that filters defined in the C<main> namespace can look like:
+
+ sub filter9 {
+ s/foo/bar/;
+ }
+
+since Test::Base automatically munges the input string into $_
+variable and checks the return value of the function to see if it
+looks like a number. If you must define a filter that returns just a
+single number, do it in a different namespace as a method. These
+filters don't allow the simplistic $_ munging.
+
+=head1 OO
+
+Test::Base has a nice functional interface for simple usage. Under the
+hood everything is object oriented. A default Test::Base object is
+created and all the functions are really just method calls on it.
+
+This means if you need to get fancy, you can use all the object
+oriented stuff too. Just create new Test::Base objects and use the
+functions as methods.
+
+ use Test::Base;
+ my $blocks1 = Test::Base->new;
+ my $blocks2 = Test::Base->new;
+
+ $blocks1->delimiters(qw(!!! @@@))->spec_file('test1.txt');
+ $blocks2->delimiters(qw(### $$$))->spec_string($test_data);
+
+ plan tests => $blocks1->blocks + $blocks2->blocks;
+
+ # ... etc
+
+=head1 THE C<Test::Base::Block> CLASS
+
+In Test::Base, blocks are exposed as Test::Base::Block objects. This
+section lists the methods that can be called on a Test::Base::Block
+object. Of course, each data section name is also available as a method.
+
+=head2 name()
+
+This is the optional short description of a block, that is specified on the
+block separator line.
+
+=head2 description()
+
+This is an optional long description of the block. It is the text taken from
+between the block separator and the first data section.
+
+=head2 seq_num()
+
+Returns a sequence number for this block. Sequence numbers begin with 1.
+
+=head2 blocks_object()
+
+Returns the Test::Base object that owns this block.
+
+=head2 run_filters()
+
+Run the filters on the data sections of the blocks. You don't need to
+use this method unless you also used the C<filters_delay> function.
+
+=head2 is_filtered()
+
+Returns true if filters have already been run for this block.
+
+=head2 original_values()
+
+Returns a hash of the original, unfiltered values of each data section.
+
+=head1 SUBCLASSING
+
+One of the nicest things about Test::Base is that it is easy to
+subclass. This is very important, because in your personal project, you
+will likely want to extend Test::Base with your own filters and other
+reusable pieces of your test framework.
+
+Here is an example of a subclass:
+
+ package MyTestStuff;
+ use Test::Base -Base;
+
+ our @EXPORT = qw(some_func);
+
+ sub some_func {
+ (my ($self), @_) = find_my_self(@_);
+ ...
+ }
+
+ package MyTestStuff::Block;
+ use base 'Test::Base::Block';
+
+ sub desc {
+ $self->description(@_);
+ }
+
+ package MyTestStuff::Filter;
+ use base 'Test::Base::Filter';
+
+ sub upper {
+ $self->assert_scalar(@_);
+ uc(shift);
+ }
+
+Note that you don't have to re-Export all the functions from
+Test::Base. That happens automatically, due to the powers of Spiffy.
+
+The first line in C<some_func> allows it to be called as either a
+function or a method in the test code.
+
+=head1 DISTRIBUTION SUPPORT
+
+You might be thinking that you do not want to use Test::Base in you
+modules, because it adds an installation dependency. Fear not.
+Module::Install takes care of that.
+
+Just write a Makefile.PL that looks something like this:
+
+ use inc::Module::Install;
+
+ name 'Foo';
+ all_from 'lib/Foo.pm';
+
+ use_test_base;
+
+ WriteAll;
+
+The line with C<use_test_base> will automatically bundle all the code
+the user needs to run Test::Base based tests.
+
+=head1 OTHER COOL FEATURES
+
+Test::Base automatically adds:
+
+ use strict;
+ use warnings;
+
+to all of your test scripts and Test::Base subclasses. A Spiffy
+feature indeed.
+
+=head1 HISTORY
+
+This module started its life with the horrible and ridicule inducing
+name C<Test::Chunks>. It was renamed to C<Test::Base> with the hope
+that it would be seen for the very useful module that it has become. If
+you are switching from C<Test::Chunks> to C<Test::Base>, simply
+substitute the concept and usage of C<chunks> to C<blocks>.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+Copyright (c) 2005. Brian Ingerson. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=cut
--- /dev/null
+#. TODO:
+#.
+
+#===============================================================================
+# This is the default class for handling Test::Base data filtering.
+#===============================================================================
+package Test::Base::Filter;
+use Spiffy -Base;
+use Spiffy ':XXX';
+
+field 'current_block';
+
+our $arguments;
+sub current_arguments {
+ return undef unless defined $arguments;
+ my $args = $arguments;
+ $args =~ s/(\\s)/ /g;
+ $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
+ return $args;
+}
+
+sub assert_scalar {
+ return if @_ == 1;
+ require Carp;
+ my $filter = (caller(1))[3];
+ $filter =~ s/.*:://;
+ Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
+}
+
+sub _apply_deepest {
+ my $method = shift;
+ return () unless @_;
+ if (ref $_[0] eq 'ARRAY') {
+ for my $aref (@_) {
+ @$aref = $self->_apply_deepest($method, @$aref);
+ }
+ return @_;
+ }
+ $self->$method(@_);
+}
+
+sub _split_array {
+ map {
+ [$self->split($_)];
+ } @_;
+}
+
+sub _peel_deepest {
+ return () unless @_;
+ if (ref $_[0] eq 'ARRAY') {
+ if (ref $_[0]->[0] eq 'ARRAY') {
+ for my $aref (@_) {
+ @$aref = $self->_peel_deepest(@$aref);
+ }
+ return @_;
+ }
+ return map { $_->[0] } @_;
+ }
+ return @_;
+}
+
+#===============================================================================
+# these filters work on the leaves of nested arrays
+#===============================================================================
+sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
+sub Reverse { $self->_apply_deepest(reverse => @_) }
+sub Split { $self->_apply_deepest(_split_array => @_) }
+sub Sort { $self->_apply_deepest(sort => @_) }
+
+
+sub append {
+ my $suffix = $self->current_arguments;
+ map { $_ . $suffix } @_;
+}
+
+sub array {
+ return [@_];
+}
+
+sub base64_decode {
+ $self->assert_scalar(@_);
+ require MIME::Base64;
+ MIME::Base64::decode_base64(shift);
+}
+
+sub base64_encode {
+ $self->assert_scalar(@_);
+ require MIME::Base64;
+ MIME::Base64::encode_base64(shift);
+}
+
+sub chomp {
+ map { CORE::chomp; $_ } @_;
+}
+
+sub chop {
+ map { CORE::chop; $_ } @_;
+}
+
+sub dumper {
+ no warnings 'once';
+ require Data::Dumper;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Terse = 1;
+ Data::Dumper::Dumper(@_);
+}
+
+sub escape {
+ $self->assert_scalar(@_);
+ my $text = shift;
+ $text =~ s/(\\.)/eval "qq{$1}"/ge;
+ return $text;
+}
+
+sub eval {
+ $self->assert_scalar(@_);
+ my @return = CORE::eval(shift);
+ return $@ if $@;
+ return @return;
+}
+
+sub eval_all {
+ $self->assert_scalar(@_);
+ my $out = '';
+ my $err = '';
+ Test::Base::tie_output(*STDOUT, $out);
+ Test::Base::tie_output(*STDERR, $err);
+ my $return = CORE::eval(shift);
+ no warnings;
+ untie *STDOUT;
+ untie *STDERR;
+ return $return, $@, $out, $err;
+}
+
+sub eval_stderr {
+ $self->assert_scalar(@_);
+ my $output = '';
+ Test::Base::tie_output(*STDERR, $output);
+ CORE::eval(shift);
+ no warnings;
+ untie *STDERR;
+ return $output;
+}
+
+sub eval_stdout {
+ $self->assert_scalar(@_);
+ my $output = '';
+ Test::Base::tie_output(*STDOUT, $output);
+ CORE::eval(shift);
+ no warnings;
+ untie *STDOUT;
+ return $output;
+}
+
+sub exec_perl_stdout {
+ my $tmpfile = "/tmp/test-blocks-$$";
+ $self->_write_to($tmpfile, @_);
+ open my $execution, "$^X $tmpfile 2>&1 |"
+ or die "Couldn't open subprocess: $!\n";
+ local $/;
+ my $output = <$execution>;
+ close $execution;
+ unlink($tmpfile)
+ or die "Couldn't unlink $tmpfile: $!\n";
+ return $output;
+}
+
+sub flatten {
+ $self->assert_scalar(@_);
+ my $ref = shift;
+ if (ref($ref) eq 'HASH') {
+ return map {
+ ($_, $ref->{$_});
+ } sort keys %$ref;
+ }
+ if (ref($ref) eq 'ARRAY') {
+ return @$ref;
+ }
+ die "Can only flatten a hash or array ref";
+}
+
+sub get_url {
+ $self->assert_scalar(@_);
+ my $url = shift;
+ CORE::chomp($url);
+ require LWP::Simple;
+ LWP::Simple::get($url);
+}
+
+sub hash {
+ return +{ @_ };
+}
+
+sub head {
+ my $size = $self->current_arguments || 1;
+ return splice(@_, 0, $size);
+}
+
+sub join {
+ my $string = $self->current_arguments;
+ $string = '' unless defined $string;
+ CORE::join $string, @_;
+}
+
+sub lines {
+ $self->assert_scalar(@_);
+ my $text = shift;
+ return () unless length $text;
+ my @lines = ($text =~ /^(.*\n?)/gm);
+ return @lines;
+}
+
+sub norm {
+ $self->assert_scalar(@_);
+ my $text = shift;
+ $text = '' unless defined $text;
+ $text =~ s/\015\012/\n/g;
+ $text =~ s/\r/\n/g;
+ return $text;
+}
+
+sub prepend {
+ my $prefix = $self->current_arguments;
+ map { $prefix . $_ } @_;
+}
+
+sub read_file {
+ $self->assert_scalar(@_);
+ my $file = shift;
+ CORE::chomp $file;
+ open my $fh, $file
+ or die "Can't open '$file' for input:\n$!";
+ CORE::join '', <$fh>;
+}
+
+sub regexp {
+ $self->assert_scalar(@_);
+ my $text = shift;
+ my $flags = $self->current_arguments;
+ if ($text =~ /\n.*?\n/s) {
+ $flags = 'xism'
+ unless defined $flags;
+ }
+ else {
+ CORE::chomp($text);
+ }
+ $flags ||= '';
+ my $regexp = eval "qr{$text}$flags";
+ die $@ if $@;
+ return $regexp;
+}
+
+sub reverse {
+ CORE::reverse(@_);
+}
+
+sub slice {
+ die "Invalid args for slice"
+ unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
+ my ($x, $y) = ($1, $2);
+ $y = $x if not defined $y;
+ die "Invalid args for slice"
+ if $x > $y;
+ return splice(@_, $x, 1 + $y - $x);
+}
+
+sub sort {
+ CORE::sort(@_);
+}
+
+sub split {
+ $self->assert_scalar(@_);
+ my $separator = $self->current_arguments;
+ if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
+ my $regexp = $1;
+ $separator = qr{$regexp};
+ }
+ $separator = qr/\s+/ unless $separator;
+ CORE::split $separator, shift;
+}
+
+sub strict {
+ $self->assert_scalar(@_);
+ <<'...' . shift;
+use strict;
+use warnings;
+...
+}
+
+sub tail {
+ my $size = $self->current_arguments || 1;
+ return splice(@_, @_ - $size, $size);
+}
+
+sub trim {
+ map {
+ s/\A([ \t]*\n)+//;
+ s/(?<=\n)\s*\z//g;
+ $_;
+ } @_;
+}
+
+sub unchomp {
+ map { $_ . "\n" } @_;
+}
+
+sub write_file {
+ my $file = $self->current_arguments
+ or die "No file specified for write_file filter";
+ if ($file =~ /(.*)[\\\/]/) {
+ my $dir = $1;
+ if (not -e $dir) {
+ require File::Path;
+ File::Path::mkpath($dir)
+ or die "Can't create $dir";
+ }
+ }
+ open my $fh, ">$file"
+ or die "Can't open '$file' for output\n:$!";
+ print $fh @_;
+ close $fh;
+ return $file;
+}
+
+sub yaml {
+ $self->assert_scalar(@_);
+ require YAML;
+ return YAML::Load(shift);
+}
+
+sub _write_to {
+ my $filename = shift;
+ open my $script, ">$filename"
+ or die "Couldn't open $filename: $!\n";
+ print $script @_;
+ close $script
+ or die "Couldn't close $filename: $!\n";
+}
+
+__DATA__
+
+=head1 NAME
+
+Test::Base::Filter - Default Filter Class for Test::Base
+
+=head1 SYNOPSIS
+
+ package MyTestSuite;
+ use Test::Base -Base;
+
+ ... reusable testing code ...
+
+ package MyTestSuite::Filter;
+ use Test::Base::Filter -Base;
+
+ sub my_filter1 {
+ ...
+ }
+
+=head1 DESCRIPTION
+
+Filters are the key to writing effective data driven tests with Test::Base.
+Test::Base::Filter is a class containing a large default set of generic
+filters. You can easily subclass it to add/override functionality.
+
+=head1 FILTERS
+
+This is a list of the default stock filters (in alphabetic order):
+
+=head2 append
+
+list => list
+
+Append a string to each element of a list.
+
+ --- numbers lines chomp append=-#\n join
+ one
+ two
+ three
+
+=head2 array
+
+list => scalar
+
+Turn a list of values into an anonymous array reference.
+
+=head2 base64_decode
+
+scalar => scalar
+
+Decode base64 data. Useful for binary tests.
+
+=head2 base64_encode
+
+scalar => scalar
+
+Encode base64 data. Useful for binary tests.
+
+=head2 chomp
+
+list => list
+
+Remove the final newline from each string value in a list.
+
+=head2 chop
+
+list => list
+
+Remove the final char from each string value in a list.
+
+=head2 dumper
+
+scalar => list
+
+Take a data structure (presumably from another filter like eval) and use
+Data::Dumper to dump it in a canonical fashion.
+
+=head2 escape
+
+scalar => scalar
+
+Unescape all backslash escaped chars.
+
+=head2 eval
+
+scalar => list
+
+Run Perl's C<eval> command against the data and use the returned value
+as the data.
+
+=head2 eval_all
+
+scalar => list
+
+Run Perl's C<eval> command against the data and return a list of 4
+values:
+
+ 1) The return value
+ 2) The error in $@
+ 3) Captured STDOUT
+ 4) Captured STDERR
+
+=head2 eval_stderr
+
+scalar => scalar
+
+Run Perl's C<eval> command against the data and return the
+captured STDERR.
+
+=head2 eval_stdout
+
+scalar => scalar
+
+Run Perl's C<eval> command against the data and return the
+captured STDOUT.
+
+=head2 exec_perl_stdout
+
+list => scalar
+
+Input Perl code is written to a temp file and run. STDOUT is captured and
+returned.
+
+=head2 flatten
+
+scalar => list
+
+Takes a hash or array ref and flattens it to a list.
+
+=head2 get_url
+
+scalar => scalar
+
+The text is chomped and considered to be a url. Then LWP::Simple::get is
+used to fetch the contents of the url.
+
+=head2 hash
+
+list => scalar
+
+Turn a list of key/value pairs into an anonymous hash reference.
+
+=head2 head[=number]
+
+list => list
+
+Takes a list and returns a number of the elements from the front of it. The
+default number is one.
+
+=head2 join
+
+list => scalar
+
+Join a list of strings into a scalar.
+
+=head2 Join
+
+Join the list of strings inside a list of array refs and return the
+strings in place of the array refs.
+
+=head2 lines
+
+scalar => list
+
+Break the data into an anonymous array of lines. Each line (except
+possibly the last one if the C<chomp> filter came first) will have a
+newline at the end.
+
+=head2 norm
+
+scalar => scalar
+
+Normalize the data. Change non-Unix line endings to Unix line endings.
+
+=head2 prepend=string
+
+list => list
+
+Prepend a string onto each of a list of strings.
+
+=head2 read_file
+
+scalar => scalar
+
+Read the file named by the current content and return the file's content.
+
+=head2 regexp[=xism]
+
+scalar => scalar
+
+The C<regexp> filter will turn your data section into a regular
+expression object. You can pass in extra flags after an equals sign.
+
+If the text contains more than one line and no flags are specified, then
+the 'xism' flags are assumed.
+
+=head2 reverse
+
+list => list
+
+Reverse the elements of a list.
+
+=head2 Reverse
+
+list => list
+
+Reverse the list of strings inside a list of array refs.
+
+=head2 slice=x[,y]
+
+list => list
+
+Returns the element number x through element number y of a list.
+
+=head2 sort
+
+list => list
+
+Sorts the elements of a list in character sort order.
+
+=head2 Sort
+
+list => list
+
+Sort the list of strings inside a list of array refs.
+
+=head2 split[=string|pattern]
+
+scalar => list
+
+Split a string in into a list. Takes a optional string or regexp as a
+parameter. Defaults to /\s+/. Same as Perl C<split>.
+
+=head2 Split[=string|pattern]
+
+list => list
+
+Split each of a list of strings and turn them into array refs.
+
+=head2 strict
+
+scalar => scalar
+
+Prepend the string:
+
+ use strict;
+ use warnings;
+
+to the block's text.
+
+=head2 tail[=number]
+
+list => list
+
+Return a number of elements from the end of a list. The default
+number is one.
+
+=head2 trim
+
+list => list
+
+Remove extra blank lines from the beginning and end of the data. This
+allows you to visually separate your test data with blank lines.
+
+=head2 unchomp
+
+list => list
+
+Add a newline to each string value in a list.
+
+=head2 write_file[=filename]
+
+scalar => scalar
+
+Write the content of the section to the named file. Return the filename.
+
+=head2 yaml
+
+scalar => list
+
+Apply the YAML::Load function to the data block and use the resultant
+structure. Requires YAML.pm.
+
+=head1 AUTHOR
+
+Ingy döt Net <ingy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006. Ingy döt Net. All rights reserved.
+Copyright (c) 2005. Brian Ingerson. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+See http://www.perl.com/perl/misc/Artistic.html
+
+=cut
--- /dev/null
+package t::BaseTest;
+use Test::Base -Base;
+
+use File::Path qw(rmtree);
+rmtree('t/output');
+
--- /dev/null
+package t::Subclass;
+use Test::Base -Base;
--- /dev/null
+# This file is an index for the `test-less` facility.
+#
+# More information can be found at:
+# http://search.cpan.org/search?query=Test-Less;mode=dist
+#
+filter t/append.t Jun 6 00:32:41 2005 GMT -- ingy
+filter t/array.t Jun 6 00:32:41 2005 GMT -- ingy
+filter t/base64.t Jun 6 00:32:41 2005 GMT -- ingy
+filter t/chomp.t Jun 6 00:32:42 2005 GMT -- ingy
+filter t/chop.t Jun 6 00:35:08 2005 GMT -- ingy
+filter t/dumper.t Jun 6 00:35:08 2005 GMT -- ingy
+filter t/eval.t Jun 6 00:35:08 2005 GMT -- ingy
+filter t/eval_all.t Jun 6 00:35:08 2005 GMT -- ingy
+filter t/eval_stderr.t Jun 6 00:35:08 2005 GMT -- ingy
+filter t/eval_stdout.t Jun 6 00:35:08 2005 GMT -- ingy
--- /dev/null
+package t::TestA;
+use Test::Base -Base;
--- /dev/null
+package t::TestB;
+use t::TestA -Base;
--- /dev/null
+package TestBass;
+use Test::Base -Base;
+
+# const block_class => 'TestBass::Block';
+# const filter_class => 'TestBass::Filter';
+
+our @EXPORT = qw(run_like_hell);
+
+sub run_like_hell() {
+ (my ($self), @_) = find_my_self(@_);
+ $self->run_like(@_);
+}
+
+
+package TestBass::Block;
+use base 'Test::Base::Block';
+
+sub el_nombre { $self->name(@_) }
+
+block_accessor 'feedle';
+
+
+package TestBass::Filter;
+use base 'Test::Base::Filter';
+
+sub foo_it {
+ map {
+ "foo - $_";
+ } @_;
+}
--- /dev/null
+package t::TestC;
+use t::TestB -Base;
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- in) lines append=---\n join
+one
+two
+three
+--- out)
+one
+---
+two
+---
+three
+---
+
+===
+--- in) lines chomp append=---\n join
+one
+two
+three
+--- out
+one---
+two---
+three---
+
+===
+--- in) chomp append=---\n
+one
+two
+three
+--- out
+one
+two
+three---
+
--- /dev/null
+use Test::Base tests => 3;
+
+run {};
+
+sub Test::Base::Filter::something {
+ my $self = shift;
+ my $value = shift;
+ my $arguments = $self->current_arguments;
+ is $value,
+ "candle\n",
+ 'value is ok';
+ is $arguments,
+ "wicked",
+ 'arguments is ok';
+ is $Test::Base::Filter::arguments,
+ "wicked",
+ '$arguments global variable is ok';
+}
+
+__END__
+=== One
+--- foo something=wicked
+candle
--- /dev/null
+use Test::Base tests => 1;
+
+is_deeply first_block->foo, [qw(one two three)];
+
+__DATA__
+
+
+=== Create an array reference
+--- foo lines chomp array
+one
+two
+three
--- /dev/null
+use Test::Base tests => 4;
+
+my $block = first_block;
+ok((not defined &Test::Base::Block::bogus_method),
+ "Method doesn't exist");
+ok((not exists $block->{bogus_method}),
+ "Slot really doesn't exist");
+ok((not defined $block->bogus_method),
+ "Method is callable");
+my @list_context = $block->bogus_method;
+ok @list_context == 0,
+ "Returns nothing in list context";
+
+__DATA__
+=== One
+--- xyz
+Flavor
--- /dev/null
+use Test::Base;
+
+plan tests => ~~blocks;
+
+run_is;
+
+__END__
+=== Test One
+--- encoded base64_decode
+SSBMb3ZlIEx1Y3kK
+
+--- decoded
+I Love Lucy
+
+
+
+=== Test Two
+
+--- encoded
+c3ViIHJ1bigmKSB7CiAgICBteSAkc2VsZiA9ICRkZWZhdWx0X29iamVjdDsKICAgIG15ICRjYWxs
+YmFjayA9IHNoaWZ0OwogICAgZm9yIG15ICRibG9jayAoJHNlbGYtPmJsb2NrcykgewogICAgICAg
+ICZ7JGNhbGxiYWNrfSgkYmxvY2spOwogICAgfQp9Cg==
+
+--- decoded base64_encode
+
+sub run(&) {
+ my $self = $default_object;
+ my $callback = shift;
+ for my $block ($self->blocks) {
+ &{$callback}($block);
+ }
+}
+
+
--- /dev/null
+use Test::Base;
+
+plan tests => 1 * blocks() + 1;
+
+for (1..blocks) {
+ ok 1, 'Jusk checking my blocking';
+}
+
+is scalar(blocks), 2,
+ 'correct number of blocks';
+
+sub this_filter_fails {
+ confess "Should never get here";
+}
+
+__DATA__
+this
+===
+--- foo this_filter_fails
+xxxx
+
+===
+--- foo this_filter_fails
+yyyy
--- /dev/null
+use Test::Base;
+
+my $plan = 1 * blocks('foo') + 3;
+
+plan tests => $plan;
+
+is $plan, 5, 'Make sure plan adds up';
+
+for my $block (blocks('foo')) {
+ is $block->foo,
+ exists($block->{bar}) ? $block->bar : 'no bar';
+}
+
+eval { blocks(foo => 'bar') };
+like "$@",
+ qr{^Invalid arguments passed to 'blocks'};
+
+run_is foo => 'bar';
+
+__DATA__
+
+===
+--- bar
+excluded
+
+===
+--- foo
+included
+--- bar
+included
+
+===
+--- foo chomp
+no bar
--- /dev/null
+use Test::Base;
+
+filters qw(norm trim chomp);
+
+plan tests => 1 * blocks;
+
+my @blocks = blocks;
+
+is $blocks[0]->input, "I am the foo";
+is $blocks[1]->input, "One\n\nTwo\n\nThree";
+is $blocks[2]->input, "Che!\n";
+
+__END__
+===
+--- input
+I am the foo
+===
+--- input
+
+One
+
+Two
+
+Three
+
+===
+--- input chomp -chomp
+Che!
+
--- /dev/null
+use Test::Base;
+
+filters qw(norm trim chomp);
+
+plan tests => 1 * blocks;
+
+my $c = next_block;
+is_deeply $c->input, $c->output;
+
+$c = next_block;
+is $c->input, $c->output;
+
+__END__
+===
+--- input lines chomp chop array
+one
+two
+three
+--- output eval
+[qw(on tw thre)]
+
+
+===
+--- input chomp chop
+one
+two
+three
+--- output eval
+"one\ntwo\nthre"
+
--- /dev/null
+use Test::Base;
+
+plan tests => 1 + 1 * blocks;
+
+filters { that => 'chomp' };
+
+run_is this => 'that';
+
+run sub {
+ my $block = shift;
+ my $value = $block->value or return;
+ is $value, 'this', $block->name;
+};
+
+my $bad_spec = <<'...';
+===
+--- bad: real content
+bogus
+stuff
+--- xxx
+yyy
+...
+my $tb = Test::Base->new->spec_string($bad_spec);
+eval { $tb->blocks };
+like "$@",
+ qr"Extra lines not allowed in 'bad' section",
+ 'Bad spec fails';
+
+
+sub upper { uc($_) }
+
+__DATA__
+
+=== Basic compact form
+--- (this): there is foo
+--- (that)
+there is foo
+
+=== Filters work
+--- (this) upper: too high to die
+--- (that)
+TOO HIGH TO DIE
+
+=== Can have no value
+--- (this):
+--- (that)
+
+=== Can have ': ' in value
+--- (this) : foo: bar
+--- (that) chop
+foo: bart
+
+=== Test trailing blank lines are ok
+--- (value): this
+
+
--- /dev/null
+use Test::Base tests => 1;
+
+pass 'Test::Base compiles';
--- /dev/null
+use Test::Base tests => 2;
+
+delimiters qw($$$ ***);
+
+run {
+ ok(shift);
+};
+
+__END__
+
+$$$
+*** foo
+this
+*** bar
+that
+
+$$$
+
+*** foo
+hola
+*** bar
+latre
--- /dev/null
+use Test::Base tests => 6;
+
+my @blocks = blocks;
+
+is $blocks[0]->description, 'One Time';
+is $blocks[1]->description, "This is the real description\nof the test.";
+is $blocks[2]->description, '';
+is $blocks[3]->description, '';
+is $blocks[4]->description, 'Three Tips';
+is $blocks[5]->description, 'Description goes here.';
+
+__END__
+=== One Time
+=== Two Toes
+This is the real description
+of the test.
+--- foo
+bar
+===
+
+===
+=== Three Tips
+
+--- beezle
+blob
+
+===
+Description goes here.
+--- data
+Some data
--- /dev/null
+use Test::Base tests => 3;
+
+SKIP: {
+ if ($^O eq 'MSWin32') {
+ skip 'Win32 doesn\'t have /tmp', 3;
+ }
+
+ unless (Test::Base->have_text_diff) {
+ skip 'The autodiffing feature of Test::Base (which rocketh) requires Text-Diff-0.35 and Algorithm-Diff-1.15 (or greater).', 3;
+ }
+
+ filters {
+ test => [qw(exec_perl_stdout smooth_output)],
+ expected => 'smooth_output',
+ };
+ run_is;
+
+ sub smooth_output {
+ s/test-blocks-\d+/test-blocks-321/;
+ s/at line \d+\)/at line 000)/;
+ s/in (.*) at line (\d+)/at $1 line $2/; # for Test::Simple 0.65
+ s/^\n//gm;
+ }
+}
+
+__DATA__
+=== little diff
+--- test
+use lib 'lib';
+use Test::Base tests => 1;
+is('a b c', 'a b x', 'little diff');
+--- expected
+1..1
+not ok 1 - little diff
+# Failed test 'little diff'
+# in /tmp/test-blocks-321 at line 3.
+# got: 'a b c'
+# expected: 'a b x'
+# Looks like you failed 1 test of 1.
+
+
+=== big diff
+--- test
+use lib 'lib';
+use Test::Base tests => 1;
+is(<<XXX, <<YYY, 'big diff');
+one
+two
+four
+five
+XXX
+one
+two
+three
+four
+YYY
+--- expected
+1..1
+not ok 1 - big diff
+# @@ -1,4 +1,4 @@
+# one
+# two
+# -three
+# four
+# +five
+#
+# Failed test 'big diff
+# @@ -1,4 +1,4 @@
+# one
+# two
+# -three
+# four
+# +five
+# '
+# in /tmp/test-blocks-321 at line 3.
+# Looks like you failed 1 test of 1.
+
+
+=== diff with space - note: doesn't help point out the extra space (yet)
+--- test
+use lib 'lib';
+use Test::Base tests => 1;
+is(<<XXX, <<YYY, 'diff with space');
+one
+two
+three
+XXX
+one
+two
+three
+YYY
+
+--- expected
+1..1
+not ok 1 - diff with space
+# @@ -1,3 +1,3 @@
+# one
+# -two
+# +two
+# three
+#
+# Failed test 'diff with space
+# @@ -1,3 +1,3 @@
+# one
+# -two
+# +two
+# three
+# '
+# in /tmp/test-blocks-321 at line 3.
+# Looks like you failed 1 test of 1.
+
+
--- /dev/null
+=== Test One\r
+--- Foo\r
+Line 1\r
+\r
+Line 2\r
+--- Bar chomp\r
+Line 3\r
+Line 4\r
+=== Test One\r
+--- Foo\r
+Line 5\r
+\r
+Line 6\r
+--- Bar chomp\r
+Line 7\r
+Line 8\r
--- /dev/null
+use Test::Base;
+
+plan tests => 3 * blocks;
+
+run_is perl => 'dumper';
+run_is dumper => 'perl';
+run_is dumper => 'dumper';
+
+__DATA__
+=== Dumper Test
+--- perl eval dumper
+[ 1..5, { 'a' .. 'p' }]
+--- dumper
+[
+ 1,
+ 2,
+ 3,
+ 4,
+ 5,
+ {
+ 'a' => 'b',
+ 'c' => 'd',
+ 'e' => 'f',
+ 'g' => 'h',
+ 'i' => 'j',
+ 'k' => 'l',
+ 'm' => 'n',
+ 'o' => 'p'
+ }
+]
+=== Another Dumper Test
+--- perl eval dumper
+"i like ike"
+--- dumper
+'i like ike'
--- /dev/null
+# This feature allows you to put a Perl section at the top of your
+# specification, between <<< and >>>. Not making this an official
+# feature yet, until I decide whether I like it.
+
+use Test::Base tests => 2;
+
+run_is;
+
+sub reverse { join '', reverse split '', shift }
+
+__DATA__
+
+<<< delimiters '+++', '***';
+filters 'chomp';
+>>>
+
+
++++ One
+*** x reverse
+123*
+*** y
+*321
+
++++ Two
+*** x reverse
+abc
+*** y
+cba
--- /dev/null
+use Test::Base tests => 2;
+
+is next_block->escaped,
+ "line1\nline2";
+is next_block->escaped,
+ " foo\n bar\n";
+
+__END__
+
+===
+--- escaped escape chomp
+line1\nline2
+===
+--- escaped escape
+\tfoo
+\t\tbar
+
--- /dev/null
+use Test::Base tests => 4;
+
+filters 'eval';
+
+my $block = first_block;
+
+is ref($block->hash), 'HASH';
+is ref($block->array), 'ARRAY';
+is scalar(@{$block->array}), 11;
+is $block->factorial, '362880';
+
+__END__
+
+=== Test
+--- hash
+{
+ foo => 'bar',
+ bar => 'hihi',
+}
+--- array
+[ 10 .. 20 ]
+--- factorial
+my $x = 1;
+$x *= $_ for (1 .. 9);
+$x;
--- /dev/null
+use Test::Base tests => 2;
+
+filters {
+ in => [qw(eval_all array)],
+ out => 'eval',
+};
+
+run_is_deeply in => 'out';
+
+__DATA__
+===
+--- (in)
+print "hi";
+warn "hello\n";
+print "bye";
+print STDERR "baby";
+die "darn\n";
+--- (out)
+[undef, "darn\n", "hibye", "hello\nbaby"]
+
+===
+--- (in)
+[1..3];
+--- (out)
+[[1,2,3], '', '', '']
--- /dev/null
+use Test::Base tests => 1;
+
+is next_block->perl, <<'...';
+You are a foo!
+You are 1 2.
+...
+
+__DATA__
+===
+--- perl eval_stderr
+warn "You are a foo!\n";
+my $foo = 2;
+print STDERR "You are 1 $foo.\n";
+return 42;
--- /dev/null
+use Test::Base tests => 1;
+
+is next_block->perl, <<'...';
+You are a foo!
+You are 1 2.
+...
+
+__DATA__
+===
+--- perl eval_stdout
+print "You are a foo!\n";
+my $foo = 2;
+print "You are 1 $foo.\n";
+return 42;
--- /dev/null
+use Test::Base;
+
+plan tests => 41;
+
+ok(defined &plan);
+ok(defined &ok);
+ok(defined &is);
+ok(defined &isnt);
+ok(defined &like);
+ok(defined &unlike);
+ok(defined &is_deeply);
+ok(defined &cmp_ok);
+ok(defined &skip);
+ok(defined &todo_skip);
+ok(defined &pass);
+ok(defined &fail);
+ok(defined &eq_array);
+ok(defined &eq_hash);
+ok(defined &eq_set);
+ok(defined &can_ok);
+ok(defined &isa_ok);
+ok(defined &diag);
+ok(defined &use_ok);
+
+ok(defined &blocks);
+ok(defined &next_block);
+ok(defined &delimiters);
+ok(defined &spec_file);
+ok(defined &spec_string);
+ok(defined &filters);
+ok(not defined &filters_map);
+ok(defined &filters_delay);
+ok(defined &run);
+ok(defined &run_is);
+ok(defined &run_like);
+ok(defined &run_unlike);
+ok(defined &run_compare);
+ok(not defined &diff_is);
+ok(defined &default_object);
+
+ok(defined &WWW);
+ok(defined &XXX);
+ok(defined &YYY);
+ok(defined &ZZZ);
+
+ok(defined &croak);
+ok(defined &carp);
+# ok(defined &cluck);
+ok(defined &confess);
--- /dev/null
+use Test::Base tests => 3;
+
+run {};
+
+sub foo {
+ is filter_arguments, '123,456';
+ return;
+}
+
+sub bar {
+ is filter_arguments, '---holy-crow+++';
+ is $_, "one\n two\n";
+ return;
+}
+
+__DATA__
+===
+--- xxx foo=123,456
+
+===
+--- xxx bar=---holy-crow+++
+one
+ two
--- /dev/null
+# Each filter should have access to blocks/block internals.
+use Test::Base;
+
+filters qw(chomp lower);
+filters_delay;
+
+plan tests => 8 * blocks;
+
+for my $block (blocks) {
+ ok not($block->is_filtered);
+ unlike $block->section, qr/[a-z]/;
+ like $block->section, qr/^I L/;
+ like $block->section, qr/\n/;
+ $block->run_filters;
+ ok $block->is_filtered;
+ like $block->section, qr/[a-z]/;
+ like $block->section, qr/^i l/;
+ unlike $block->section, qr/\n/;
+}
+
+sub lower { lc }
+
+__DATA__
+=== One
+--- section
+I LIKE IKE
+
+=== One
+--- section
+I LOVE LUCY
--- /dev/null
+use Test::Base tests => 2;
+
+filters {
+ foo => 'upper',
+ bar => 'lower',
+};
+
+run_is 'foo', 'upper';
+run_is 'bar', 'lower';
+
+sub upper { uc(shift) }
+sub Test::Base::Filter::lower { shift; lc(shift) }
+
+__END__
+===
+--- foo
+So long, and thanks for all the fish!
+--- bar
+So long, and thanks for all the fish!
+--- upper
+SO LONG, AND THANKS FOR ALL THE FISH!
+--- lower
+so long, and thanks for all the fish!
--- /dev/null
+use Test::Base tests => 2;
+
+filters qw(chomp +bar foo);
+
+is next_block->text, "this,foo,that,bar";
+# 2nd test is needed
+is next_block->text, "this,foo,that,bar";
+
+sub foo { $_[0] . ",foo" }
+sub bar { $_[0] . ",bar" }
+sub that { $_[0] . ",that" }
+
+__DATA__
+===
+--- text that
+this
+===
+--- text that
+this
--- /dev/null
+use Test::Base;
+
+filters 'upper';
+plan tests => 2;
+
+run {
+ my $block = shift;
+ is($block->one, $block->two);
+};
+
+my ($block) = blocks;
+is($block->one, "HEY NOW HEY NOW\n");
+
+sub Test::Base::Filter::upper {
+ my $self = shift;
+ return uc(shift);
+}
+
+__END__
+===
+--- one
+Hey now Hey Now
+
+--- two
+hEY NoW hEY NoW
--- /dev/null
+use Test::Base tests => 7;
+
+eval {
+ filters_map {
+ perl => ['eval'],
+ text => ['chomp', 'lines', 'array'],
+ };
+};
+like $@, qr{Can't locate object method "filters_map"};
+
+filters {
+ perl => ['eval'],
+ text => ['chomp', 'lines', 'array'],
+};
+
+run {
+ my $block = shift;
+ is ref($block->perl), 'ARRAY';
+ is ref($block->text), 'ARRAY';
+ is_deeply $block->perl, $block->text;
+};
+
+__DATA__
+=== One
+--- perl
+[
+ "One\n",
+ "2nd line\n",
+ "\n",
+ "Third time's a charm",
+]
+--- text
+One
+2nd line
+
+Third time's a charm
+=== Two
+--- text
+tic tac toe
+--- perl
+[ 'tic tac toe' ]
+
--- /dev/null
+use Test::Base tests => 7;
+
+filters 'chomp';
+
+is next_block->test, '1';
+is next_block->test, '2';
+is first_block->test, '1';
+is first_block->test, '1';
+is next_block->test, '2';
+is next_block->test, '3';
+ok not defined next_block;
+
+__DATA__
+===
+--- test
+1
+
+===
+--- test
+2
+
+===
+--- test
+3
--- /dev/null
+use Test::Base tests => 4;
+
+run_is_deeply in => 'out';
+
+filters_delay;
+
+my ($b3, $b4) = blocks('bad');
+
+eval { $b3->run_filters };
+like "$@", qr"Input to the 'flatten' filter must be a scalar";
+
+eval { $b4->run_filters };
+like "$@", qr"Can only flatten a hash or array ref";
+
+__END__
+===
+--- in eval flatten array
+{
+ one => 'won',
+ two => 'too',
+ three => 'thrice',
+}
+--- out lines chomp array
+one
+won
+three
+thrice
+two
+too
+
+===
+--- in eval flatten array
+[qw(one two three four)]
+--- out lines chomp array
+one
+two
+three
+four
+
+===
+--- bad lines flatten
+one
+two
+
+===
+--- bad flatten: foo bar baz
--- /dev/null
+use Test::Base;
+
+plan skip_all => "Need to figure out network testing";
+# plan tests => 1;
+
+run_like html => 'match';
+
+__DATA__
+=== Test kwiki.org
+--- (html) get_url: http://www.kwiki.org
+--- (match) regexp
+The Official Kwiki Web Site
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- words lines chomp hash
+foo
+42
+bar
+44
+baz
+because
+--- hash eval
++{
+ foo => 42,
+ bar => 44,
+ baz => 'because',
+}
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- in lines head
+one
+two
+three
+--- out
+one
+
+===
+--- in lines head=2 join
+one
+two
+three
+--- out
+one
+two
--- /dev/null
+# Each filter should have access to blocks/block internals.
+use Test::Base tests => 20 * 2;
+
+run {};
+
+package Test::Base::Filter;
+use Test::More;
+
+sub foo {
+ my $self = shift;
+ my $value = shift;
+
+# Test access to Test::Base::Filter object.
+ ok ref($self),
+ '$self is an object';
+ is ref($self),
+ 'Test::Base::Filter',
+ '$self is a Test:Base::Filter object';
+ like $value,
+ qr/^This is some .*text.\z/,
+ 'Filter value is correct';
+
+# Test access to Test::Base::Block object.
+ my $block = $self->current_block;
+ is ref($block),
+ 'Test::Base::Block',
+ 'Have a reference to our block object';
+
+ ok not($block->is_filtered),
+ 'Block is not completely filtered yet';
+
+ my $name = shift || 'One';
+ is $block->name,
+ $name,
+ 'name is correct';
+
+ my $description = shift || 'One';
+ is $block->description,
+ $description,
+ 'description is correct';
+
+ my $original = shift || "This is some text.";
+ is $block->original_values->{xxx},
+ $original,
+ 'Access to the original value';
+
+ my $seq_num = shift || 1;
+ cmp_ok $block->seq_num,
+ '==',
+ $seq_num,
+ 'Sequence number (seq_num) is correct';
+
+ my $array_xxx = shift || ["This is some text."];
+ is_deeply $block->{xxx},
+ $array_xxx,
+ 'Test raw content of $block->{xxx}';
+
+ my $method_xxx = shift || "This is some text.";
+ is $block->xxx,
+ $method_xxx,
+ 'Test method content of $block->xxx';
+
+# Test access to Test::Base object.
+ my $blocks = $block->blocks_object;
+ my $block_list = $blocks->block_list;
+ is ref($block_list),
+ 'ARRAY',
+ 'Have an array of all blocks';
+
+ is scalar(@$block_list),
+ '2',
+ 'Is there 2 blocks?';
+
+ is $blocks->block_class,
+ "Test::Base::Block",
+ 'block class';
+
+ is $blocks->filter_class,
+ "Test::Base::Filter",
+ 'filter class';
+
+ is_deeply
+ $blocks->{_filters},
+ [qw(norm trim)],
+ 'default filters are ok';
+
+ is $blocks->block_delim,
+ '===',
+ 'block delimiter';
+
+ is $blocks->data_delim,
+ '---',
+ 'data delimiter';
+
+ my $spec = <<END;
+=== One
+--- xxx foo: This is some text.
+=== Two
+This is the 2nd description.
+Right here.
+
+--- xxx chomp bar
+This is some more text.
+
+END
+ is $blocks->spec,
+ $spec,
+ 'spec is ok';
+
+ is $block_list->[$seq_num - 1],
+ $block,
+ 'test block ref in list';
+}
+
+sub bar {
+ my $self = shift;
+ my $value = shift;
+ $self->foo($value,
+ 'Two',
+ "This is the 2nd description.\nRight here.",
+ "This is some more text.\n\n",
+ 2,
+ ["This is some more text."],
+ "This is some more text.",
+ );
+}
+
+__END__
+=== One
+--- xxx foo: This is some text.
+=== Two
+This is the 2nd description.
+Right here.
+
+--- xxx chomp bar
+This is some more text.
+
--- /dev/null
+use Test::Base tests => 1;
+
+is(<<_ , <<_);
+1
+2
+3
+_
+1
+2
+3
+_
+
+
--- /dev/null
+# Don't filter until just before dispatch in run()
+
+use Test::Base tests => 4;
+
+eval {
+ run { pass };
+};
+
+like "$@",
+ qr/Can't find a function or method for/,
+ 'expect an error';
+
+__END__
+=== One
+--- foo
+xxx
+
+=== Two
+--- foo
+xxx
+
+=== Three
+--- foo
+xxx
+
+=== Bad
+--- foo filter_doesnt_exist_vsdyufbkhdkbjagyewkjbc
+xxx
+
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- (xxx) eval Join
+[
+ [qw(a b c)],
+ [qw(d e f)],
+]
+
+--- (yyy) eval
+[ qw(abc def) ]
+
+===
+--- (xxx) eval Join=x
+[
+ [
+ [qw(a b c)],
+ [qw(d e f)],
+ ],
+ [
+ [qw(a b c)],
+ [qw(d e f)],
+ ]
+]
+
+--- (yyy) eval
+[
+ [ qw(axbxc dxexf) ],
+ [ qw(axbxc dxexf) ],
+]
--- /dev/null
+use Test::Base tests => 3;
+
+is next_block->input, 'onetwothree';
+is next_block->input, 'one=two=three';
+is next_block->input, "one\n\ntwo\n\nthree";
+
+__DATA__
+===
+--- input lines chomp join
+one
+two
+three
+
+===
+--- input lines chomp join==
+one
+two
+three
+
+===
+--- input lines chomp join=\n\n
+one
+two
+three
--- /dev/null
+use Test::Base tests => 4;
+
+is scalar(blocks), 3,
+ 'Does LAST limit tests to 3?';
+
+run {
+ is(shift()->test, 'all work and no play');
+}
+
+__DATA__
+===
+--- test: all work and no play
+
+===
+--- test: all work and no play
+
+===
+--- LAST
+--- test: all work and no play
+
+===
+--- test: all work and no play
+
+===
+--- test: all work and no play
+
+===
+--- test: all work and no play
+
+===
+--- test: all work and no play
+
+
--- /dev/null
+use Test::Base tests => 5;
+
+run {};
+
+eval {
+ filters 'blah', 'blam';
+};
+is "$@", "";
+
+eval {
+ filters {foo => 'grate'};
+};
+is "$@", "";
+
+eval {
+ delimiters '***', '&&&';
+};
+like "$@", qr{^Too late to call delimiters\(\)};
+
+eval {
+ spec_file 'foo.txt';
+};
+like "$@", qr{^Too late to call spec_file\(\)};
+
+eval {
+ spec_string "my spec\n";
+};
+like "$@", qr{^Too late to call spec_string\(\)};
+
+__DATA__
+
+=== Dummy
+--- foo
+--- bar
--- /dev/null
+use Test::Base tests => 2;
+no_diag_on_only;
+sub shouldnt_be_run {
+ fail "shouldnt_be_run was run";
+}
+
+run_is foo => 'bar';
+
+my ($block) = blocks;
+is($block->foo, "1234");
+
+__DATA__
+===
+--- foo shouldnt_be_run
+--- bar
+
+
+
+===
+--- ONLY
+--- foo chomp
+1234
+--- bar chomp
+1234
--- /dev/null
+use Test::Base tests => 6;
+
+my @lines1 = [blocks]->[0]->text1;
+ok @lines1 == 3;
+is_deeply
+\@lines1,
+[
+ "One\n",
+ "Two\n",
+ "Three \n",
+];
+
+my @lines2 = [blocks]->[0]->text2;
+ok @lines2 == 3;
+is_deeply
+\@lines2,
+[
+ "Three",
+ "Two",
+ "One",
+];
+
+is ref([blocks]->[0]->text3), 'ARRAY';
+is scalar(@{[blocks]->[0]->text3}), 0;
+
+__END__
+=== One
+--- text1 lines
+One
+Two
+Three
+--- text2 lines chomp
+Three
+Two
+One
+--- text3 lines array
--- /dev/null
+use Test::Base tests => 5;
+
+my $block1 = [blocks]->[0];
+my @values = $block1->grocery;
+is scalar(@values), 3,
+ 'check list context';
+is_deeply \@values, ['apples', 'oranges', 'beef jerky'],
+ 'list context content';
+
+my $block2 = [blocks]->[1];
+is_deeply $block2->todo,
+[
+ 'Fix YAML',
+ 'Fix Inline',
+ 'Fix Test::Base',
+], 'deep block from index';
+
+my $block3 = [blocks]->[2];
+is $block3->perl, 'xxx',
+ 'scalar context';
+is_deeply [$block3->perl], ['xxx', 'yyy', 'zzz'],
+ 'deep list compare';
+
+__END__
+
+=== One
+--- grocery lines chomp
+apples
+oranges
+beef jerky
+
+=== Two
+--- todo lines chomp array
+Fix YAML
+Fix Inline
+Fix Test::Base
+
+=== Three
+--- perl eval
+return qw(
+ xxx
+ yyy
+ zzz
+)
--- /dev/null
+use Test::Base tests => 6;
+
+is next_block->xxx, "I lmike mike\n";
+is next_block->xxx, "I like mikey";
+is next_block->xxx, "123\n";
+is next_block->xxx, "I like MIKEY";
+is next_block->xxx, "I like ike\n";
+
+run_is xxx => 'yyy';
+
+sub mike1 {
+ s/ike/mike/g;
+};
+
+sub mike2 {
+ $_ = 'I like mikey';
+ return 123;
+};
+
+sub mike3 {
+ s/ike/heck/;
+ return "123\n";
+}
+
+sub mike4 {
+ $_ = 'I like MIKEY';
+ return;
+}
+
+sub mike5 {
+ return 200;
+}
+
+sub yyy { s/x/y/g }
+
+__DATA__
+===
+--- xxx mike1
+I like ike
+
+===
+--- xxx mike2
+I like ike
+
+===
+--- xxx mike3
+I like ike
+
+===
+--- xxx mike4
+I like ike
+
+===
+--- xxx mike5
+I like ike
+
+===
+--- xxx lines yyy
+xxx xxx
+ xxx xxx
+--- yyy
+yyy yyy
+ yyy yyy
--- /dev/null
+use t::TestC tests => 2;
+
+no_diff;
+pass 'It works';
+
+run_is();
+
+sub upper { uc }
+
+__DATA__
+=== First
+--- x upper
+foo
+--- y
+FOO
--- /dev/null
+use Test::Base;
+
+plan tests => 1 * blocks;
+
+my @blocks = blocks;
+
+is $blocks[0]->name, 'One Time';
+is $blocks[1]->name, 'Two Toes';
+is $blocks[2]->name, '';
+is $blocks[3]->name, 'Three Tips';
+
+__END__
+=== One Time
+=== Two Toes
+--- foo
+===
+
+
+
+=== Three Tips
--- /dev/null
+use Test::Base tests => 10;
+
+for (1..2) {
+ is next_block->foo, 'This is foo';
+ is next_block->bar, 'This is bar';
+
+ while (my $block = next_block) {
+ pass;
+ }
+}
+
+__DATA__
+=== One
+--- foo chomp
+This is foo
+=== Two
+--- bar chomp
+This is bar
+=== Three
+=== Four
+=== Five
--- /dev/null
+use Test::Base tests => 1;
+
+no_diff;
+
+is "xxx\nyyy\n", "xxx\nyyy\n",
+ 'This test is really weak.';
--- /dev/null
+use Test::Base;
+
+plan 'no_plan';
+
+pass;
--- /dev/null
+use Test::Base tests => 4;
+
+spec_file 't/dos_spec';
+
+my @blocks = blocks;
+
+is $blocks[0]->Foo, "Line 1\n\nLine 2\n";
+is $blocks[0]->Bar, "Line 3\nLine 4";
+is $blocks[1]->Foo, "Line 5\n\nLine 6\n";
+is $blocks[1]->Bar, "Line 7\nLine 8";
--- /dev/null
+use Test::Base tests => 1;
+no_diag_on_only;
+run_is;
+
+__END__
+
+===
+--- ONLY
+--- foo: xxx
+--- bar: xxx
+
+===
+--- foo: xxx
+--- bar: yyy
--- /dev/null
+use Test::Base tests => 3;
+no_diag_on_only;
+run { pass };
+
+is scalar(blocks), 1;
+
+is first_block->foo, "2";
+
+__DATA__
+=== One
+--- foo: 1
+=== Two
+--- ONLY
+--- foo: 2
+=== Three
+--- foo: 3
+--- ONLY
+=== Four
+--- foo: 4
--- /dev/null
+use Test::Base tests => 8;
+
+my $test = Test::Base->new;
+
+my @blocks = $test->filters('chomp')->spec_file('t/spec1')->blocks;
+
+is $blocks[0]->foo, '42';
+is $blocks[0]->bar, '44';
+is $blocks[1]->xxx, '123';
+is $blocks[1]->yyy, '321';
+
+@blocks = Test::Base->new->delimiters('^^^', '###')->blocks;
+
+is $blocks[0]->foo, "42\n";
+is $blocks[0]->bar, "44\n";
+is $blocks[1]->xxx, "123\n";
+is $blocks[1]->yyy, "321\n";
+
+__END__
+^^^ Test one
+
+### foo
+42
+
+### bar
+44
+
+^^^ Test two
+
+### xxx
+123
+### yyy
+321
--- /dev/null
+use Test::Base;
+
+my $blocks = Test::Base->new;
+$blocks->delimiters(qw(%%% ***))->filters('lower');
+
+plan tests => 3 * $blocks->blocks;
+
+$blocks->run(sub {
+ my $block = shift;
+ is $block->foo, $block->bar, $block->name;
+});
+
+$blocks->run_is('foo', 'bar');
+$blocks->run_like('foo', qr{x});
+
+sub lower { lc }
+
+__DATA__
+%%% Test
+*** foo
+xyz
+*** bar
+XYZ
--- /dev/null
+use Test::Base tests => 17;
+
+sub some_text { 'This is some text' };
+
+my $b = first_block;
+is $b->foo, $b->bar, $b->name;
+is $b->foo, some_text();
+
+run {
+ my $b = shift;
+ ok defined $b->foo;
+ is @{[$b->foo]}, 1;
+ ok length $b->foo;
+};
+
+__DATA__
+
+=== Parens clarify section
+--- (foo) some_text
+--- (bar) some_text
+
+===
+--- (foo: some text
+
+===
+--- foo)
+some text
+
+===
+--- (foo): some text
+
+===
+--- (foo) split join: some text
+
--- /dev/null
+use Test::Base;
+
+__DATA__
+=== Prepend lines before lines
+--- (in) lines prepend=---\n join
+one
+two
+three
+--- (out)
+---
+one
+---
+two
+---
+three
+
+
+=== Prepend chars before lines
+--- (in) lines chomp prepend=--- join=\n
+one
+two
+three
+--- (out) chomp
+---one
+---two
+---three
+
+
+=== Prepend to a multline string
+--- (in) prepend=---
+one
+two
+three
+--- (out)
+---one
+two
+three
+
--- /dev/null
+use Test::Base tests => 10;
+
+run {};
+
+my $count = 0;
+sub test {
+ my $num = shift;
+ chomp $num;
+ is $num, ++$count;
+ return;
+}
+
+__END__
+=== One
+--- grape test
+1
+--- iceberg_lettuce test
+2
+--- fig test
+3
+--- eggplant test
+4
+--- jalepeno test
+5
+--- banana test
+6
+--- apple test
+7
+--- carrot test
+8
+--- hot_pepper test
+9
+--- date test
+10
--- /dev/null
+use Test::Base tests => 1;
+
+is foo(), 'scalar_context', 'testing force scalar context';
+
+sub foo {
+ wantarray ? 'list_context' : 'scalar_context';
+}
--- /dev/null
+use Test::Base;
+
+run_is;
+
+__DATA__
+=== Foo
+--- a: foo
+--- b: foo
+
+=== Bar
+--- a: bar
+--- b: bar
+
+=== Baz
+--- a: baz
+--- b: baz
--- /dev/null
+use Test::Base;
+
+__DATA__
+=== Compare strings
+--- in split sort join=\s: ccc bbb aaa
+--- out: aaa bbb ccc
+
+=== Compare deeply
+--- in eval: [1, 2, 3]
+--- out eval Reverse: [3, 2, 1]
+
+=== Compare like
+--- in: You are here
+--- out regexp: ere$
+
--- /dev/null
+use Test::Base;
+
+__END__
+=== Filename is chomped automatically
+--- file read_file
+t/sample-file.txt
+--- content
+A sample of some text
+in a sample file!
+
+=== Filename is inline
+--- file read_file: t/sample-file.txt
+--- content
+A sample of some text
+in a sample file!
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- text
+one fish
+two fish
+red fish
+blue fish
+--- re regexp=
+one fish
+two fish
+red fish
+blue fish
+
+===
+--- text
+One Fish
+Two Fish
+Red Fish
+Blue Fish
+--- re regexp=im
+^one fish
+^two fish
+^red fish
+^blue fish
+
+===
+--- text
+One Fish
+Two Fish
+Red Fish
+Blue Fish
+--- re regexp
+\A^one\ fish\n
+^two\ fish.
+^red\ fish.
+^blue\ fish\n\z
+
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- (foo) lines reverse reverse join
+one
+two
+three
+
+--- (bar)
+one
+two
+three
+
--- /dev/null
+# This should not fail (used by Module::Install to check for dependency
+# presence, etc).
+require Test::Base;
+
+print "1..1\n";
+print "ok 1 - Print ran. Code didn't blow up\n";
+
--- /dev/null
+use Test::Base tests => 18;
+
+for my $word (qw(
+ BEGIN
+ DESTROY
+ EXPORT
+ ISA
+ block_accessor
+ blocks_object
+ description
+ is_filtered
+ name
+ new
+ run_filters
+ seq_num
+ set_value
+ )) {
+ my $blocks = my_blocks($word);
+ eval {$blocks->blocks};
+ like $@, qr{'$word' is a reserved name},
+ "$word is a bad name";
+}
+
+for my $word (qw(
+ field
+ const
+ stub
+ super
+ )) {
+ my $blocks = my_blocks($word);
+ my @blocks = $blocks->blocks;
+ eval {$blocks->blocks};
+ is "$@", '',
+ "$word is a good name";
+}
+
+sub my_blocks {
+ my $word = shift;
+ Test::Base->new->spec_string(<<"...");
+=== Fail test
+--- $word
+This is a test
+--- foo
+This is a test
+...
+}
+
+my $blocks = Test::Base->new->spec_string(<<'...');
+=== Fail test
+--- bar
+This is a test
+--- foo
+This is a test
+...
+eval {$blocks->blocks};
+is "$@", '';
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- xxx) eval Reverse array
+[qw(a b c)],
+[qw(d e f)],
+[qw(g h i j)]
+--- yyy) eval
+[
+[qw(c b a)],
+[qw(f e d)],
+[qw(j i h g)]
+]
+
+===
+--- xxx) eval Reverse array
+[
+ [qw(a b c)],
+ [qw(d e f)],
+ [qw(g h i j)]
+],
+[
+ [qw(a b c)],
+ [qw(d e f)],
+ [qw(g h i j)]
+],
+
+--- yyy) eval
+[
+ [
+ [qw(c b a)],
+ [qw(f e d)],
+ [qw(j i h g)]
+ ],
+ [
+ [qw(c b a)],
+ [qw(f e d)],
+ [qw(j i h g)]
+ ]
+]
+
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- (a) split reverse join=\s: this and that
+--- (b) : that and this
+
+===
+--- (a) lines reverse join
+This
+And
+That
+--- (b)
+That
+And
+This
--- /dev/null
+use Test::Base tests => 2;
+
+run_is;
+run_is_deeply;
+
+__END__
+===
+--- foo: Coolness
+--- bar append=ness: Cool
--- /dev/null
+use Test::Base tests => 3;
+
+run_compare in => 'out';
+
+__DATA__
+=== Compare strings
+--- in split sort join=\s: ccc bbb aaa
+--- out: aaa bbb ccc
+
+=== Compare deeply
+--- in eval: [1, 2, 3]
+--- out eval Reverse: [3, 2, 1]
+
+=== Compare like
+--- in: You are here
+--- out regexp: ere$
+
--- /dev/null
+use Test::Base;
+
+plan tests => 7 * blocks;
+
+run_is 'foo', 'bar';
+run_is 'bar', 'baz';
+run_is 'baz', 'foo';
+
+for my $block (blocks) {
+ is $block->foo, $block->bar, $block->name;
+ is $block->bar, $block->baz, $block->name;
+ is $block->baz, $block->foo, $block->name;
+}
+
+my @blocks = blocks;
+
+is $blocks[0]->foo, "Hey Now\n";
+is $blocks[1]->foo, "Holy Cow\n";
+
+__END__
+
+
+=== One
+--- foo
+Hey Now
+--- bar
+Hey Now
+--- baz
+Hey Now
+
+
+=== Two
+--- baz
+Holy Cow
+--- bar
+Holy Cow
+--- foo
+Holy Cow
--- /dev/null
+use Test::Base tests => 3;
+
+filters 'eval';
+
+run_is_deeply qw(foo bar);
+
+run {
+ my $block = shift;
+ ok ref $block->foo;
+ ok ref $block->bar;
+};
+
+__DATA__
+=== Test is_deeply
+--- foo
+{ foo => 22, bar => 33 }
+--- bar
+{ bar => 33, foo => 22 }
--- /dev/null
+use Test::Base tests => 3;
+
+run_like('html', 're1');
+run_like 'html', 're2';
+run_like html => qr{stylesheet};
+
+__END__
+
+=== Like Test
+--- html
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="he" dir="rtl">
+ <head>
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+
+ <link rel="stylesheet" href="/htdocs/default.css" type="text/css" />
+--- re1 regexp=xis
+<!doctype
+.*
+<html
+.*
+--- re2 regexp
+1\.0 Strict
--- /dev/null
+use Test::Base tests => 2;
+
+run_unlike('html', 're1');
+run_is 're1' => 're2';
+
+__END__
+
+=== Unlike Test
+--- html
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="he" dir="rtl">
+ <head>
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+
+ <link rel="stylesheet" href="/htdocs/default.css" type="text/css" />
+--- re1 regexp=i
+software error
+--- re2 chomp
+(?i-xsm:software error)
--- /dev/null
+A sample of some text
+in a sample file!
--- /dev/null
+use Test::Base;
+
+plan tests => 1 * blocks;
+
+# A silly test instead of pod2html
+for my $block (blocks) {
+ is(
+ uc($block->pod),
+ $block->upper,
+ $block->name,
+ );
+}
+
+__END__
+=== Header 1 Test
+--- pod
+=head1 The Main Event
+--- upper
+=HEAD1 THE MAIN EVENT
+=== List Test
+--- pod
+=over
+=item * one
+=item * two
+=back
+--- upper
+=OVER
+=ITEM * ONE
+=ITEM * TWO
+=BACK
--- /dev/null
+use Test::Base tests => 5;
+
+run { pass };
+
+is scalar(blocks), 2;
+
+my @block = blocks;
+is $block[0]->foo, "2\n";
+is $block[1]->foo, "3\n";
+
+__DATA__
+=== One
+--- SKIP
+--- foo
+1
+=== Two
+--- foo
+2
+=== Three
+--- foo
+3
+=== Four
+--- SKIP
+--- foo
+4
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- in lines slice=0,2 join
+one
+two
+three
+four
+five
+--- out
+one
+two
+three
+
+===
+--- in lines slice=2,3 join
+one
+two
+three
+four
+five
+--- out
+three
+four
+
+===
+--- in lines slice=1 join
+one
+two
+three
+--- out
+two
--- /dev/null
+use Test::Base;
+
+__END__
+=== Test deep sorting
+--- (a) eval Sort
+[
+[
+[qw(c d b a)], [qw(foo bar baz)],
+]
+]
+--- (b) eval Reverse
+[
+[
+[qw(d c b a)], [qw(foo baz bar)],
+]
+]
--- /dev/null
+use Test::Base;
+
+__DATA__
+=== Can sort a list
+--- (in) split sort join=-: foo bar baz
+--- out: bar-baz-foo
+
+=== Can sort backwards
+--- (in) split sort reverse join=-: foo bar baz
+--- out: foo-baz-bar
+
+
--- /dev/null
+=== Test one
+
+--- foo
+42
+
+--- bar
+44
+
+=== Test two
+
+--- xxx
+123
+--- yyy
+321
--- /dev/null
+===
+--- foo
+1
+--- bar
+2
+===
+--- foo
+3
+--- bar
+4
--- /dev/null
+use Test::Base;
+
+filters 'chomp';
+spec_file 't/spec2';
+
+plan tests => 3 * blocks;
+
+run {
+ my $block = shift;
+ is ref($block), 'Test::Base::Block';
+};
+
+my @blocks = blocks;
+
+is($blocks[0]->foo, 1);
+is($blocks[0]->bar, 2);
+is($blocks[1]->foo, 3);
+is($blocks[1]->bar, 4);
--- /dev/null
+use Test::Base;
+
+filters 'chomp';
+spec_string <<'...';
+===
+--- foo
+1
+--- bar
+2
+===
+--- foo
+3
+--- bar
+4
+...
+
+plan tests => 3 * blocks;
+
+run {
+ my $block = shift;
+ is ref($block), 'Test::Base::Block';
+};
+
+my @blocks = blocks;
+
+is $blocks[0]->foo, 1;
+is $blocks[0]->bar, 2;
+is $blocks[1]->foo, 3;
+is $blocks[1]->bar, 4;
--- /dev/null
+use Test::Base;
+
+__DATA__
+=== Complex generic manipulation
+--- (test) lines chomp Split Reverse Join=\s reverse join=\n
+Hey
+I Like Ike
+Give Peace A Chance
+Love Is The Answer
+--- (flipper) chomp
+Answer The Is Love
+Chance A Peace Give
+Ike Like I
+Hey
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- (xxx) chomp split=// reverse join
+one
+two
+--- (yyy) chomp
+owt
+eno
+
+===
+--- (xxx) split=/[XY]/ join=-: oneXtwoYthree
+--- (yyy): one-two-three
+
+===
+--- (xxx) split join=-: one two three
+--- (yyy): one-two-three
--- /dev/null
+use Test::Base tests => 2;
+
+my $b = next_block;
+is $b->ok, "I am ok. Are you ok?";
+
+$b = next_block;
+is_deeply [$b->words], [qw(foo bar baz)];
+
+__DATA__
+
+=== Split a string of lines into words
+--- ok split join=\s
+I am
+ok. Are you
+ok?
+
+=== Split on a string
+--- words split=x: fooxbarxbaz
+--- LAST
+The other tests don't work yet.
+
+===
+--- ok lines split
+I am
+ok. Are you
+ok?
+
+
+===
+--- test lines Split Reverse Join reverse join=\n
+I Like Ike
+Give Peace A Chance
+Love Is The Answer
+--- flip
+Answer The Is Love
+Chance A Peace Give
+Ike Like I
--- /dev/null
+use Test::Base tests => 1;
+use lib 't';
+
+eval "require 'strict-warnings.test'";
+like "$@",
+ qr{\QGlobal symbol "\E.\Qglobal_variable" requires explicit package name\E};
--- /dev/null
+use Test::Base;
+
+$global_variable = 42;
--- /dev/null
+use Test::Base;
+
+__DATA__
+=== Strict Test
+
+--- perl strict
+my $x = 5;
+--- strict
+use strict;
+use warnings;
+my $x = 5;
--- /dev/null
+package Testorama;
+use Test::Base -Base;
+
+BEGIN {
+ our @EXPORT = qw(run_orama);
+}
+
+sub run_orama {
+ pass 'Testorama EXPORT ok';
+}
+
+package Test::Base::Block;
+
+sub foofoo {
+ Test::More::pass 'Test::Base::Block ok';
+}
+
+package Testorama::Filter;
+use base 'Test::Base::Filter';
+
+sub rama_rama {
+ Test::More::pass 'Testorama::Filter ok';
+}
+
+package main;
+# use Testorama;
+BEGIN { Testorama->import }
+
+plan tests => 3;
+
+run_orama;
+
+[blocks]->[0]->foofoo;
+
+__DATA__
+===
+--- stuff chomp rama_rama
+che!
--- /dev/null
+# Make sure a subclass passes along inport args
+use t::Subclass tests => 1;
+
+pass;
--- /dev/null
+use lib 't';
+use TestBass tests => 7;
+
+eval "use Test::Base";
+is "$@", '', 'ok to import parent class *after* subclass';
+
+my @blocks = blocks;
+
+is ref(default_object), 'TestBass';
+
+is $blocks[0]->el_nombre, 'Test One';
+
+ok $blocks[0]->can('feedle'), 'Does feedle method exist?';
+
+run_is xxx => 'yyy';
+
+run_like_hell 'thunk', qr(thunk,.*ile.*unk);
+
+__DATA__
+=== Test One
+--- xxx lines foo_it join
+a lion
+a tiger
+a liger
+--- yyy
+foo - a lion
+foo - a tiger
+foo - a liger
+
+===
+--- thunk
+A thunk, a pile of junk
+===
+--- thunk
+A thunk, a jile of punk
--- /dev/null
+use lib 't';
+use Test::Base tests => 1;
+
+# I can't remember why I added this but it was preventing multiple
+# levels of inheritance which I needed for the YAML and YAML-Syck
+# projects. And is also just damn useful in general.
+
+SKIP: {
+ skip("yagni For now...", 1);
+ eval "use TestBass";
+
+ like "$@", qr{Can't use TestBass after using Test::Base};
+}
--- /dev/null
+use Test::Base;
+
+__DATA__
+===
+--- in lines tail
+one
+two
+three
+--- out
+three
+
+===
+--- in lines tail=2 join
+one
+two
+three
+--- out
+two
+three
--- /dev/null
+use Test::Base tests => 3;
+
+my $out = "Stuff\n";
+my $err = '';
+
+tie_output(*STDOUT, $out);
+tie_output(*STDERR, $err);
+
+warn "Keep out!\n";
+
+print "The eagle has landed\n";
+
+is $out, "Stuff\nThe eagle has landed\n";
+
+print "This bird had flown\n";
+
+is $out, "Stuff\nThe eagle has landed\nThis bird had flown\n";
+
+print STDERR "You 'lil rascal...\n";
+
+is $err, "Keep out!\nYou 'lil rascal...\n";
--- /dev/null
+use Test::Base tests => 4;
+
+my ($block1, $block2) = blocks;
+
+is $block1->foo, "line 1\nline 2\n";
+is $block1->bar, "line1\nline2\n";
+is $block2->foo, "aaa\n\nbbb\n";
+is $block2->bar, "\nxxxx\n\nyyyy\n\n";
+
+
+__END__
+
+=== One
+
+--- foo
+line 1
+line 2
+
+--- bar
+
+line1
+line2
+
+=== Two
+
+--- bar -trim
+
+xxxx
+
+yyyy
+
+--- foo
+
+aaa
+
+bbb
+
+
--- /dev/null
+use Test::Base tests => 1;
+
+filters qw(norm trim chomp);
+
+is next_block->input, "on\ntw\nthre\n";
+
+__END__
+===
+--- input lines chomp chop unchomp join
+one
+two
+three
--- /dev/null
+use Test::Base tests => 3;
+
+pass for 1 .. 3;
--- /dev/null
+use t::BaseTest tests => 4;
+
+my $file = 't/output/foo.txt';
+
+ok not(-e $file), "$file doesn't already exist";
+
+first_block;
+
+ok -e $file, "$file exists";
+
+open my $fh, $file
+ or die "Can't open '$file' for input:\n$!";
+is join('', <$fh>),
+ "One two\nBuckle my shoe\n",
+ '$file content is right';
+
+is first_block->poem, $file, 'Returns file name';
+
+__END__
+
+===
+--- poem write_file=t/output/foo.txt
+One two
+Buckle my shoe
--- /dev/null
+use Test::Base;
+
+plan eval { require YAML; 1 }
+ ? (tests => 1 * blocks)
+ : skip_all => 'Requires YAML';
+
+my ($block) = blocks;
+
+eval { XXX($block->text) };
+
+my $error = "$@";
+$error =~ s/\\/\//g;
+
+is $error, $block->xxx, $block->name;
+
+__DATA__
+=== XXX Test
+--- text eval
++{ foo => 'bar' }
+--- xxx
+---
+foo: bar
+...
+ at t/xxx.t line 9
--- /dev/null
+use Test::Base;
+
+plan eval { require YAML; 1 }
+ ? (tests => 1 * blocks)
+ : skip_all => 'Requires YAML';
+
+filters {
+ data1 => 'yaml',
+ data2 => 'eval',
+};
+
+run_compare;
+
+__END__
+=== YAML Hashes
+--- data1
+foo: xxx
+bar: [ 1, 2, 3]
+--- data2
++{
+ foo => 'xxx',
+ bar => [1,2,3],
+}
+
+
+=== YAML Arrays
+--- data1
+- foo
+- bar
+- {x: y}
+--- data2
+[
+ 'foo',
+ 'bar',
+ { x => 'y' },
+]
+
+
+=== YAML Scalar
+--- data1
+--- |
+ sub foo {
+ print "bar\n";
+ }
+--- data2
+<<'END';
+sub foo {
+ print "bar\n";
+}
+END
--- /dev/null
+use Test::Base;
+
+plan tests => 1;
+
+ok(blocks == 0, 'Ok to have zero blocks');
+
+__DATA__
+
+There really is nothing here to test...
--- /dev/null
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+Format: 1.0
+Source: libtest-base-perl
+Binary: libtest-base-perl
+Architecture: all
+Version: 0.54-1
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: Florian Ragwitz <rafl@debian.org>, Damyan Ivanov <dmn@debian.org>
+Homepage: http://search.cpan.org/dist/Test-Base/
+Standards-Version: 3.8.0
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-base-perl/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libtest-base-perl/
+Build-Depends: debhelper (>= 7)
+Build-Depends-Indep: perl (>= 5.6), libspiffy-perl (>= 0.30), libtest-simple-perl (>= 0.62), libalgorithm-diff-perl, libtext-diff-perl, libyaml-perl
+Checksums-Sha1:
+ 2505fb996b3c490ddb215647fb6a224d6b5cd421 45525 libtest-base-perl_0.54.orig.tar.gz
+ 16febbdf0c2ae6e7a5f26ab18b8bf8a5ff4660ef 2270 libtest-base-perl_0.54-1.diff.gz
+Checksums-Sha256:
+ f63ef7b36e6c04c836034b496a2cf458f87162e49fcf320490d39d53a0a2cf51 45525 libtest-base-perl_0.54.orig.tar.gz
+ f5dae90a808c7d0d36d7b1f1189fa27f91e147a88c22a9cd717e85d800ef3ecb 2270 libtest-base-perl_0.54-1.diff.gz
+Files:
+ 502a92cbbaea1d53ada4d8388e5e3b16 45525 libtest-base-perl_0.54.orig.tar.gz
+ c5f9103d19cc3144b2ed38f8a8ba609b 2270 libtest-base-perl_0.54-1.diff.gz
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.9 (GNU/Linux)
+
+iEYEARECAAYFAkhqB4cACgkQHqjlqpcl9jsRUgCcCTmLcA1KTNBgcRqoENxYd1XC
+EmIAoIj0PJPJlIOY9CtXy6si84p4YrL6
+=zKdL
+-----END PGP SIGNATURE-----
--- /dev/null
+Changes file for Text::Diff
+
+0.35 Tue Aug 27 13:53:23 EDT 2002
+ - Escape whitespace if a blank line is inserted or removed. This
+ puts a "\n" in the column containing the blank line, for instance.
+
+0.34 Sun Jul 14 07:02:51 EDT 2002
+ - Improved Table format's escaping
+ - that "\t" and "\\t" are displayed differently
+ - the entire line is escaped consistently if it is escaped
+ at all.
+
+0.33 Mon Jul 8 16:29:01 EDT 2002
+ - Make diff() return "" instead of 0 when comparing two empty
+ things. Patch from Rolf Grossmann <grossman@progtech.net>.
+
+0.32 Thu Mar 14 13:37:51 EST 2002
+ - Fix escaping of all-whitespace strings.
+
+0.31 Wed Feb 6 05:36:47 EST 2002
+ - Remove stray $SIG{__DIE__} that was confessing on every die.
+
+0.3 Undocumented (sorry)
+
+0.11 Mon Dec 10 06:23:00 EST 2001
+ - Remove hardcoded date string from t/general.t's test data, because
+ localtime is used to generate this in Diff.pm and the local machine's
+ timezone (and locale?) can cause the localtime for a given mtime to be
+ quite different. Reported by Andreas Marcel Riechert
+ <riechert@pobox.com> of cpan-testers.
+ - Start this Changes file.
+ - Added hunk_header() and hunk_footer() for symmetry in overloading.
+ - Added t/ext_format.t
+
+0.1
+ - Initial public release.
+ - Added filename, filehandle, and string I/O options
+ - API resembles Algorithm::Diff's a bit more
+ - Reimplement output formats as classes so that external (user-supplied)
+ can be specified as class names (My::Diff::Format) and so that they may
+ be inherited from. Should probably break out hunk_header() from hunk().
+ - Add footer() to all formats
--- /dev/null
+Changes
+MANIFEST
+MANIFEST.SKIP
+Makefile.PL
+lib/Text/Diff.pm
+lib/Text/Diff/Table.pm
+t/ext_format.t
+t/general.t
+t/inputs.t
+t/keygen.t
+t/outputs.t
+t/table.t
--- /dev/null
+\.bak$
+\.sw[a-z]$
+\.tar\.gz$
+^tmp/
+^blib/
+^Makefile$
+\.old$
+^A$
+^B$
+^pm_to_blib$
--- /dev/null
+use ExtUtils::MakeMaker;
+
+use strict ;
+
+WriteMakefile(
+ 'NAME' => 'Text::Diff',
+ 'VERSION_FROM' => 'lib/Text/Diff.pm',
+ 'PREREQ_PM' => {
+ 'Algorithm::Diff' => 0,
+ },
+);
+
+sub MY::libscan {
+ package MY ;
+ my $self = shift ;
+ my ( $path ) = @_ ;
+ return '' if /\.sw[a-z]$/ ;
+ return '' unless length $self->SUPER::libscan( $path ) ;
+ return $path ;
+}
--- /dev/null
+libtext-diff-perl (0.35-3maemo1) fremantle; urgency=low
+
+ * New Maemo packaging
+
+ -- Nito Martinez <Nito@Qindel.ES> Wed, 14 Apr 2010 07:11:11 +0100
+
+
+llibtext-diff-perl (0.35-3) unstable; urgency=low
+
+ [ gregor herrmann ]
+ * debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser
+ field (source stanza); Homepage field (source stanza).
+ * Set Maintainer to Debian Perl Group.
+ * Use dist-based URL in debian/watch.
+ * debian/rules: delete /usr/lib/perl5 only if it exists.
+
+ [ Gunnar Wolf ]
+ * Bumped up standards-version to 3.7.3 (no changes needed)
+ * Upgraded debhelper compat level to 6
+ * Moved debhelper to b-d
+ * Clarified the copyright information
+ * Remove the versioned dependency on Perl >= 5.6.0
+ * Make clean no longer ignores results
+ * Removed debian/substvars, which is auto-generated and should be
+ auto-cleaned
+ * Modified debian/watch to be more in line with our general style
+ * Added myself as an uploader
+
+ -- Gunnar Wolf <gwolf@debian.org> Wed, 20 Feb 2008 16:50:08 -0600
+
+libtext-diff-perl (0.35-2) unstable; urgency=low
+
+ * Adds debian/watch file so uscan will work
+
+ -- Jay Bonci <jaybonci@debian.org> Mon, 11 Oct 2004 02:40:26 -0400
+
+libtext-diff-perl (0.35-1) unstable; urgency=low
+
+ * Initial Release (closes: #178078)
+
+ -- Jay Bonci <jaybonci@debian.org> Sun, 21 Sep 2003 02:50:48 -0400
--- /dev/null
+Source: libtext-diff-perl
+Section: perl
+Priority: optional
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: Jay Bonci <jaybonci@debian.org>, Gunnar Wolf <gwolf@debian.org>
+Build-Depends: debhelper7
+Build-Depends-Indep: perl (>= 5.8), libalgorithm-diff-perl
+Standards-Version: 3.7.3
+Homepage: http://search.cpan.org/dist/Text-Diff/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libtext-diff-perl/
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libtext-diff-perl/
+
+Package: libtext-diff-perl
+Architecture: all
+Depends: ${perl:Depends}, libalgorithm-diff-perl
+Description: Perform diffs on files and record sets in perl
+ CPAN's Text::Diff provides a basic set of services akin to the GNU diff
+ utility. It is not anywhere near as feature complete as GNU diff, but
+ it is better integrated with Perl and available on all platforms
--- /dev/null
+This package was debianized by Jay Bonci <jay@bonci.com> on
+Thu, 23 Jan 2003 10:08:30 -0500.
+
+It was downloaded from http://search.cpan.org/dist/Text-Diff
+
+Upstream Author: Barrie Slaymaker <barries@slaysys.com>
+
+Copyright 2001, Barrie Slaymaker. All Rights Reserved.
+
+You may use this under the terms of either the Artistic License or
+GNU Public License v 2.0 or greater.
+
+See:
+/usr/share/common-licenses/Artistic
+ - or -
+/usr/share/common-licenses/GPL
+
+For more information regarding these licensing options.
--- /dev/null
+#!/usr/bin/make -f
+# Sample debian/rules that uses debhelper.
+# GNU copyright 1997 to 1999 by Joey Hess.
+
+# Uncomment this to turn on verbose mode.
+#export DH_VERBOSE=1
+
+# This is the debhelper compatibility version to use.
+# export DH_COMPAT=4
+
+PACKAGE=`pwd | sed -e "s/.*\/\\(.*\\)-.*/\\1/"`
+
+
+build:
+ dh_testdir
+ # Add here commands to compile the package.
+ perl Makefile.PL verbose INSTALLDIRS=vendor
+clean:
+ dh_testdir
+ dh_testroot
+
+ [ ! -f Makefile ] || $(MAKE) distclean
+ rm -f Makefile.old
+ dh_clean
+
+install:
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ dh_installdirs
+
+ $(MAKE) PREFIX=$(CURDIR)/debian/$(PACKAGE)/usr OPTIMIZE="-O2 -g -Wall" test install
+ [ ! -d $(CURDIR)/debian/$(shell dh_listpackages)/usr/lib/perl5 ] || rmdir --ignore-fail-on-non-empty --parents --verbose $(CURDIR)/debian/$(shell dh_listpackages)/usr/lib/perl5
+
+binary-arch:;
+binary-indep: build install
+ dh_testdir
+ dh_testroot
+ dh_installdocs
+ dh_installman
+ dh_installchangelogs Changes
+ dh_link
+ dh_strip
+ dh_compress
+ dh_fixperms
+ dh_installdeb
+ dh_perl
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
--- /dev/null
+version=3
+http://search.cpan.org/dist/Text-Diff/ .*/Text-Diff-(\d[\d\.]*)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)
--- /dev/null
+package Text::Diff;
+
+$VERSION = 0.35;
+
+=head1 NAME
+
+Text::Diff - Perform diffs on files and record sets
+
+=head1 SYNOPSIS
+
+ use Text::Diff;
+
+ ## Mix and match filenames, strings, file handles, producer subs,
+ ## or arrays of records; returns diff in a string.
+ ## WARNING: can return B<large> diffs for large files.
+ my $diff = diff "file1.txt", "file2.txt", { STYLE => "Context" };
+ my $diff = diff \$string1, \$string2, \%options;
+ my $diff = diff \*FH1, \*FH2;
+ my $diff = diff \&reader1, \&reader2;
+ my $diff = diff \@records1, \@records2;
+
+ ## May also mix input types:
+ my $diff = diff \@records1, "file_B.txt";
+
+=head1 DESCRIPTION
+
+C<diff()> provides a basic set of services akin to the GNU C<diff> utility. It
+is not anywhere near as feature complete as GNU C<diff>, but it is better
+integrated with Perl and available on all platforms. It is often faster than
+shelling out to a system's C<diff> executable for small files, and generally
+slower on larger files.
+
+Relies on L<Algorithm::Diff> for, well, the algorithm. This may not produce
+the same exact diff as a system's local C<diff> executable, but it will be a
+valid diff and comprehensible by C<patch>. We haven't seen any differences
+between Algorithm::Diff's logic and GNU diff's, but we have not examined them
+to make sure they are indeed identical.
+
+B<Note>: If you don't want to import the C<diff> function, do one of the
+following:
+
+ use Text::Diff ();
+
+ require Text::Diff;
+
+That's a pretty rare occurence, so C<diff()> is exported by default.
+
+=cut
+
+use Exporter;
+@ISA = qw( Exporter );
+@EXPORT = qw( diff );
+
+use strict;
+use Carp;
+use Algorithm::Diff qw( traverse_sequences );
+
+## Hunks are made of ops. An op is the starting index for each
+## sequence and the opcode:
+use constant A => 0; # Array index before match/discard
+use constant B => 1;
+use constant OPCODE => 2; # "-", " ", "+"
+use constant FLAG => 3; # What to display if not OPCODE "!"
+
+
+=head1 OPTIONS
+
+diff() takes two parameters from which to draw input and a set of
+options to control it's output. The options are:
+
+=over
+
+=item FILENAME_A, MTIME_A, FILENAME_B, MTIME_B
+
+The name of the file and the modification time "files"
+
+These are filled in automatically for each file when diff() is passed a
+filename, unless a defined value is passed in.
+
+If a filename is not passed in and FILENAME_A and FILENAME_B are not provided
+or C<undef>, the header will not be printed.
+
+Unused on C<OldStyle> diffs.
+
+=item OFFSET_A, OFFSET_B
+
+The index of the first line / element. These default to 1 for all
+parameter types except ARRAY references, for which the default is 0. This
+is because ARRAY references are presumed to be data structures, while the
+others are line oriented text.
+
+=item STYLE
+
+"Unified", "Context", "OldStyle", or an object or class reference for a class
+providing C<file_header()>, C<hunk_header()>, C<hunk()>, C<hunk_footer()> and
+C<file_footer()> methods. The two footer() methods are provided for
+overloading only; none of the formats provide them.
+
+Defaults to "Unified" (unlike standard C<diff>, but Unified is what's most
+often used in submitting patches and is the most human readable of the three.
+
+If the package indicated by the STYLE has no hunk() method, c<diff()> will
+load it automatically (lazy loading). Since all such packages should inherit
+from Text::Diff::Base, this should be marvy.
+
+Styles may be specified as class names (C<STYLE => "Foo"), in which case they
+will be C<new()>ed with no parameters, or as objects (C<STYLE => Foo->new>).
+
+=item CONTEXT
+
+How many lines before and after each diff to display. Ignored on old-style
+diffs. Defaults to 3.
+
+=item OUTPUT
+
+Examples and their equivalent subroutines:
+
+ OUTPUT => \*FOOHANDLE, # like: sub { print FOOHANDLE shift() }
+ OUTPUT => \$output, # like: sub { $output .= shift }
+ OUTPUT => \@output, # like: sub { push @output, shift }
+ OUTPUT => sub { $output .= shift },
+
+If no C<OUTPUT> is supplied, returns the diffs in a string. If
+C<OUTPUT> is a C<CODE> ref, it will be called once with the (optional)
+file header, and once for each hunk body with the text to emit. If
+C<OUTPUT> is an L<IO::Handle>, output will be emitted to that handle.
+
+=item FILENAME_PREFIX_A, FILENAME_PREFIX_B
+
+The string to print before the filename in the header. Unused on C<OldStyle>
+diffs. Defaults are C<"---">, C<"+++"> for Unified and C<"***">, C<"+++"> for
+Context.
+
+=item KEYGEN, KEYGEN_ARGS
+
+These are passed to L<Algorithm::Diff/traverse_sequences>.
+
+=back
+
+B<Note>: if neither C<FILENAME_> option is defined, the header will not be
+printed. If at one is present, the other and both MTIME_ options must be
+present or "Use of undefined variable" warnings will be generated (except
+on C<OldStyle> diffs, which ignores these options).
+
+=cut
+
+my %internal_styles = (
+ Unified => undef,
+ Context => undef,
+ OldStyle => undef,
+ Table => undef, ## "internal", but in another module
+);
+
+sub diff {
+ my @seqs = ( shift, shift );
+ my $options = shift || {};
+
+ for my $i ( 0..1 ) {
+ my $seq = $seqs[$i];
+ my $type = ref $seq;
+
+ while ( $type eq "CODE" ) {
+ $seqs[$i] = $seq = $seq->( $options );
+ $type = ref $seq;
+ }
+
+ my $AorB = !$i ? "A" : "B";
+
+ if ( $type eq "ARRAY" ) {
+ ## This is most efficient :)
+ $options->{"OFFSET_$AorB"} = 0
+ unless defined $options->{"OFFSET_$AorB"};
+ }
+ elsif ( $type eq "SCALAR" ) {
+ $seqs[$i] = [split( /^/m, $$seq )];
+ $options->{"OFFSET_$AorB"} = 1
+ unless defined $options->{"OFFSET_$AorB"};
+ }
+ elsif ( ! $type ) {
+ $options->{"OFFSET_$AorB"} = 1
+ unless defined $options->{"OFFSET_$AorB"};
+ $options->{"FILENAME_$AorB"} = $seq
+ unless defined $options->{"FILENAME_$AorB"};
+ $options->{"MTIME_$AorB"} = (stat($seq))[9]
+ unless defined $options->{"MTIME_$AorB"};
+
+ local $/ = "\n";
+ open F, "<$seq" or carp "$!: $seq";
+ $seqs[$i] = [<F>];
+ close F;
+
+ }
+ elsif ( $type eq "GLOB" || UNIVERSAL::isa( $seq, "IO::Handle" ) ) {
+ $options->{"OFFSET_$AorB"} = 1
+ unless defined $options->{"OFFSET_$AorB"};
+ local $/ = "\n";
+ $seqs[$i] = [<$seq>];
+ }
+ else {
+ confess "Can't handle input of type ", ref;
+ }
+ }
+
+ ## Config vars
+ my $output;
+ my $output_handler = $options->{OUTPUT};
+ my $type = ref $output_handler ;
+ if ( ! defined $output_handler ) {
+ $output = "";
+ $output_handler = sub { $output .= shift };
+ }
+ elsif ( $type eq "CODE" ) {
+ ## No problems, mate.
+ }
+ elsif ( $type eq "SCALAR" ) {
+ my $out_ref = $output_handler;
+ $output_handler = sub { $$out_ref .= shift };
+ }
+ elsif ( $type eq "ARRAY" ) {
+ my $out_ref = $output_handler;
+ $output_handler = sub { push @$out_ref, shift };
+ }
+ elsif ( $type eq "GLOB" || UNIVERSAL::isa $output_handler, "IO::Handle" ) {
+ my $output_handle = $output_handler;
+ $output_handler = sub { print $output_handle shift };
+ }
+ else {
+ croak "Unrecognized output type: $type";
+ }
+
+ my $style = $options->{STYLE};
+ $style = "Unified" unless defined $options->{STYLE};
+ $style = "Text::Diff::$style" if exists $internal_styles{$style};
+
+ if ( ! $style->can( "hunk" ) ) {
+ eval "require $style; 1" or die $@;
+ }
+
+ $style = $style->new
+ if ! ref $style && $style->can( "new" );
+
+ my $ctx_lines = $options->{CONTEXT};
+ $ctx_lines = 3 unless defined $ctx_lines;
+ $ctx_lines = 0 if $style->isa( "Text::Diff::OldStyle" );
+
+ my @keygen_args = $options->{KEYGEN_ARGS}
+ ? @{$options->{KEYGEN_ARGS}}
+ : ();
+
+ ## State vars
+ my $diffs = 0; ## Number of discards this hunk
+ my $ctx = 0; ## Number of " " (ctx_lines) ops pushed after last diff.
+ my @ops; ## ops (" ", +, -) in this hunk
+ my $hunks = 0; ## Number of hunks
+
+ my $emit_ops = sub {
+ $output_handler->( $style->file_header( @seqs, $options ) )
+ unless $hunks++;
+ $output_handler->( $style->hunk_header( @seqs, @_, $options ) );
+ $output_handler->( $style->hunk ( @seqs, @_, $options ) );
+ $output_handler->( $style->hunk_footer( @seqs, @_, $options ) );
+ };
+
+ ## We keep 2*ctx_lines so that if a diff occurs
+ ## at 2*ctx_lines we continue to grow the hunk instead
+ ## of emitting diffs and context as we go. We
+ ## need to know the total length of both of the two
+ ## subsequences so the line count can be printed in the
+ ## header.
+ my $dis_a = sub {push @ops, [@_[0,1],"-"]; ++$diffs ; $ctx = 0 };
+ my $dis_b = sub {push @ops, [@_[0,1],"+"]; ++$diffs ; $ctx = 0 };
+
+ traverse_sequences(
+ @seqs,
+ {
+ MATCH => sub {
+ push @ops, [@_[0,1]," "];
+
+ if ( $diffs && ++$ctx > $ctx_lines * 2 ) {
+ $emit_ops->( [ splice @ops, 0, $#ops - $ctx_lines ] );
+ $ctx = $diffs = 0;
+ }
+
+ ## throw away context lines that aren't needed any more
+ shift @ops if ! $diffs && @ops > $ctx_lines;
+ },
+ DISCARD_A => $dis_a,
+ DISCARD_B => $dis_b,
+ },
+ $options->{KEYGEN}, # pass in user arguments for key gen function
+ @keygen_args,
+ );
+
+ if ( $diffs ) {
+ $#ops -= $ctx - $ctx_lines if $ctx > $ctx_lines;
+ $emit_ops->( \@ops );
+ }
+
+ $output_handler->( $style->file_footer( @seqs, $options ) ) if $hunks;
+
+ return defined $output ? $output : $hunks;
+}
+
+
+sub _header {
+ my ( $h ) = @_;
+ my ( $p1, $fn1, $t1, $p2, $fn2, $t2 ) = @{$h}{
+ "FILENAME_PREFIX_A",
+ "FILENAME_A",
+ "MTIME_A",
+ "FILENAME_PREFIX_B",
+ "FILENAME_B",
+ "MTIME_B"
+ };
+
+ ## remember to change Text::Diff::Table if this logic is tweaked.
+ return "" unless defined $fn1 && defined $fn2;
+
+ return join( "",
+ $p1, " ", $fn1, defined $t1 ? "\t" . localtime $t1 : (), "\n",
+ $p2, " ", $fn2, defined $t2 ? "\t" . localtime $t2 : (), "\n",
+ );
+}
+
+## _range encapsulates the building of, well, ranges. Turns out there are
+## a few nuances.
+sub _range {
+ my ( $ops, $a_or_b, $format ) = @_;
+
+ my $start = $ops->[ 0]->[$a_or_b];
+ my $after = $ops->[-1]->[$a_or_b];
+
+ ## The sequence indexes in the lines are from *before* the OPCODE is
+ ## executed, so we bump the last index up unless the OP indicates
+ ## it didn't change.
+ ++$after
+ unless $ops->[-1]->[OPCODE] eq ( $a_or_b == A ? "+" : "-" );
+
+ ## convert from 0..n index to 1..(n+1) line number. The unless modifier
+ ## handles diffs with no context, where only one file is affected. In this
+ ## case $start == $after indicates an empty range, and the $start must
+ ## not be incremented.
+ my $empty_range = $start == $after;
+ ++$start unless $empty_range;
+
+ return
+ $start == $after
+ ? $format eq "unified" && $empty_range
+ ? "$start,0"
+ : $start
+ : $format eq "unified"
+ ? "$start,".($after-$start+1)
+ : "$start,$after";
+}
+
+
+sub _op_to_line {
+ my ( $seqs, $op, $a_or_b, $op_prefixes ) = @_;
+
+ my $opcode = $op->[OPCODE];
+ return () unless defined $op_prefixes->{$opcode};
+
+ my $op_sym = defined $op->[FLAG] ? $op->[FLAG] : $opcode;
+ $op_sym = $op_prefixes->{$op_sym};
+ return () unless defined $op_sym;
+
+ $a_or_b = $op->[OPCODE] ne "+" ? 0 : 1 unless defined $a_or_b;
+ return ( $op_sym, $seqs->[$a_or_b][$op->[$a_or_b]] );
+}
+
+
+=head1 Formatting Classes
+
+These functions implement the output formats. They are grouped in to classes
+so diff() can use class names to call the correct set of output routines and so
+that you may inherit from them easily. There are no constructors or instance
+methods for these classes, though subclasses may provide them if need be.
+
+Each class has file_header(), hunk_header(), hunk(), and footer() methods
+identical to those documented in the Text::Diff::Unified section. header() is
+called before the hunk() is first called, footer() afterwards. The default
+footer function is an empty method provided for overloading:
+
+ sub footer { return "End of patch\n" }
+
+Some output formats are provided by external modules (which are loaded
+automatically), such as L<Text::Diff::Table>. These are
+are documented here to keep the documentation simple.
+
+=over
+
+=head2 Text::Diff::Base
+
+Returns "" for all methods (other than C<new()>).
+
+=cut
+
+{
+ package Text::Diff::Base;
+ sub new {
+ my $proto = shift;
+ return bless { @_ }, ref $proto || $proto;
+ }
+
+ sub file_header { return "" }
+ sub hunk_header { return "" }
+ sub hunk { return "" }
+ sub hunk_footer { return "" }
+ sub file_footer { return "" }
+}
+
+
+=head2 Text::Diff::Unified
+
+ --- A Mon Nov 12 23:49:30 2001
+ +++ B Mon Nov 12 23:49:30 2001
+ @@ -2,13 +2,13 @@
+ 2
+ 3
+ 4
+ -5d
+ +5a
+ 6
+ 7
+ 8
+ 9
+ +9a
+ 10
+ 11
+ -11d
+ 12
+ 13
+
+=over
+
+=item file_header
+
+ $s = Text::Diff::Unified->file_header( $options );
+
+Returns a string containing a unified header. The sole parameter is the
+options hash passed in to diff(), containing at least:
+
+ FILENAME_A => $fn1,
+ MTIME_A => $mtime1,
+ FILENAME_B => $fn2,
+ MTIME_B => $mtime2
+
+May also contain
+
+ FILENAME_PREFIX_A => "---",
+ FILENAME_PREFIX_B => "+++",
+
+to override the default prefixes (default values shown).
+
+=cut
+
+@Text::Diff::Unified::ISA = qw( Text::Diff::Base );
+
+sub Text::Diff::Unified::file_header {
+ shift; ## No instance data
+ my $options = pop ;
+
+ _header(
+ { FILENAME_PREFIX_A => "---", FILENAME_PREFIX_B => "+++", %$options }
+ );
+}
+
+=item hunk_header
+
+ Text::Diff::Unified->hunk_header( \@ops, $options );
+
+Returns a string containing the output of one hunk of unified diff.
+
+=cut
+
+sub Text::Diff::Unified::hunk_header {
+ shift; ## No instance data
+ pop; ## Ignore options
+ my $ops = pop;
+
+ return join( "",
+ "@@ -",
+ _range( $ops, A, "unified" ),
+ " +",
+ _range( $ops, B, "unified" ),
+ " @@\n",
+ );
+}
+
+
+=item Text::Diff::Unified::hunk
+
+ Text::Diff::Unified->hunk( \@seq_a, \@seq_b, \@ops, $options );
+
+Returns a string containing the output of one hunk of unified diff.
+
+=cut
+
+sub Text::Diff::Unified::hunk {
+ shift; ## No instance data
+ pop; ## Ignore options
+ my $ops = pop;
+
+ my $prefixes = { "+" => "+", " " => " ", "-" => "-" };
+
+ return join "", map _op_to_line( \@_, $_, undef, $prefixes ), @$ops
+}
+
+
+=back
+
+=head2 Text::Diff::Table
+
+ +--+----------------------------------+--+------------------------------+
+ | |../Test-Differences-0.2/MANIFEST | |../Test-Differences/MANIFEST |
+ | |Thu Dec 13 15:38:49 2001 | |Sat Dec 15 02:09:44 2001 |
+ +--+----------------------------------+--+------------------------------+
+ | | * 1|Changes *
+ | 1|Differences.pm | 2|Differences.pm |
+ | 2|MANIFEST | 3|MANIFEST |
+ | | * 4|MANIFEST.SKIP *
+ | 3|Makefile.PL | 5|Makefile.PL |
+ | | * 6|t/00escape.t *
+ | 4|t/00flatten.t | 7|t/00flatten.t |
+ | 5|t/01text_vs_data.t | 8|t/01text_vs_data.t |
+ | 6|t/10test.t | 9|t/10test.t |
+ +--+----------------------------------+--+------------------------------+
+
+This format also goes to some pains to highlight "invisible" characters on
+differing elements by selectively escaping whitespace:
+
+ +--+--------------------------+--------------------------+
+ | |demo_ws_A.txt |demo_ws_B.txt |
+ | |Fri Dec 21 08:36:32 2001 |Fri Dec 21 08:36:50 2001 |
+ +--+--------------------------+--------------------------+
+ | 1|identical |identical |
+ * 2| spaced in | also spaced in *
+ * 3|embedded space |embedded tab *
+ | 4|identical |identical |
+ * 5| spaced in |\ttabbed in *
+ * 6|trailing spaces\s\s\n |trailing tabs\t\t\n *
+ | 7|identical |identical |
+ * 8|lf line\n |crlf line\r\n *
+ * 9|embedded ws |embedded\tws *
+ +--+--------------------------+--------------------------+
+
+See L</Text::Diff::Table> for more details, including how the whitespace
+escaping works.
+
+=head2 Text::Diff::Context
+
+ *** A Mon Nov 12 23:49:30 2001
+ --- B Mon Nov 12 23:49:30 2001
+ ***************
+ *** 2,14 ****
+ 2
+ 3
+ 4
+ ! 5d
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ - 11d
+ 12
+ 13
+ --- 2,14 ----
+ 2
+ 3
+ 4
+ ! 5a
+ 6
+ 7
+ 8
+ 9
+ + 9a
+ 10
+ 11
+ 12
+ 13
+
+Note: hunk_header() returns only "***************\n".
+
+=cut
+
+
+@Text::Diff::Context::ISA = qw( Text::Diff::Base );
+
+sub Text::Diff::Context::file_header {
+ _header { FILENAME_PREFIX_A=>"***", FILENAME_PREFIX_B=>"---", %{$_[-1]} };
+}
+
+
+sub Text::Diff::Context::hunk_header {
+ return "***************\n";
+}
+
+sub Text::Diff::Context::hunk {
+ shift; ## No instance data
+ pop; ## Ignore options
+ my $ops = pop;
+ ## Leave the sequences in @_[0,1]
+
+ my $a_range = _range( $ops, A, "" );
+ my $b_range = _range( $ops, B, "" );
+
+ ## Sigh. Gotta make sure that differences that aren't adds/deletions
+ ## get prefixed with "!", and that the old opcodes are removed.
+ my $after;
+ for ( my $start = 0; $start <= $#$ops ; $start = $after ) {
+ ## Scan until next difference
+ $after = $start + 1;
+ my $opcode = $ops->[$start]->[OPCODE];
+ next if $opcode eq " ";
+
+ my $bang_it;
+ while ( $after <= $#$ops && $ops->[$after]->[OPCODE] ne " " ) {
+ $bang_it ||= $ops->[$after]->[OPCODE] ne $opcode;
+ ++$after;
+ }
+
+ if ( $bang_it ) {
+ for my $i ( $start..($after-1) ) {
+ $ops->[$i]->[FLAG] = "!";
+ }
+ }
+ }
+
+ my $b_prefixes = { "+" => "+ ", " " => " ", "-" => undef, "!" => "! " };
+ my $a_prefixes = { "+" => undef, " " => " ", "-" => "- ", "!" => "! " };
+
+ return join( "",
+ "*** ", $a_range, " ****\n",
+ map( _op_to_line( \@_, $_, A, $a_prefixes ), @$ops ),
+ "--- ", $b_range, " ----\n",
+ map( _op_to_line( \@_, $_, B, $b_prefixes ), @$ops ),
+ );
+}
+=head2 Text::Diff::OldStyle
+
+ 5c5
+ < 5d
+ ---
+ > 5a
+ 9a10
+ > 9a
+ 12d12
+ < 11d
+
+Note: no file_header().
+
+=cut
+
+@Text::Diff::OldStyle::ISA = qw( Text::Diff::Base );
+
+sub _op {
+ my $ops = shift;
+ my $op = $ops->[0]->[OPCODE];
+ $op = "c" if grep $_->[OPCODE] ne $op, @$ops;
+ $op = "a" if $op eq "+";
+ $op = "d" if $op eq "-";
+ return $op;
+}
+
+sub Text::Diff::OldStyle::hunk_header {
+ shift; ## No instance data
+ pop; ## ignore options
+ my $ops = pop;
+
+ my $op = _op $ops;
+
+ return join "", _range( $ops, A, "" ), $op, _range( $ops, B, "" ), "\n";
+}
+
+sub Text::Diff::OldStyle::hunk {
+ shift; ## No instance data
+ pop; ## ignore options
+ my $ops = pop;
+ ## Leave the sequences in @_[0,1]
+
+ my $a_prefixes = { "+" => undef, " " => undef, "-" => "< " };
+ my $b_prefixes = { "+" => "> ", " " => undef, "-" => undef };
+
+ my $op = _op $ops;
+
+ return join( "",
+ map( _op_to_line( \@_, $_, A, $a_prefixes ), @$ops ),
+ $op eq "c" ? "---\n" : (),
+ map( _op_to_line( \@_, $_, B, $b_prefixes ), @$ops ),
+ );
+}
+
+=head1 LIMITATIONS
+
+Must suck both input files entirely in to memory and store them with a normal
+amount of Perlish overhead (one array location) per record. This is implied by
+the implementation of Algorithm::Diff, which takes two arrays. If
+Algorithm::Diff ever offers an incremental mode, this can be changed (contact
+the maintainers of Algorithm::Diff and Text::Diff if you need this; it
+shouldn't be too terribly hard to tie arrays in this fashion).
+
+Does not provide most of the more refined GNU diff options: recursive directory
+tree scanning, ignoring blank lines / whitespace, etc., etc. These can all be
+added as time permits and need arises, many are rather easy; patches quite
+welcome.
+
+Uses closures internally, this may lead to leaks on C<perl> versions 5.6.1 and
+prior if used many times over a process' life time.
+
+=head1 AUTHOR
+
+Barrie Slaymaker <barries@slaysys.com>.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2001, Barrie Slaymaker. All Rights Reserved.
+
+You may use this under the terms of either the Artistic License or GNU Public
+License v 2.0 or greater.
+
+=cut
+
+1;
--- /dev/null
+package Text::Diff::Table;
+
+=head1 NAME
+
+ Text::Diff::Table - Text::Diff plugin to generate "table" format output
+
+=head1 SYNOPSIS
+
+ use Text::Diff;
+
+ diff \@a, $b { STYLE => "Table" };
+
+=head1 DESCRIPTION
+
+This is a plugin output formatter for Text::Diff that generates "table" style
+diffs:
+
+ +--+----------------------------------+--+------------------------------+
+ | |../Test-Differences-0.2/MANIFEST | |../Test-Differences/MANIFEST |
+ | |Thu Dec 13 15:38:49 2001 | |Sat Dec 15 02:09:44 2001 |
+ +--+----------------------------------+--+------------------------------+
+ | | * 1|Changes *
+ | 1|Differences.pm | 2|Differences.pm |
+ | 2|MANIFEST | 3|MANIFEST |
+ | | * 4|MANIFEST.SKIP *
+ | 3|Makefile.PL | 5|Makefile.PL |
+ | | * 6|t/00escape.t *
+ | 4|t/00flatten.t | 7|t/00flatten.t |
+ | 5|t/01text_vs_data.t | 8|t/01text_vs_data.t |
+ | 6|t/10test.t | 9|t/10test.t |
+ +--+----------------------------------+--+------------------------------+
+
+This format also goes to some pains to highlight "invisible" characters on
+differing elements by selectively escaping whitespace. Each element is split
+in to three segments (leading whitespace, body, trailing whitespace). If
+whitespace differs in a segement, that segment is whitespace escaped.
+
+Here is an example of the selective whitespace.
+
+ +--+--------------------------+--------------------------+
+ | |demo_ws_A.txt |demo_ws_B.txt |
+ | |Fri Dec 21 08:36:32 2001 |Fri Dec 21 08:36:50 2001 |
+ +--+--------------------------+--------------------------+
+ | 1|identical |identical |
+ * 2| spaced in | also spaced in *
+ * 3|embedded space |embedded tab *
+ | 4|identical |identical |
+ * 5| spaced in |\ttabbed in *
+ * 6|trailing spaces\s\s\n |trailing tabs\t\t\n *
+ | 7|identical |identical |
+ * 8|lf line\n |crlf line\r\n *
+ * 9|embedded ws |embedded\tws *
+ +--+--------------------------+--------------------------+
+
+Here's why the lines do or do not have whitespace escaped:
+
+=over
+
+=item lines 1, 4, 7 don't differ, no need.
+
+=item lines 2, 3 differ in non-whitespace, no need.
+
+=item lines 5, 6, 8, 9 all have subtle ws changes.
+
+=back
+
+Whether or not line 3 should have that tab character escaped is a judgement
+call; so far I'm choosing not to.
+
+=cut
+
+@ISA = qw( Text::Diff::Base Exporter );
+@EXPORT_OK = qw( expand_tabs );
+$VERSION = 1.2;
+
+use strict;
+use Carp;
+
+
+my %escapes = map {
+ my $c =
+ $_ eq '"' || $_ eq '$' ? qq{'$_'}
+ : $_ eq "\\" ? qq{"\\\\"}
+ : qq{"$_"} ;
+ ( ord eval $c => $_ )
+} (
+ map( chr, 32..126),
+ map( sprintf( "\\x%02x", $_ ), ( 0..31, 127..255 ) ),
+# map( "\\c$_", "A".."Z"),
+ "\\t", "\\n", "\\r", "\\f", "\\b", "\\a", "\\e"
+ ## NOTE: "\\\\" is not here because some things are explicitly
+ ## escaped before escape() is called and we don't want to
+ ## double-escape "\". Also, in most texts, leaving "\" more
+ ## readable makes sense.
+) ;
+
+
+sub expand_tabs($) {
+ my $s = shift ;
+ my $count=0;
+ $s =~ s{(\t)(\t*)|([^\t]+)}{
+ if ( $1 ) {
+ my $spaces = " " x ( 8 - $count % 8 + 8 * length $2 );
+ $count = 0;
+ $spaces;
+ }
+ else {
+ $count += length $3;
+ $3;
+ }
+ }ge;
+
+ return $s;
+}
+
+
+sub trim_trailing_line_ends($) {
+ my $s = shift;
+ $s =~ s/[\r\n]+(?!\n)$//;
+ return $s;
+}
+
+sub escape($);
+
+{
+ ## use utf8 if available. don't if not.
+ my $escaper = <<'EOCODE' ;
+ sub escape($) {
+ use utf8;
+ join "", map {
+ $_ = ord;
+ exists $escapes{$_}
+ ? $escapes{$_}
+ : sprintf( "\\x{%04x}", $_ ) ;
+ } split //, shift ;
+ }
+
+ 1;
+EOCODE
+ unless ( eval $escaper ) {
+ $escaper =~ s/ *use *utf8 *;\n// or die "Can't drop use utf8;";
+ eval $escaper or die $@;
+ }
+}
+
+
+sub new {
+ my $proto = shift;
+ return bless { @_ }, $proto
+}
+
+my $missing_elt = [ "", "" ];
+
+sub hunk {
+ my $self = shift;
+ my @seqs = ( shift, shift );
+ my $ops = shift; ## Leave sequences in @_[0,1]
+ my $options = shift;
+
+ my ( @A, @B );
+ for ( @$ops ) {
+ my $opcode = $_->[Text::Diff::OPCODE()];
+ if ( $opcode eq " " ) {
+ push @A, $missing_elt while @A < @B;
+ push @B, $missing_elt while @B < @A;
+ }
+ push @A, [ $_->[0] + ( $options->{OFFSET_A} || 0), $seqs[0][$_->[0]] ]
+ if $opcode eq " " || $opcode eq "-";
+ push @B, [ $_->[1] + ( $options->{OFFSET_B} || 0), $seqs[1][$_->[1]] ]
+ if $opcode eq " " || $opcode eq "+";
+ }
+
+ push @A, $missing_elt while @A < @B;
+ push @B, $missing_elt while @B < @A;
+ my @elts;
+ for ( 0..$#A ) {
+ my ( $A, $B ) = (shift @A, shift @B );
+
+ ## Do minimal cleaning on identical elts so these look "normal":
+ ## tabs are expanded, trailing newelts removed, etc. For differing
+ ## elts, make invisible characters visible if the invisible characters
+ ## differ.
+ my $elt_type = $B == $missing_elt ? "A" :
+ $A == $missing_elt ? "B" :
+ $A->[1] eq $B->[1] ? "="
+ : "*";
+ if ( $elt_type ne "*" ) {
+ if ( $elt_type eq "=" || $A->[1] =~ /\S/ || $B->[1] =~ /\S/ ) {
+ $A->[1] = escape trim_trailing_line_ends expand_tabs $A->[1];
+ $B->[1] = escape trim_trailing_line_ends expand_tabs $B->[1];
+ }
+ else {
+ $A->[1] = escape $A->[1];
+ $B->[1] = escape $B->[1];
+ }
+ }
+ else {
+ ## not using \z here for backcompat reasons.
+ $A->[1] =~ /^(\s*?)([^ \t].*?)?(\s*)(?![\n\r])$/s;
+ my ( $l_ws_A, $body_A, $t_ws_A ) = ( $1, $2, $3 );
+ $body_A = "" unless defined $body_A;
+ $B->[1] =~ /^(\s*?)([^ \t].*?)?(\s*)(?![\n\r])$/s;
+ my ( $l_ws_B, $body_B, $t_ws_B ) = ( $1, $2, $3 );
+ $body_B = "" unless defined $body_B;
+
+ my $added_escapes;
+
+ if ( $l_ws_A ne $l_ws_B ) {
+ ## Make leading tabs visible. Other non-' ' chars
+ ## will be dealt with in escape(), but this prevents
+ ## tab expansion from hiding tabs by making them
+ ## look like ' '.
+ $added_escapes = 1 if $l_ws_A =~ s/\t/\\t/g;
+ $added_escapes = 1 if $l_ws_B =~ s/\t/\\t/g;
+ }
+
+ if ( $t_ws_A ne $t_ws_B ) {
+ ## Only trailing whitespace gets the \s treatment
+ ## to make it obvious what's going on.
+ $added_escapes = 1 if $t_ws_A =~ s/ /\\s/g;
+ $added_escapes = 1 if $t_ws_B =~ s/ /\\s/g;
+ $added_escapes = 1 if $t_ws_A =~ s/\t/\\t/g;
+ $added_escapes = 1 if $t_ws_B =~ s/\t/\\t/g;
+ }
+ else {
+ $t_ws_A = $t_ws_B = "";
+ }
+
+ my $do_tab_escape = $added_escapes || do {
+ my $expanded_A = expand_tabs join( $body_A, $l_ws_A, $t_ws_A );
+ my $expanded_B = expand_tabs join( $body_B, $l_ws_B, $t_ws_B );
+ $expanded_A eq $expanded_B;
+ };
+
+ my $do_back_escape = $do_tab_escape || do {
+ my ( $unescaped_A, $escaped_A,
+ $unescaped_B, $escaped_B
+ ) =
+ map
+ join( "", /(\\.)/g ),
+ map {
+ ( $_, escape $_ )
+ }
+ expand_tabs join( $body_A, $l_ws_A, $t_ws_A ),
+ expand_tabs join( $body_B, $l_ws_B, $t_ws_B );
+ $unescaped_A ne $unescaped_B && $escaped_A eq $escaped_B;
+ };
+
+ if ( $do_back_escape ) {
+ $body_A =~ s/\\/\\\\/g;
+ $body_B =~ s/\\/\\\\/g;
+ }
+
+ my $line_A = join $body_A, $l_ws_A, $t_ws_A;
+ my $line_B = join $body_B, $l_ws_B, $t_ws_B;
+
+ unless ( $do_tab_escape ) {
+ $line_A = expand_tabs $line_A;
+ $line_B = expand_tabs $line_B;
+ }
+
+ $A->[1] = escape $line_A;
+ $B->[1] = escape $line_B;
+ }
+
+ push @elts, [ @$A, @$B, $elt_type ];
+ }
+
+
+ push @{$self->{ELTS}}, @elts, ["bar"];
+ return "";
+}
+
+
+sub _glean_formats {
+ my $self = shift ;
+}
+
+
+sub file_footer {
+ my $self = shift;
+ my @seqs = (shift,shift);
+ my $options = pop;
+
+ my @heading_lines ;
+
+ if ( defined $options->{FILENAME_A} || defined $options->{FILENAME_B} ) {
+ push @heading_lines, [
+ map(
+ {
+ ( "", escape( defined $_ ? $_ : "<undef>" ) );
+ }
+ ( @{$options}{qw( FILENAME_A FILENAME_B)} )
+ ),
+ "=",
+ ];
+ }
+
+ if ( defined $options->{MTIME_A} || defined $options->{MTIME_B} ) {
+ push @heading_lines, [
+ map( {
+ ( "",
+ escape(
+ ( defined $_ && length $_ )
+ ? localtime $_
+ : ""
+ )
+ );
+ }
+ @{$options}{qw( MTIME_A MTIME_B )}
+ ),
+ "=",
+ ];
+ }
+
+ if ( defined $options->{INDEX_LABEL} ) {
+ push @heading_lines, [ "", "", "", "", "=" ] unless @heading_lines;
+ $heading_lines[-1]->[0] = $heading_lines[-1]->[2] =
+ $options->{INDEX_LABEL};
+ }
+
+ ## Not ushifting on to @{$self->{ELTS}} in case it's really big. Want
+ ## to avoid the overhead.
+
+ my $four_column_mode = 0;
+ for my $cols ( @heading_lines, @{$self->{ELTS}} ) {
+ next if $cols->[-1] eq "bar";
+ if ( $cols->[0] ne $cols->[2] ) {
+ $four_column_mode = 1;
+ last;
+ }
+ }
+
+ unless ( $four_column_mode ) {
+ for my $cols ( @heading_lines, @{$self->{ELTS}} ) {
+ next if $cols->[-1] eq "bar";
+ splice @$cols, 2, 1;
+ }
+ }
+
+ my @w = (0,0,0,0);
+ for my $cols ( @heading_lines, @{$self->{ELTS}} ) {
+ next if $cols->[-1] eq "bar";
+ for my $i (0..($#$cols-1)) {
+ $w[$i] = length $cols->[$i]
+ if defined $cols->[$i] && length $cols->[$i] > $w[$i];
+ }
+ }
+
+ my %fmts = $four_column_mode
+ ? (
+ "=" => "| %$w[0]s|%-$w[1]s | %$w[2]s|%-$w[3]s |\n",
+ "A" => "* %$w[0]s|%-$w[1]s * %$w[2]s|%-$w[3]s |\n",
+ "B" => "| %$w[0]s|%-$w[1]s * %$w[2]s|%-$w[3]s *\n",
+ "*" => "* %$w[0]s|%-$w[1]s * %$w[2]s|%-$w[3]s *\n",
+ )
+ : (
+ "=" => "| %$w[0]s|%-$w[1]s |%-$w[2]s |\n",
+ "A" => "* %$w[0]s|%-$w[1]s |%-$w[2]s |\n",
+ "B" => "| %$w[0]s|%-$w[1]s |%-$w[2]s *\n",
+ "*" => "* %$w[0]s|%-$w[1]s |%-$w[2]s *\n",
+ );
+
+ $fmts{bar} = sprintf $fmts{"="}, "", "", "", "" ;
+ $fmts{bar} =~ s/\S/+/g;
+ $fmts{bar} =~ s/ /-/g;
+ return join( "",
+ map {
+ sprintf( $fmts{$_->[-1]}, @$_ )
+ } (
+ ["bar"],
+ @heading_lines,
+ @heading_lines ? ["bar"] : (),
+ @{$self->{ELTS}},
+ ),
+ );
+
+ @{$self->{ELTS}} = [];
+}
+
+
+=head1 LIMITATIONS
+
+Table formatting requires buffering the entire diff in memory in order to
+calculate column widths. This format should only be used for smaller
+diffs.
+
+Assumes tab stops every 8 characters, as $DIETY intended.
+
+Assumes all character codes >= 127 need to be escaped as hex codes, ie that the
+user's terminal is ASCII, and not even "high bit ASCII", capable. This can be
+made an option when the need arises.
+
+Assumes that control codes (character codes 0..31) that don't have slash-letter
+escapes ("\n", "\r", etc) in Perl are best presented as hex escapes ("\x01")
+instead of octal ("\001") or control-code ("\cA") escapes.
+
+=head1 AUTHOR
+
+ Barrie Slaymaker <barries@slaysys.com>
+
+=head1 LICENSE
+
+Copyright 2001 Barrie Slaymaker, All Rights Reserved.
+
+You may use this software under the terms of the GNU public license, any
+version, or the Artistic license.
+
+=cut
+
+1;
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use strict ;
+use Test ;
+use Text::Diff ;
+use Algorithm::Diff qw( traverse_sequences ) ;
+
+my @A = map "$_\n", qw( 1 a 2 b 3 ) ;
+my @B = map "$_\n", qw( 1 A 2 B 3 ) ;
+
+## This tests both that we can overload all 5 methods and that all 5
+## methods are called by diff() (and in the right order :)
+
+my $f = "My::Diff::Format" ;
+my $diff = diff \@A, \@B, { CONTEXT => 0, STYLE => $f } ;
+
+my @tests = (
+sub {
+ if ( $diff =~ /(^${f}::.*){8}/sm ) {
+ ok 1 ;
+ }
+ else {
+ ok $diff, "8 lines of output" ;
+ }
+},
+
+sub {
+ if ( $diff =~ m{
+ file_header.*
+ hunk_header.*
+ hunk.*
+ hunk_footer.*
+ hunk_header.*
+ hunk.*
+ hunk_footer.*
+ file_footer
+ }sx
+ ) {
+ ok 1 ;
+ }
+ else {
+ ok $diff, "proper ordering (see test source)" ;
+ }
+},
+
+) ;
+
+plan tests => scalar @tests ;
+
+$_->() for @tests ;
+
+package My::Diff::Format ;
+
+use Data::Dumper ;
+
+sub _dump {
+ my $prefix = (caller(1))[3] ;
+ local $Data::Dumper::Indent = 0 ;
+ local $Data::Dumper::Terse = 1 ;
+
+ join( "",
+ map { s/^/$prefix: /mg ; $_ ; } join ", ", map {
+ my $s = ref $_ ? Dumper $_ : $_ ;
+ $s =~ s/([\000-\026])/sprintf "\0x%02x", ord $1/ge ;
+ $s ;
+ } @_
+ ) . "\n" ;
+}
+
+sub file_header { &_dump }
+sub hunk_header { &_dump }
+sub hunk { &_dump }
+sub hunk_footer { &_dump }
+sub file_footer { &_dump }
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use strict ;
+use Test ;
+use Text::Diff ;
+use Algorithm::Diff qw( traverse_sequences ) ;
+
+## Each test specifies options to pass to "diff" when the --update option
+## is present in @ARGV and options to pass to Text::Diff::diff when the
+## tests are run.
+my @tests= (
+ ["-u",
+ ''
+ ],
+ ["-c",
+ 'STYLE => "Context"'
+ ],
+ ["-C0",
+ 'STYLE => "Context", CONTEXT => 0'
+ ],
+ ["-U0",
+ 'STYLE => "Unified", CONTEXT => 0'
+ ],
+ ["",
+ 'STYLE => "OldStyle"'
+ ],
+) ;
+
+my @A = map "$_\n", qw( 1 2 3 4 5d 6 7 8 9 10 11 11d 12 13 ) ;
+my @B = map "$_\n", qw( 1 2 3 4 5a 6 7 8 9 9a 10 11 12 13 ) ;
+
+my $sep = ( "----8<----" x 7 ) . "\n" ;
+
+if ( grep "--update", @ARGV ) {
+ my $version = `diff -v` ;
+
+ die "Could not determine your diff's version"
+ unless defined $version && length $version ;
+ chomp $version ;
+ die "Requires GNU's diff, not '$version'"
+ unless $version =~ /GNU/ ;
+
+ ## Here are the two files to feed to diff
+ open A, ">A" or die $! ; print A @A ; close A ;
+ open B, ">B" or die $! ; print B @B ; close B ;
+
+ my $mtime_A = time ;
+ my $mtime_B = $mtime_A + 1 ;
+
+ utime $mtime_A, $mtime_A, "A" or die $! ;
+ utime $mtime_B, $mtime_B, "B" or die $! ;
+
+ my $file_options = <<END_OPTIONS ;
+FILENAME_A => "A",
+MTIME_A => $mtime_A,
+FILENAME_B => "B",
+MTIME_B => $mtime_B,
+END_OPTIONS
+
+ open ME, "<$0" or die $! ;
+ my $me = join( "", <ME> ) ;
+ close ME or die $! ;
+
+ open BAK, ">$0.bak" or die $! ;
+ print BAK $me or die $! ;
+ close BAK or die $! ;
+
+ my @diffs = map scalar `diff $_->[0] A B`, @tests ;
+
+ for ( @diffs ) {
+ s/(Sun|Mon|Tue|Wed|Thu|Fri|Sat).*/<MTIME_A>/m ;
+ s/(Sun|Mon|Tue|Wed|Thu|Fri|Sat).*/<MTIME_B>/m ;
+ }
+
+ $me =~ s/^(__DATA__\n).*//ms ;
+ open ME, ">$0" or die $! ;
+ print ME
+ $me,
+ "__DATA__\n",
+ join $sep, "$file_options\n", @diffs
+ or die $! ;
+
+ close ME or die $! ;
+# unlink "A" or warn "$! unlinking A" ;
+# unlink "B" or warn "$! unlinking B" ;
+ exit 0 ;
+}
+
+## Ok, we're not updating, so run the tests...
+
+my @data = split $sep, join "", <DATA> ;
+close DATA or die $! ;
+die "Found " . @data,
+ " elements, not ", ( @tests + 1 ),
+ ", time to --update?\n"
+ unless @data == @tests + 1 ;
+
+my @file_options = eval "(" . shift( @data ) . ")" ;
+die if $@ ;
+
+my ( $mtime_A, $mtime_B ) ;
+
+{
+ my %o = @file_options ;
+ $mtime_A = $o{MTIME_A} ;
+ $mtime_B = $o{MTIME_B} ;
+}
+
+plan tests => scalar @tests ;
+for ( @tests ) {
+ my ( $diff_opts, $Diff_opts ) = @$_ ;
+ my $expect = shift @data ;
+
+ $expect =~ s/<MTIME_A>/localtime $mtime_A/e ;
+ $expect =~ s/<MTIME_B>/localtime $mtime_B/e ;
+
+ my @Diff_opts = eval "($Diff_opts)" ;
+ die if $@ ;
+
+ my $output = diff \@A, \@B, { @file_options, @Diff_opts } ;
+ if ( $output eq $expect ) {
+ ok( 1 ) ;
+ }
+ else {
+ ok( 0 ) ;
+ warn "# diff options: $diff_opts\n" ;
+ warn "# my options: $Diff_opts\n" ;
+ ## Merge the outputs using A::D
+ my @E = split /^/, $expect ;
+ my @G = split /^/, $output ;
+ my $w = length "Expected" ;
+ for ( @E, @G ) {
+ s/\n/\\n/g ;
+ $w = length if length > $w ;
+ }
+ my $fmt = "# %-${w}s %-2s %-${w}s\n" ;
+ printf STDERR $fmt, "Expected", " ", "Got" ;
+ print STDERR "# ", "-" x ( $w * 2 + 4 ), "\n" ;
+
+ my ( $E_start, $G_start ) ;
+ my $print_diff = sub {
+ my ( $E_end, $G_end ) = @_ ;
+ if ( defined $E_start || defined $G_start ) {
+ while ( $E_start < $E_end || $G_start < $G_end ) {
+ printf STDERR (
+ $fmt,
+ $E_start < $E_end ? $E[$E_start] : "",
+ "!=",
+ $G_start < $G_end ? $G[$G_start] : ""
+ ) ;
+
+ ++$E_start ;
+ ++$G_start ;
+ }
+ $E_start = $G_start = undef ;
+
+ }
+ } ;
+
+ my $dis = sub {
+ $E_start = $_[0] unless defined $E_start ;
+ $G_start = $_[1] unless defined $G_start ;
+ } ;
+
+ traverse_sequences(
+ \@E, \@G,
+ {
+ MATCH => sub {
+ $print_diff->( @_ ) ;
+ printf STDERR $fmt, $E[$_[0]], "==", $G[$_[1]] ;
+ },
+ DISCARD_A => $dis,
+ DISCARD_B => $dis,
+ }
+ ) ;
+ $print_diff->( scalar @E, scalar @G ) ;
+
+ print STDERR "# ", "-" x ( $w * 2 + 4 ), "\n" ;
+ print STDERR "#\n" ;
+ }
+}
+
+
+__DATA__
+FILENAME_A => "A",
+MTIME_A => 1007983243,
+FILENAME_B => "B",
+MTIME_B => 1007983244,
+
+----8<--------8<--------8<--------8<--------8<--------8<--------8<----
+--- A <MTIME_A>
++++ B <MTIME_B>
+@@ -2,13 +2,13 @@
+ 2
+ 3
+ 4
+-5d
++5a
+ 6
+ 7
+ 8
+ 9
++9a
+ 10
+ 11
+-11d
+ 12
+ 13
+----8<--------8<--------8<--------8<--------8<--------8<--------8<----
+*** A <MTIME_A>
+--- B <MTIME_B>
+***************
+*** 2,14 ****
+ 2
+ 3
+ 4
+! 5d
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+- 11d
+ 12
+ 13
+--- 2,14 ----
+ 2
+ 3
+ 4
+! 5a
+ 6
+ 7
+ 8
+ 9
++ 9a
+ 10
+ 11
+ 12
+ 13
+----8<--------8<--------8<--------8<--------8<--------8<--------8<----
+*** A <MTIME_A>
+--- B <MTIME_B>
+***************
+*** 5 ****
+! 5d
+--- 5 ----
+! 5a
+***************
+*** 9 ****
+--- 10 ----
++ 9a
+***************
+*** 12 ****
+- 11d
+--- 12 ----
+----8<--------8<--------8<--------8<--------8<--------8<--------8<----
+--- A <MTIME_A>
++++ B <MTIME_B>
+@@ -5 +5 @@
+-5d
++5a
+@@ -9,0 +10 @@
++9a
+@@ -12 +12,0 @@
+-11d
+----8<--------8<--------8<--------8<--------8<--------8<--------8<----
+5c5
+< 5d
+---
+> 5a
+9a10
+> 9a
+12d12
+< 11d
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use strict;
+use Test;
+use Text::Diff;
+
+my @A = map "$_\n", qw( 1 2 3 4 );
+my @B = map "$_\n", qw( 1 2 3 5 );
+
+my $A = join "", @A;
+my $B = join "", @B;
+
+my $Af = "io_A";
+my $Bf = "io_B";
+
+open A, ">$Af" or die $!; print A @A or die $! ; close A or die $! ;
+open B, ">$Bf" or die $!; print B @B or die $! ; close B or die $! ;
+
+my @tests = (
+sub { ok !diff \@A, \@A },
+sub {
+ my $d = diff \@A, \@B;
+ $d =~ /-4.*\+5/s ? ok 1 : ok $d, "a valid diff";
+},
+sub { ok !diff \$A, \$A },
+sub {
+ my $d = diff \$A, \$B;
+ $d =~ /-4.*\+5/s ? ok 1 : ok $d, "a valid diff";
+},
+sub { ok !diff $Af, $Af },
+sub {
+ my $d = diff $Af, $Bf;
+ $d =~ /-4.*\+5/s ? ok 1 : ok $d, "a valid diff";
+},
+sub {
+ open A1, "<$Af" or die $!;
+ open A2, "<$Af" or die $!;
+ ok !diff \*A1, \*A2;
+ close A1;
+ close A2;
+},
+sub {
+ open A, "<$Af" or die $!;
+ open B, "<$Bf" or die $!;
+ my $d = diff \*A, \*B;
+ $d =~ /-4.*\+5/s ? ok 1 : ok $d, "a valid diff";
+ close A;
+ close B;
+},
+sub {
+ ok !diff sub { \@A}, sub { \@A };
+},
+sub {
+ my $d = diff sub { \@A }, sub { \@B };
+ $d =~ /-4.*\+5/s ? ok 1 : ok $d, "a valid diff";
+},
+);
+
+plan tests => scalar @tests;
+
+$_->() for @tests;
+
+unlink "io_A" or warn $!;
+unlink "io_B" or warn $!;
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use strict ;
+use Test ;
+use Text::Diff ;
+
+my @A = map "$_\n", qw( 1 2 3_ 4_ ) ;
+my @B = map "$_\n", qw( 1 2_ 3 4_ ) ;
+
+my @tests = (
+sub {
+ ok !diff \@A, \@B, {
+ KEYGEN => sub {
+ local $_ = shift ;
+ s/_+//g ;
+ return $_ . shift ;
+ },
+ KEYGEN_ARGS => [ "args" ],
+ } ;
+},
+) ;
+
+plan tests => scalar @tests ;
+
+$_->() for @tests ;
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use strict ;
+use Test ;
+use Text::Diff ;
+
+my @A = map "$_\n", qw( 1 2 3 4 ) ;
+my @B = map "$_\n", qw( 1 2 3 5 ) ;
+
+sub _d($) { diff \@A, \@B, { OUTPUT => shift } }
+
+sub slurp { open SLURP, "<" . shift or die $! ; return join "", <SLURP> }
+
+my $expected = _d undef ;
+
+my @tests = (
+sub { ok $expected =~ tr/\n// },
+
+sub { my $o ; _d sub { $o .= shift } ; ok $o, $expected },
+
+sub { my @o ; _d \@o ; ok join( "", @o ), $expected },
+
+sub {
+ open F, ">output.t.foo" or die $! ;
+ _d \*F ;
+ close F or die $! ;
+ ok slurp "output.t.foo", $expected ;
+ unlink "output.t.foo" or warn $! ;
+},
+
+sub {
+ require IO::File ;
+ my $fh = IO::File->new( ">output.t.foo" ) ;
+ _d $fh ;
+ $fh = undef ;
+ ok slurp "output.t.foo", $expected ;
+ unlink "output.t.foo" or warn $! ;
+},
+
+sub { ok 0 < index( diff( \"\n", \"", { STYLE => "Table" } ), "\\n" ) },
+
+# test for bug reported by Ilya Martynov <ilya@martynov.org>
+sub { ok diff( \"", \"" ), "" },
+sub { ok diff( \"A", \"A" ), "" },
+) ;
+
+plan tests => scalar @tests ;
+
+$_->() for @tests ;
--- /dev/null
+#!/usr/local/bin/perl -w
+
+use strict ;
+use Test ;
+use Text::Diff ;
+
+sub t($$$$) {
+ my ( $a, $b, $exp_a, $exp_b ) = @_;
+ my $d = diff \$a, \$b, { STYLE => "Table" };
+ my $re = qr/^\*.*\|\Q$exp_a\E\s*\|\Q$exp_b\E\s*\*$/m;
+
+ ## Older Test.pms don't support ok( $foo, qr// );
+ $d =~ $re
+ ? ok 1
+ : ok "\n" . $d, "a match for " . $re;
+}
+
+sub slurp { open SLURP, "<" . shift or die $! ; return join "", <SLURP> }
+
+my @tests = (
+sub { t " ", "\t", "\\s", "\\t" },
+sub { t " a", "\ta", " a", "\\ta" },
+sub { t "a ", "a\t", "a\\s", "a\\t" },
+sub { t "\t", "\\t", "\\t", "\\\\t" },
+sub { t "\ta", "\tb", " a", " b" },
+sub { t "-\ta", "-\tb", "- a", "- b" },
+sub { t "\\ta", "\\tb", "\\ta", "\\tb" },
+) ;
+
+plan tests => scalar @tests ;
+
+$_->() for @tests ;
--- /dev/null
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+Format: 1.0
+Source: libtext-diff-perl
+Binary: libtext-diff-perl
+Architecture: all
+Version: 0.35-3
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: Jay Bonci <jaybonci@debian.org>, Gunnar Wolf <gwolf@debian.org>
+Homepage: http://search.cpan.org/dist/Text-Diff/
+Standards-Version: 3.7.3
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libtext-diff-perl/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libtext-diff-perl/
+Build-Depends: debhelper (>> 6)
+Build-Depends-Indep: libalgorithm-diff-perl, perl (>= 5.8)
+Files:
+ 4931662ea353384dec2a54a71b26ee8c 14746 libtext-diff-perl_0.35.orig.tar.gz
+ 57d54da84a53ab6701438a3b40df1e30 2174 libtext-diff-perl_0.35-3.diff.gz
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.6 (GNU/Linux)
+
+iD8DBQFHvK7j2A7zWou1J68RAngCAKDHp26Th2vkLo/05bieMwR13iUUvwCfWZ3v
+YLRwS17/Kne1bcpcc9sjXSM=
+=TZhx
+-----END PGP SIGNATURE-----
--- /dev/null
+Format: 1.0
+Source: libtext-diff-perl
+Version: 0.35-3maemo1
+Binary: libtext-diff-perl
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Architecture: all
+Standards-Version: 3.7.3
+Build-Depends: debhelper7
+Build-Depends-Indep: perl (>= 5.8), libalgorithm-diff-perl
+Uploaders: Jay Bonci <jaybonci@debian.org>, Gunnar Wolf <gwolf@debian.org>
+Files:
+ 4931662ea353384dec2a54a71b26ee8c 14746 libtext-diff-perl_0.35.orig.tar.gz
+ 673f94f18ab2b78b33a89f567af4263c 2239 libtext-diff-perl_0.35-3maemo1.diff.gz
--- /dev/null
+Format: 1.7
+Date: Wed, 14 Apr 2010 07:11:11 +0100
+Source: libtext-diff-perl
+Binary: libtext-diff-perl
+Architecture: source all
+Version: 0.35-3maemo1
+Distribution: fremantle
+Urgency: low
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Changed-By: Nito Martinez <Nito@Qindel.ES>
+Description:
+ libtext-diff-perl - Perform diffs on files and record sets in perl
+Changes:
+ libtext-diff-perl (0.35-3maemo1) fremantle; urgency=low
+ .
+ * New Maemo packaging
+Files:
+ 846652002f808ccaa24fcbb8e2870a99 527 perl optional libtext-diff-perl_0.35-3maemo1.dsc
+ 673f94f18ab2b78b33a89f567af4263c 2239 perl optional libtext-diff-perl_0.35-3maemo1.diff.gz
+ c7d156b3c5df7611d4cbd195be28f168 23710 perl optional libtext-diff-perl_0.35-3maemo1_all.deb
projects / pkg-perl / commitdiff