Browse Source

Merging in newer Wala stuff.

pull/1/head
Brennen Bearnes 13 years ago
parent
commit
f43bf714c0
30 changed files with 118 additions and 10938 deletions
  1. +0
    -0
      benchmark.pl
  2. +91
    -116
      lib/Wala.pm
  3. +15
    -0
      t/SpitTest.pm
  4. +12
    -0
      t/spittest.pl
  5. +0
    -0
      t/validate.pl
  6. +0
    -0
      t/wala_test.pl
  7. +0
    -0
      t/wala_validate.pl
  8. +0
    -0
      wala.pl
  9. +0
    -24
      wala/Makefile
  10. +0
    -98
      wala/README
  11. +0
    -30
      wala/TESTING
  12. +0
    -25
      wala/VALIDATION
  13. +0
    -39
      wala/default.conf.pl
  14. +0
    -222
      wala/lib/Carp/Clan.pm
  15. +0
    -95
      wala/lib/Carp/Clan.pod
  16. +0
    -1848
      wala/lib/Test/Builder.pm
  17. +0
    -182
      wala/lib/Test/Builder/Module.pm
  18. +0
    -647
      wala/lib/Test/Builder/Tester.pm
  19. +0
    -50
      wala/lib/Test/Builder/Tester/Color.pm
  20. +0
    -275
      wala/lib/Test/HTML/W3C.pm
  21. +0
    -1547
      wala/lib/Test/More.pm
  22. +0
    -230
      wala/lib/Test/Simple.pm
  23. +0
    -603
      wala/lib/Test/Tutorial.pod
  24. +0
    -3499
      wala/lib/Text/Textile.pm
  25. +0
    -593
      wala/lib/WebService/Validator/HTML/W3C.pm
  26. +0
    -32
      wala/lib/WebService/Validator/HTML/W3C/Error.pm
  27. +0
    -32
      wala/lib/WebService/Validator/HTML/W3C/Warning.pm
  28. +0
    -703
      wala/lib/XML/Atom/SimpleFeed.pm
  29. +0
    -5
      wala/log
  30. +0
    -43
      wala/p1k3.conf.pl

wala/benchmark.pl → benchmark.pl View File


+ 91
- 116
lib/Wala.pm View File

@ -1,6 +1,3 @@
#!/usr/bin/perl
# vim:set ts=2 et:
=pod
=head1 NAME
@ -61,8 +58,10 @@ You can set options directly from the calling script, like so:
TitleString => 'wala::', # Display before page names in titles
ScriptName => 'wala.pl',
ShowSearchlinks => 1, # Display "see also" box on pages
LogRelatedLinks => 1, # Log related links for a given change.
CheckSetup => 1, # Check for setup files every time
UseCache => 0, # Don't use caching behavior
NoCache => qr/^([A-Z]|PageIndex|RecentChanges|HomePage|PageChangeTimes)$/x,
);
$w->run;
@ -106,7 +105,8 @@ fault.
=head1 REVISION
Brennen's version, branched from Brent's at 1.1.4
Last updated Thu Jun 7 13:45:31 PDT 2007
$Id: Wala.pm 135 2008-01-27 15:03:47Z bbearnes $
=cut
@ -119,7 +119,7 @@ no warnings 'uninitialized';
use Fcntl qw(:flock);
use POSIX qw(strftime);
# Pull in the markup package.
use base 'MethodSpit';
use Wala::Markup;
use Wala::Editor;
@ -138,6 +138,9 @@ my %WalaConf = (
ShowSearchlinks => 1, # Display "see also" box on pages
CheckSetup => 1, # Check for setup files every time
UseCache => 0, # Don't use caching behavior
NoCache => qr/^([A-Z]|PageIndex|RecentChanges|HomePage
|PageChangeTimes)$/x,
LogRelatedLinks => 1, # Log related links for a given change.
DisplayRootDir => undef,
DisplayURL => undef,
TestMode => undef,
@ -146,69 +149,22 @@ my %WalaConf = (
parameters => undef,
);
# The following bits are cheap method generation, in place
# of using Class::Accessor or Object::Tiny.
{
no strict 'refs';
# These are simple accessors.
foreach my $name (keys %WalaConf) {
# Install a generated sub:
*{ $name } = makemethod($name);
}
# These are conditional accessors, dependent on RootDir.
my %methods_rootdir = (
LogFile => 'log',
SpamLogFile => 'spam.log',
PagesDir => 'pages',
CacheDir => 'cache',
DiffDir => 'diffs',
);
foreach my $name (keys %methods_rootdir) {
# Install a generated sub:
*{ $name } = makemethod_rootdir($name, $methods_rootdir{$name});
}
}
# (Relatively) cheap custom method generation.
# Handy-dandy basic closure:
sub makemethod {
my ($name) = @_;
# Simple accessors:
__PACKAGE__->methodspit(keys %WalaConf);
return sub {
my ($self, $param) = @_;
$self->{$name} = $param if $param;
return $self->{$name};
# Accessors which depend on RootDir unless explicitly set:
__PACKAGE__->methodspit_depend(
'RootDir',
{
LogFile => '/log',
SpamLogFile => '/spam.log',
PagesDir => '/pages',
CacheDir => '/cache',
DiffDir => '/diffs',
}
}
# A slightly more complicated closure.
# If we don't have an appropriate value,
# return the RootDir + a default.
#
# This way, if we haven't explicitly set
# something like LogFile, it will always
# be dependent on RootDir.
sub makemethod_rootdir {
my ($name, $default) = @_;
return sub {
my $self = shift;
my ($param) = @_;
if (defined $param) {
$self->{$name} = $param;
}
if (defined $self->{$name}) {
return $self->{$name};
} else {
return $self->RootDir . "/$default";
}
}
}
);
=head1 METHODS
@ -247,7 +203,7 @@ sub conf {
sub run {
my $self = shift;
my ($query, $result);
my ($result);
my $page = $self->HomePage;
$self->setup() if $self->CheckSetup;
@ -260,9 +216,9 @@ sub run {
# We got a plain WikiWord as the only parameter, so that's the page
$page = $querystring;
} elsif (length($querystring) > 0 or $content_len > 0) {
# We have one or more parameters; read and parse them:
my $query;
if ($content_len > 0) {
read STDIN, $query, $content_len;
} else {
@ -273,11 +229,11 @@ sub run {
}
# Cut off access to other directories.
if (substr($page, 0, 1) eq '.') {
if ($page =~ m/^[.]/) {
$page = $self->HomePage;
}
my $pagefile = $self->PagesDir . "/$page";
my $pagefile = $self->PagesDir . "/$page";
my $cachefile = $self->CacheDir . "/$page";
print $self->get_header($page);
@ -296,44 +252,40 @@ sub run {
}
# Half of caching behavior is implemented starting here:
CACHEBREAK: {
my $usecache = $self->UseCache;
if ( $page =~ m/^([A-Z]|PageIndex|RecentChanges|HomePage|
PageChangeTimes)$/x ) {
$usecache = 0;
}
# Why was this localized? Does it matter?
#local $WalaConf{UseCache} = $usecache;
unless ($usecache) {
print $self->print_page($page) . $self->get_footer($page);
return 1; # done
}
if ($self->skip_cache($page)) {
print $self->print_page($page) . $self->get_footer($page);
return 1; # done
}
# Only fall through to this stuff if UseCache is turned on:
# We'll only fall through to this stuff if UseCache is turned on:
my ($page_mtime, $cachetime);
if (-e $cachefile) {
($page_mtime, $cachetime) = get_mtime($pagefile, $cachefile);
}
# Has the page been touched since it was cached?
if ($page_mtime < $cachetime) {
# use cache
# no - use cache
$result = get_file_text($cachefile);
} else {
# otherwise store a copy in the cache
# yes - store a fresh copy in the cache
$result = $self->print_page($page);
write_file($cachefile, $result);
}
print $result . $self->get_footer($page);
}
# Skip cache for this page?
sub skip_cache {
my $self = shift;
my ($page) = @_;
return 1 unless $self->UseCache;
return 1 if $page =~ $self->NoCache();
return;
}
@ -407,7 +359,7 @@ sub convert_links {
# Bare links.
$text =~ s/(?<![\[<]) # not preceded by
(http|https|ftp|gopher|news|telnet|ssh):\/\/ # protocol
[A-Za-z0-9\/\.\-\=\?\&\%\~\_\+#]* # text
[A-Za-z0-9\/\.\-=?&%~_+#]* # text
/get_link($&)/geosx;
@ -464,8 +416,8 @@ sub is_image {
if ($url =~ m{^(http:|https:|ftp:) # protocol
[A-Za-z0-9/.\-=?&%~_+]+
\.(gif|jpg|jpeg|png$) # extensions
}ix )
{
}ix
) {
return 1;
} else {
return 0;
@ -488,16 +440,22 @@ sub convert_wikiwords {
my ($text) = @_;
# CamelCase
$text =~ s/(?<![A-Za-z0-9\[\=\/\?\.\,\&\-]) # if not preceeded by
([A-Z][a-z0-9]+) # One uppercase + lowercase
([A-Z][a-z0-9]+)+ # + one uppercase + lowercase
/$self->wikiword_linkify($&)/geosx;
$text =~ s/(?<!
[\w\[=?:] # Not preceeded by a word character, bracket, etc.
)
(
[A-Z][a-z0-9]+ # One uppercase + lowercase
(?:[A-Z][a-z0-9]+)+ # + one uppercase + lowercase...
)
(\W|$) # Non-word or EOF
/$self->wikiword_linkify($1) . $2/geosx;
# Bracketed links
$text =~ s!\[{1,2} # one or two brackets
([A-Za-z0-9|.%,_'\!\ ]*) # everything we take in the link
$text =~ s{(?<! \\) # Not an escape.
\[{1,2} # one or two brackets
([A-Za-z0-9|.%,_'!\;\&?\= ]*) # everything we take in the link
\]{1,2} # one or two brackets
!$self->wikiword_linkify($1)!geosx;
}{$self->wikiword_linkify($1)}geosx;
return $text;
}
@ -542,7 +500,7 @@ sub write_page {
# Check for edit collisions:
my $new_timestamp = get_mtime($self->PagesDir . "/$pagename");
if( $old_timestamp and ($new_timestamp > $old_timestamp) ) {
if ( $old_timestamp and ($new_timestamp > $old_timestamp) ) {
return "<h1>Probable edit collision.</h1>\n\n<p>This page has changed
since you started editing it. You'll find your text below the
edit box - please incorporate your changes here and save the
@ -565,9 +523,9 @@ sub write_page {
my @to_touch;
# For new pages we want to update anything that links here:
if ($diff_line eq 'New page or unchanged.') {
@to_touch = $self->get_linked_pages($pagename, 0);
}
#if ($diff_line eq 'New page or unchanged.') {
@to_touch = $self->get_linked_pages($pagename);
#}
# Update everything this page links to:
push @to_touch, pagelinks($file_text);
@ -578,7 +536,7 @@ sub write_page {
# first mapping directory prefix to the list.
my $pagesdir = $self->PagesDir;
utime $touch_time, $touch_time,
map { "${pagesdir}$_" } @to_touch;
map { "${pagesdir}/$_" } @to_touch;
return (0);
}
@ -592,7 +550,7 @@ sub spamcheck {
# Does the file contain a URL or an attempt at a URL, and is the user
# anonymous?
if ( ($text =~ m{http://|a href=}i)
if ( ($text =~ m{http://|a href}i)
and $self->get_username eq $self->DefaultUserName )
{
# Quickie spamlogging.
@ -793,7 +751,8 @@ sub searchlinks {
# Include the list of pages that link to this one.
if ( $parameters->{'action'} ne 'links' ) {
push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename, 15);
push @matchpages, map { "[$_]" }
$self->get_linked_pages($pagename, 15);
@matchpages = sort @matchpages;
# provide "more..." link if we got a full list.
@ -803,7 +762,7 @@ sub searchlinks {
'<em>more...</em>');
}
} else {
push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename, 0);
push @matchpages, map { "[$_]" } $self->get_linked_pages($pagename);
@matchpages = sort(@matchpages);
}
@ -832,9 +791,19 @@ sub searchlinks {
return @result;
}
sub format_matchpages {
my ($link) = @_;
my $new_link = $link;
if (length($link) > 20) {
$new_link = $link . '|' . substr($link, 0, 20) . '...';
}
return "[$new_link]";
}
# Return a list of the pages that link to a given page
# essentially a big dumb grep:
# return a list of the pages that link to a given page
# essentially a big dumb grep
sub get_linked_pages {
my $self = shift;
my ($pagename, $quantity) = @_;
@ -857,7 +826,7 @@ sub get_linked_pages {
my @matchpages;
until ($filename eq '') {
# Bail out if we've got a desired quantity:
last if $quantity and (@matchpages >= $quantity);
last if (defined $quantity) and (@matchpages >= $quantity);
$filename = readdir $dh;
@ -1376,7 +1345,7 @@ sub parse_cookies {
# see if this works
my %cookies;
my @values = split /&/, $cookie_string;
my @values = split /;/, $cookie_string;
foreach my $query (@values) {
my ($name, $value) = split(/=/, $query);
$value =~ tr/+/ /;
@ -1650,11 +1619,17 @@ sub write_diff
$summary = "$change_count changes.";
}
# Make sure the links in our related list are unique:
my %seen = ();
@link_list = grep { ! $seen{$_} ++ } @link_list;
if ($self->LogRelatedLinks) {
if (@link_list) { $summary .= " Related: @link_list"; }
# Make sure the links in our related list are unique:
my %seen = ();
@link_list = map { "[$_]" }
grep { ! $seen{$_} ++ }
@link_list;
$summary .= ' (Related: ' . (join q{, }, @link_list) . ')'
if @link_list;
}
write_file($diffdir . "/$currtime", $the_diff);


+ 15
- 0
t/SpitTest.pm View File

@ -0,0 +1,15 @@
package SpitTest;
use base 'MethodSpit';
__PACKAGE__->methodspit( qw( cat ) );
__PACKAGE__->methodspit_depend(
'cat',
{ moose => 'bark' }
);
sub new {
bless { @_ };
}
1;

+ 12
- 0
t/spittest.pl View File

@ -0,0 +1,12 @@
use SpitTest;
use Wala;
my $w = Wala->new();
my $obj = SpitTest->new();
$obj->cat("Persian ");
print $obj->moose;
$obj->moose("dog");
print $obj->moose;
print $w->LogFile;

validate.pl → t/validate.pl View File


wala/test.pl → t/wala_test.pl View File


wala/validate.pl → t/wala_validate.pl View File


wala/wala.pl → wala.pl View File


+ 0
- 24
wala/Makefile View File

@ -1,24 +0,0 @@
all: test docs checkin
docs: readme test_docs validation_docs
@echo "Generated text files from POD."
readme:
pod2text Wala.pm > README
test_docs:
pod2text test.pl > TESTING
validation_docs:
pod2text validate.pl > VALIDATION
test:
@echo "Running test script."
./test.pl
./validate.pl
checkin: update readme test_docs test
svn ci
update:
svn update

+ 0
- 98
wala/README View File

@ -1,98 +0,0 @@
NAME
Wala.pm - easy minimalist wiki
SYNOPSIS
As a standalone wiki app:
#!/usr/bin/perl
use Wala;
my $w = Wala->new;
$w->run;
Pulling content into other scripts:
$text = $w->print_page('SandBox');
DESCRIPTION
This is a Wala, which is a derivation of a wiki that incorporates
appending text directly to pages, turning a wiki into something more
like a forum while retaining all the wonderful full-page editing
features of a wiki.
INSTALLATION
This script is a self-contained package, which makes the code easy to
test. To actually use it as a wala, create a script named "wala.pl" in
the same directory, containing the following three lines:
#!/usr/bin/perl
use Wala;
my $w = Wala->new();
$w->run;
You can experiment with the wala by use'ing it and calling its functions
without calling "run". By default, required directories and files should
be created as needed, but you can visit wala.pl?setup in your browser,
or call "setup()" from a script at any time.
CONFIGURATION
You can set options directly from the calling script, like so:
#!/usr/bin/perl
use Wala;
my $w = Wala->new(
RecentChangesMaxLines => 50, # Max lines to display in RecentChanges
DefaultUserName => 'Anonymous', # Default user name
StyleSheet => 'wala.css', # URL of style sheet
DefaultPageText => "Write something.\n",
CookieSurvivalDays => 90, # Number of days for cookies to remain
RootDir => '.', # No trailing slash, please
HomePage => 'HomePage', # Name of default page
TimeZone => 'UTC', # Currently just a string to display
TitleString => 'wala::', # Display before page names in titles
ScriptName => 'wala.pl', # substr( $0, rindex( $0, "/" ) + 1 );
ShowSearchlinks => 1, # Display "see also" box on pages
CheckSetup => 1, # Check for setup files every time
UseCache => 0, # Don't use caching behavior
);
$w->run;
FEEDS
Feeds are practically a requirement these days. While it wouldn't be the
hardest thing in the world to roll my own Atom or RSS within Wala.pm, it
was much less painful to look to CPAN, which offers
XML::Atom::SimpleFeed.
I've included a simple wala_feed.pl, which relies on the aforementioned
module. It shouldn't be too hard to customize.
If you do something along the lines of:
FeedURL => 'http://p1k3.com/wala/wala_feed.pl',
in your configuration, Wala.pm will link to your feed in page headers so
that browsers like Firefox will auto-discover it.
LICENSE
No warranty of any kind is made regarding this software's fitness or
suitability for any purpose. The authors explicitly disclaim any
liability or responsibility for the results of its use.
This software is dedicated to the public domain. In any jurisdiction
where a dedication to the public domain is not permitted by law, the
authors grant you a perpetual, non-exclusive license to modify and/or
redistribute the software in any medium, world-wide, forever and ever.
Though there is no legal requirement, credit would be appreciated.
AUTHORS
Wala was originally written by Brent P. Newhall. This version contains
substantial modifications by Brennen Bearnes; following Brent's lead,
all changes are placed in the public domain. Egregious bugs are probably
Brennen's fault.
REVISION
Brennen's version, branched from Brent's at 1.1.4
Last updated Thu Jun 7 13:45:31 PDT 2007

+ 0
- 30
wala/TESTING View File

@ -1,30 +0,0 @@
NAME
test.pl - a set of basic tests for Wala.pm
SYNOPSIS
Given a working installation and configuration file:
./test.pl
DESCRIPTION
This section to-come.
MISSING TESTS
These items aren't tested at all, at the moment. A number of them aren't
particularly trivial to test.
sub get_diff
sub get_latest_diff_date
sub write_page
sub add_to_page
sub log_page_edit
sub parse_cookies
sub write_cookies_to_browser
sub setup
sub parse_parameters
sub write_diff
sub merge_diff
SEE ALSO
validate.pl in the WalaWiki distribution.

+ 0
- 25
wala/VALIDATION View File

@ -1,25 +0,0 @@
NAME
validate.pl - W3C validate markup from Wala.pm
SYNOPSIS
Given a working installation and configuration file:
./validate.pl
DESCRIPTION
These tests are aimed at a working installation with several files in
place, and require Test::HTML::W3C as well as Test::Simple. For the time
being, I'm using "valid W3C HTML" as a proxy for "not broken", and a
number of larger pages as a proxy for their component features. This
works surprisingly well for much of what the module does.
What these tests don't validate in any way is the handling of user
input, writing of pages, change logging, or edit conflict resolution.
I'll do something about this, eventually. There are also be some issues
around testing with different configurations.
Nothing here should be destructive.
SEE ALSO
test.pl in Wala Wiki distribution, Test::HTML::W3C.

+ 0
- 39
wala/default.conf.pl View File

@ -1,39 +0,0 @@
##################
# WALA OPTIONS #
##################
%WalaConf = (
RecentChangesMaxLines => 50, # Max lines to display in RecentChanges
DefaultUserName => 'Anonymous', # Default user name
StyleSheet => 'wala.css', # URL of style sheet
DefaultPageText => "Write something.\n",
CookieSurvivalDays => 90, # Number of days for cookies to remain
RootDir => '.', # No trailing slash, please
HomePage => 'HomePage', # Name of default page
TimeZone => 'UTC', # Currently just a string to display
TitleString => 'wala::', # Display before page names in titles
ScriptName => 'wala.pl', # substr( $0, rindex( $0, "/" ) + 1 );
ShowSearchlinks => 1, # Display "see also" box on pages
UseCache => 0, # Don't cache generated pages
# Check for important files every time we run the script.
# This can be changed to 0 for faster load times once everything
# is working:
CheckSetup => 1,
# Uncomment and set to use a feed script:
#FeedURL => "http://path/to/wala/feed.pl",
);
# Set some important paths relative to our root directory:
$WalaConf{LogFile} = $WalaConf{RootDir} . '/log';
$WalaConf{PagesDir} = $WalaConf{RootDir} . '/pages';
$WalaConf{CacheDir} = $WalaConf{RootDir} . '/cache';
$WalaConf{DiffDir} = $WalaConf{RootDir} . '/diffs';
# Should be empty unless we're going to use display.pl:
%DISPLAY_CONF = (
);

+ 0
- 222
wala/lib/Carp/Clan.pm View File

@ -1,222 +0,0 @@
##
## Based on Carp.pm from Perl 5.005_03.
## Last modified 12-Jun-2001 by Steffen Beyer.
## Should be reasonably backwards compatible.
##
## This module is free software and can
## be used, modified and redistributed
## under the same terms as Perl itself.
##
@DB::args = (); # Avoid warning "used only once" in Perl 5.003
package Carp::Clan;
use strict;
use vars qw( $MaxEvalLen $MaxArgLen $MaxArgNums $Verbose $VERSION );
use overload ();
# Original comments by Andy Wardley <abw@kfs.org> 09-Apr-1998.
# The $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how
# the eval text and function arguments should be formatted when printed.
$MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
$MaxArgLen = 64; # How much of each argument to print. 0 = all.
$MaxArgNums = 8; # How many arguments to print. 0 = all.
$Verbose = 0; # If true then make _shortmsg call _longmsg instead.
$VERSION = '5.8';
# _longmsg() crawls all the way up the stack reporting on all the function
# calls made. The error string, $error, is originally constructed from the
# arguments passed into _longmsg() via confess(), cluck() or _shortmsg().
# This gets appended with the stack trace messages which are generated for
# each function call on the stack.
sub _longmsg {
return (@_) if ( ref $_[0] );
local $_; # Protect surrounding program - just in case...
my ( $pack, $file, $line, $sub, $hargs, $eval, $require, @parms, $push );
my $error = join( '', @_ );
my $msg = '';
my $i = 0;
while (
do {
{
package DB;
( $pack, $file, $line, $sub, $hargs, undef, $eval, $require )
= caller( $i++ )
}
}
)
{
next if ( $pack eq 'Carp::Clan' );
if ( $error eq '' ) {
if ( defined $eval ) {
$eval =~ s/([\\\'])/\\$1/g unless ($require); # Escape \ and '
$eval
=~ s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
substr( $eval, $MaxEvalLen ) = '...'
if ( $MaxEvalLen && length($eval) > $MaxEvalLen );
if ($require) { $sub = "require $eval"; }
else { $sub = "eval '$eval'"; }
}
elsif ( $sub eq '(eval)' ) { $sub = 'eval {...}'; }
else {
@parms = ();
if ($hargs) {
$push = 0;
@parms = @DB::args
; # We may trash some of the args so we take a copy
if ( $MaxArgNums and @parms > $MaxArgNums ) {
$#parms = $MaxArgNums;
pop(@parms);
$push = 1;
}
for (@parms) {
if ( defined $_ ) {
if ( ref $_ ) {
$_ = overload::StrVal($_);
}
else {
unless ( /^-?\d+(?:\.\d+(?:[eE][+-]\d+)?)?$/
) # Looks numeric
{
s/([\\\'])/\\$1/g; # Escape \ and '
s/([\x00-\x1F\x7F-\xFF])/sprintf("\\x%02X",ord($1))/eg;
substr( $_, $MaxArgLen ) = '...'
if ( $MaxArgLen
and length($_) > $MaxArgLen );
$_ = "'$_'";
}
}
}
else { $_ = 'undef'; }
}
push( @parms, '...' ) if ($push);
}
$sub .= '(' . join( ', ', @parms ) . ')';
}
if ( $msg eq '' ) { $msg = "$sub called"; }
else { $msg .= "\t$sub called"; }
}
else {
if ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
else { $msg = "$sub: $error"; }
}
$msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
$error = '';
}
$msg ||= $error;
$msg =~ tr/\0//d; # Circumvent die's incorrect handling of NUL characters
$msg;
}
# _shortmsg() is called by carp() and croak() to skip all the way up to
# the top-level caller's package and report the error from there. confess()
# and cluck() generate a full stack trace so they call _longmsg() to
# generate that. In verbose mode _shortmsg() calls _longmsg() so you
# always get a stack trace.
sub _shortmsg {
my $pattern = shift;
my $verbose = shift;
return (@_) if ( ref $_[0] );
goto &_longmsg if ( $Verbose or $verbose );
my ( $pack, $file, $line, $sub );
my $error = join( '', @_ );
my $msg = '';
my $i = 0;
while ( ( $pack, $file, $line, $sub ) = caller( $i++ ) ) {
next if ( $pack eq 'Carp::Clan' or $pack =~ /$pattern/ );
if ( $error eq '' ) { $msg = "$sub() called"; }
elsif ( $sub =~ /::/ ) { $msg = "$sub(): $error"; }
else { $msg = "$sub: $error"; }
$msg .= " at $file line $line\n" unless ( $error =~ /\n$/ );
$msg =~ tr/\0//d
; # Circumvent die's incorrect handling of NUL characters
return $msg;
}
goto &_longmsg;
}
# The following four functions call _longmsg() or _shortmsg() depending on
# whether they should generate a full stack trace (confess() and cluck())
# or simply report the caller's package (croak() and carp()), respectively.
# confess() and croak() die, carp() and cluck() warn.
# Following code kept for calls with fully qualified subroutine names:
# (For backward compatibility with the original Carp.pm)
sub croak {
my $callpkg = caller(0);
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
die _shortmsg( $pattern, 0, @_ );
}
sub confess { die _longmsg(@_); }
sub carp {
my $callpkg = caller(0);
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
warn _shortmsg( $pattern, 0, @_ );
}
sub cluck { warn _longmsg(@_); }
# The following method imports a different closure for every caller.
# I.e., different modules can use this module at the same time
# and in parallel and still use different patterns.
sub import {
my $pkg = shift;
my $callpkg = caller(0);
my $pattern = ( $callpkg eq 'main' ) ? '^:::' : "^$callpkg\$";
my $verbose = 0;
my $item;
my $file;
for $item (@_) {
if ( $item =~ /^\d/ ) {
if ( $VERSION < $item ) {
$file = "$pkg.pm";
$file =~ s!::!/!g;
$file = $INC{$file};
die _shortmsg( '^:::', 0,
"$pkg $item required--this is only version $VERSION ($file)"
);
}
}
elsif ( $item =~ /^verbose$/i ) { $verbose = 1; }
else { $pattern = $item; }
}
# Speed up pattern matching in Perl versions >= 5.005:
# (Uses "eval ''" because qr// is a syntax error in previous Perl versions)
if ( $] >= 5.005 ) {
eval '$pattern = qr/$pattern/;';
}
else {
eval { $pkg =~ /$pattern/; };
}
if ($@) {
$@ =~ s/\s+$//;
$@ =~ s/\s+at\s.+$//;
die _shortmsg( '^:::', 0, $@ );
}
{
local ($^W) = 0;
no strict "refs";
*{"${callpkg}::croak"}
= sub { die _shortmsg( $pattern, $verbose, @_ ); };
*{"${callpkg}::confess"} = sub { die _longmsg(@_); };
*{"${callpkg}::carp"}
= sub { warn _shortmsg( $pattern, $verbose, @_ ); };
*{"${callpkg}::cluck"} = sub { warn _longmsg(@_); };
}
}
1;

+ 0
- 95
wala/lib/Carp/Clan.pod View File

@ -1,95 +0,0 @@
=head1 NAME
Carp::Clan - Report errors from perspective of caller of a "clan" of modules
=head1 SYNOPSIS
carp - warn of errors (from perspective of caller)
cluck - warn of errors with stack backtrace
croak - die of errors (from perspective of caller)
confess - die of errors with stack backtrace
use Carp::Clan qw(^MyClan::);
croak "We're outta here!";
use Carp::Clan;
confess "This is how we got here!";
=head1 DESCRIPTION
This module is based on "C<Carp.pm>" from Perl 5.005_03. It has been
modified to skip all package names matching the pattern given in
the "use" statement inside the "C<qw()>" term (or argument list).
Suppose you have a family of modules or classes named "Pack::A",
"Pack::B" and so on, and each of them uses "C<Carp::Clan qw(^Pack::);>"
(or at least the one in which the error or warning gets raised).
Thus when for example your script "tool.pl" calls module "Pack::A",
and module "Pack::A" calls module "Pack::B", an exception raised in
module "Pack::B" will appear to have originated in "tool.pl" where
"Pack::A" was called, and not in "Pack::A" where "Pack::B" was called,
as the unmodified "C<Carp.pm>" would try to make you believe C<:-)>.
This works similarly if "Pack::B" calls "Pack::C" where the
exception is raised, etcetera.
In other words, this blames all errors in the "C<Pack::*>" modules
on the user of these modules, i.e., on you. C<;-)>
The skipping of a clan (or family) of packages according to a pattern
describing its members is necessary in cases where these modules are
not classes derived from each other (and thus when examining C<@ISA>
- as in the original "C<Carp.pm>" module - doesn't help).
The purpose and advantage of this is that a "clan" of modules can work
together (and call each other) and throw exceptions at various depths
down the calling hierarchy and still appear as a monolithic block (as
though they were a single module) from the perspective of the caller.
In case you just want to ward off all error messages from the module
in which you "C<use Carp::Clan>", i.e., if you want to make all error
messages or warnings to appear to originate from where your module
was called (this is what you usually used to "C<use Carp;>" for C<;-)>),
instead of in your module itself (which is what you can do with a
"die" or "warn" anyway), you do not need to provide a pattern,
the module will automatically provide the correct one for you.
I.e., just "C<use Carp::Clan;>" without any arguments and call "carp"
or "croak" as appropriate, and they will automatically defend your
module against all blames!
In other words, a pattern is only necessary if you want to make
several modules (more than one) work together and appear as though
they were only one.
=head2 Forcing a Stack Trace
As a debugging aid, you can force "C<Carp::Clan>" to treat a "croak" as
a "confess" and a "carp" as a "cluck". In other words, force a detailed
stack trace to be given. This can be very helpful when trying to
understand why, or from where, a warning or error is being generated.
This feature is enabled either by "importing" the non-existent symbol
'verbose', or by setting the global variable "C<$Carp::Clan::Verbose>"
to a true value.
You would typically enable it by saying
use Carp::Clan qw(verbose);
Note that you can both specify a "family pattern" and the string "verbose"
inside the "C<qw()>" term (or argument list) of the "use" statement, but
consider that a pattern of packages to skip is pointless when "verbose"
causes a full stack trace anyway.
=head1 BUGS
The "C<Carp::Clan>" routines don't handle exception objects currently.
If called with a first argument that is a reference, they simply
call "C<die()>" or "C<warn()>", as appropriate.

+ 0
- 1848
wala/lib/Test/Builder.pm
File diff suppressed because it is too large
View File


+ 0
- 182
wala/lib/Test/Builder/Module.pm View File

@ -1,182 +0,0 @@
package Test::Builder::Module;
use Test::Builder;
require Exporter;
@ISA = qw(Exporter);
$VERSION = '0.68';
use strict;
# 5.004's Exporter doesn't have export_to_level.
my $_export_to_level = sub {
my $pkg = shift;
my $level = shift;
(undef) = shift; # redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
};
=head1 NAME
Test::Builder::Module - Base class for test modules
=head1 SYNOPSIS
# Emulates Test::Simple
package Your::Module;
my $CLASS = __PACKAGE__;
use base 'Test::Builder::Module';
@EXPORT = qw(ok);
sub ok ($;$) {
my $tb = $CLASS->builder;
return $tb->ok(@_);
}
1;
=head1 DESCRIPTION
This is a superclass for Test::Builder-based modules. It provides a
handful of common functionality and a method of getting at the underlying
Test::Builder object.
=head2 Importing
Test::Builder::Module is a subclass of Exporter which means your
module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
all act normally.
A few methods are provided to do the C<use Your::Module tests => 23> part
for you.
=head3 import
Test::Builder::Module provides an import() method which acts in the
same basic way as Test::More's, setting the plan and controling
exporting of functions and variables. This allows your module to set
the plan independent of Test::More.
All arguments passed to import() are passed onto
C<< Your::Module->builder->plan() >> with the exception of
C<import =>[qw(things to import)]>.
use Your::Module import => [qw(this that)], tests => 23;
says to import the functions this() and that() as well as set the plan
to be 23 tests.
import() also sets the exported_to() attribute of your builder to be
the caller of the import() function.
Additional behaviors can be added to your import() method by overriding
import_extra().
=cut
sub import {
my($class) = shift;
my $test = $class->builder;
my $caller = caller;
$test->exported_to($caller);
$class->import_extra(\@_);
my(@imports) = $class->_strip_imports(\@_);
$test->plan(@_);
$class->$_export_to_level(1, $class, @imports);
}
sub _strip_imports {
my $class = shift;
my $list = shift;
my @imports = ();
my @other = ();
my $idx = 0;
while( $idx <= $#{$list} ) {
my $item = $list->[$idx];
if( defined $item and $item eq 'import' ) {
push @imports, @{$list->[$idx+1]};
$idx++;
}
else {
push @other, $item;
}
$idx++;
}
@$list = @other;
return @imports;
}
=head3 import_extra
Your::Module->import_extra(\@import_args);
import_extra() is called by import(). It provides an opportunity for you
to add behaviors to your module based on its import list.
Any extra arguments which shouldn't be passed on to plan() should be
stripped off by this method.
See Test::More for an example of its use.
B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
feels like a bit of an ugly hack in its current form.
=cut
sub import_extra {}
=head2 Builder
Test::Builder::Module provides some methods of getting at the underlying
Test::Builder object.
=head3 builder
my $builder = Your::Class->builder;
This method returns the Test::Builder object associated with Your::Class.
It is not a constructor so you can call it as often as you like.
This is the preferred way to get the Test::Builder object. You should
I<not> get it via C<< Test::Builder->new >> as was previously
recommended.
The object returned by builder() may change at runtime so you should
call builder() inside each function rather than store it in a global.
sub ok {
my $builder = Your::Class->builder;
return $builder->ok(@_);
}
=cut
sub builder {
return Test::Builder->new;
}
1;

+ 0
- 647
wala/lib/Test/Builder/Tester.pm View File

@ -1,647 +0,0 @@
package Test::Builder::Tester;
use strict;
use vars qw(@EXPORT $VERSION @ISA);
$VERSION = "1.07";
use Test::Builder;
use Symbol;
use Carp;
=head1 NAME
Test::Builder::Tester - test testsuites that have been built with
Test::Builder
=head1 SYNOPSIS
use Test::Builder::Tester tests => 1;
use Test::More;
test_out("not ok 1 - foo");
test_fail(+1);
fail("foo");
test_test("fail works");
=head1 DESCRIPTION
A module that helps you test testing modules that are built with
B<Test::Builder>.
The testing system is designed to be used by performing a three step
process for each test you wish to test. This process starts with using
C<test_out> and C<test_err> in advance to declare what the testsuite you
are testing will output with B<Test::Builder> to stdout and stderr.
You then can run the test(s) from your test suite that call
B<Test::Builder>. At this point the output of B<Test::Builder> is
safely captured by B<Test::Builder::Tester> rather than being
interpreted as real test output.
The final stage is to call C<test_test> that will simply compare what you
predeclared to what B<Test::Builder> actually outputted, and report the
results back with a "ok" or "not ok" (with debugging) to the normal
output.
=cut
####
# set up testing
####
my $t = Test::Builder->new;
###
# make us an exporter
###
use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
# _export_to_level and import stolen directly from Test::More. I am
# the king of cargo cult programming ;-)
# 5.004's Exporter doesn't have export_to_level.
sub _export_to_level
{
my $pkg = shift;
my $level = shift;
(undef) = shift; # XXX redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
sub import {
my $class = shift;
my(@plan) = @_;
my $caller = caller;
$t->exported_to($caller);
$t->plan(@plan);
my @imports = ();
foreach my $idx (0..$#plan) {
if( $plan[$idx] eq 'import' ) {
@imports = @{$plan[$idx+1]};
last;
}
}
__PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
}
###
# set up file handles
###
# create some private file handles
my $output_handle = gensym;
my $error_handle = gensym;
# and tie them to this package
my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
####
# exported functions
####
# for remembering that we're testing and where we're testing at
my $testing = 0;
my $testing_num;
# remembering where the file handles were originally connected
my $original_output_handle;
my $original_failure_handle;
my $original_todo_handle;
my $original_test_number;
my $original_harness_state;
my $original_harness_env;
# function that starts testing and redirects the filehandles for now
sub _start_testing
{
# even if we're running under Test::Harness pretend we're not
# for now. This needed so Test::Builder doesn't add extra spaces
$original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
$ENV{HARNESS_ACTIVE} = 0;
# remember what the handles were set to
$original_output_handle = $t->output();
$original_failure_handle = $t->failure_output();
$original_todo_handle = $t->todo_output();
# switch out to our own handles
$t->output($output_handle);
$t->failure_output($error_handle);
$t->todo_output($error_handle);
# clear the expected list
$out->reset();
$err->reset();
# remeber that we're testing
$testing = 1;
$testing_num = $t->current_test;
$t->current_test(0);
# look, we shouldn't do the ending stuff
$t->no_ending(1);
}
=head2 Functions
These are the six methods that are exported as default.
=over 4
=item test_out
=item test_err
Procedures for predeclaring the output that your test suite is
expected to produce until C<test_test> is called. These procedures
automatically assume that each line terminates with "\n". So
test_out("ok 1","ok 2");
is the same as
test_out("ok 1\nok 2");
which is even the same as
test_out("ok 1");
test_out("ok 2");
Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
been called once all further output from B<Test::Builder> will be
captured by B<Test::Builder::Tester>. This means that your will not
be able perform further tests to the normal output in the normal way
until you call C<test_test> (well, unless you manually meddle with the
output filehandles)
=cut
sub test_out(@)
{
# do we need to do any setup?
_start_testing() unless $testing;
$out->expect(@_)
}
sub test_err(@)
{
# do we need to do any setup?
_start_testing() unless $testing;
$err->expect(@_)
}
=item test_fail
Because the standard failure message that B<Test::Builder> produces
whenever a test fails will be a common occurrence in your test error
output, and because has changed between Test::Builder versions, rather
than forcing you to call C<test_err> with the string all the time like
so
test_err("# Failed test ($0 at line ".line_num(+1).")");
C<test_fail> exists as a convenience function that can be called
instead. It takes one argument, the offset from the current line that
the line that causes the fail is on.
test_fail(+1);
This means that the example in the synopsis could be rewritten
more simply as:
test_out("not ok 1 - foo");
test_fail(+1);
fail("foo");
test_test("fail works");
=cut
sub test_fail
{
# do we need to do any setup?
_start_testing() unless $testing;
# work out what line we should be on
my ($package, $filename, $line) = caller;
$line = $line + (shift() || 0); # prevent warnings
# expect that on stderr
$err->expect("# Failed test ($0 at line $line)");
}
=item test_diag
As most of the remaining expected output to the error stream will be
created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
provides a convience function C<test_diag> that you can use instead of
C<test_err>.
The C<test_diag> function prepends comment hashes and spacing to the
start and newlines to the end of the expected output passed to it and
adds it to the list of expected error output. So, instead of writing
test_err("# Couldn't open file");
you can write
test_diag("Couldn't open file");
Remember that B<Test::Builder>'s diag function will not add newlines to
the end of output and test_diag will. So to check
Test::Builder->new->diag("foo\n","bar\n");
You would do
test_diag("foo","bar")
without the newlines.
=cut
sub test_diag
{
# do we need to do any setup?
_start_testing() unless $testing;
# expect the same thing, but prepended with "# "
local $_;
$err->expect(map {"# $_"} @_)
}
=item test_test
Actually performs the output check testing the tests, comparing the
data (with C<eq>) that we have captured from B<Test::Builder> against
that that was declared with C<test_out> and C<test_err>.
This takes name/value pairs that effect how the test is run.
=over
=item title (synonym 'name', 'label')
The name of the test that will be displayed after the C<ok> or C<not
ok>.
=item skip_out
Setting this to a true value will cause the test to ignore if the
output sent by the test to the output stream does not match that
declared with C<test_out>.
=item skip_err
Setting this to a true value will cause the test to ignore if the
output sent by the test to the error stream does not match that
declared with C<test_err>.
=back
As a convience, if only one argument is passed then this argument
is assumed to be the name of the test (as in the above examples.)
Once C<test_test> has been run test output will be redirected back to
the original filehandles that B<Test::Builder> was connected to
(probably STDOUT and STDERR,) meaning any further tests you run
will function normally and cause success/errors for B<Test::Harness>.
=cut
sub test_test
{
# decode the arguements as described in the pod
my $mess;
my %args;
if (@_ == 1)
{ $mess = shift }
else
{
%args = @_;
$mess = $args{name} if exists($args{name});
$mess = $args{title} if exists($args{title});
$mess = $args{label} if exists($args{label});
}
# er, are we testing?
croak "Not testing. You must declare output with a test function first."
unless $testing;
# okay, reconnect the test suite back to the saved handles
$t->output($original_output_handle);
$t->failure_output($original_failure_handle);
$t->todo_output($original_todo_handle);
# restore the test no, etc, back to the original point
$t->current_test($testing_num);
$testing = 0;
# re-enable the original setting of the harness
$ENV{HARNESS_ACTIVE} = $original_harness_env;
# check the output we've stashed
unless ($t->ok( ($args{skip_out} || $out->check)
&& ($args{skip_err} || $err->check),
$mess))
{
# print out the diagnostic information about why this
# test failed
local $_;
$t->diag(map {"$_\n"} $out->complaint)
unless $args{skip_out} || $out->check;
$t->diag(map {"$_\n"} $err->complaint)
unless $args{skip_err} || $err->check;
}
}
=item line_num
A utility function that returns the line number that the function was
called on. You can pass it an offset which will be added to the
result. This is very useful for working out the correct text of
diagnostic functions that contain line numbers.
Essentially this is the same as the C<__LINE__> macro, but the
C<line_num(+3)> idiom is arguably nicer.
=cut
sub line_num
{
my ($package, $filename, $line) = caller;
return $line + (shift() || 0); # prevent warnings
}
=back
In addition to the six exported functions there there exists one
function that can only be accessed with a fully qualified function
call.
=over 4
=item color
When C<test_test> is called and the output that your tests generate
does not match that which you declared, C<test_test> will print out
debug information showing the two conflicting versions. As this
output itself is debug information it can be confusing which part of
the output is from C<test_test> and which was the original output from
your original tests. Also, it may be hard to spot things like
extraneous whitespace at the end of lines that may cause your test to
fail even though the output looks similar.