Ready for 7.10.29 development.

t/lib/Perl/Critic/Policy/WebGUI/NoIllegalI18NLabels.pm

@@ -0,0 +1,173 @@
+package Perl::Critic::Policy::WebGUI::NoIllegalI18NLabels;
+
+use strict;
+use warnings;
+use Readonly;
+use FindBin;
+
+use WebGUI::Test;
+use WebGUI::International;
+
+use Perl::Critic::Utils qw{ :all };
+use base 'Perl::Critic::Policy';
+
+=head1 Perl::Critic::Policy::WebGUI::NoIllegalI18NLabels
+
+Scan WebGUI modules for i18n calls and make sure that each call has a
+corresponding i18n table entry.  It will not check i18n calls that have
+variables for either the namespace or the label to look up.
+
+Running this policy from the command line requires setting up some
+environmental variables to that it can get a proper WebGUI session,
+and access the test library.
+
+env WEBGUI_CONFIG=/data/WebGUI/etc/my.conf PERL5LIB=/data/WebGUI/t/lib perlcritic -single-policy NoIllegalI18N
+
+=head2 TODO
+
+=over 4
+
+=item +
+
+Handle inline calls like International->new('','')->get('','');
+like in Form/Asset.pm, line 107.
+
+=item +
+
+Handle scoping, like in Content/Setup.pm and other places.
+
+=back
+
+=cut
+
+our $VERSION = '0.2';
+
+Readonly::Scalar my $DESC => q{i18n calls that do not have corresponding i18n table entries};
+
+sub supported_parameters { return ()                   }
+ 
+sub default_severity     { return $SEVERITY_LOWEST     }
+
+sub default_themes       { return 'WebGUI'             }
+
+sub applies_to           { return qw/PPI::Token::Word/ }
+
+##Set up a cache of i18n objects.  Later this will be extended to handle scoping,
+##probably by having a pointer
+
+sub initialize_if_enabled {
+    my ($self, $config) = @_;
+    $self->{_i18n_objects} = {};
+    my $session = WebGUI::Test->session;
+    $self->{i18n} = WebGUI::International->new($session);
+    return $TRUE;
+}
+
+=head2 violates
+
+Gets called on every block, and then scans it for i18n object creations
+and corresponding calls.  It will then check each call to make sure
+that the i18n entry that is being requested exists.
+
+For now, do the check without handling nested scopes.  For nested scopes, I need
+to find a way to detect the nesting (does PPI have a parent check?) and then
+push a scope onto the object for later reference.
+
+=cut
+
+sub violates {
+    my ($self, $elem, undef) = @_;
+    ##$elem has stringification overloaded by default.
+    return unless $elem eq 'new'
+               or $elem eq 'get'
+               or $elem eq 'setNamespace';
+    return if !is_method_call($elem);
+    if ($elem eq 'new') {  ##Object creation,  check for class.
+        my $operator = $elem->sprevious_sibling     or return;
+        my $class    = $operator->sprevious_sibling or return;
+        return unless $class eq 'WebGUI::International';
+
+        my $symbol_name = _get_symbol_name($class);
+        return unless $symbol_name;
+
+        ##It's an i18n object, see if a default namespace was passed in.
+        my $arg_list = $elem->snext_sibling;
+        return unless ref $arg_list eq 'PPI::Structure::List'; 
+        my @arguments = _get_args($arg_list);
+        my $namespace;
+        if ($arguments[1]) {
+            my $secondArgument = $arguments[1]->[0];
+            return unless $secondArgument->isa('PPI::Token::Quote');
+            $namespace = $arguments[1]->[0]->string;
+        }
+        else {
+            $namespace = 'WebGUI';
+        }
+        $self->{_i18n_objects}->{$symbol_name} = $namespace;
+        return;
+    }
+    elsif ($elem eq 'get') {  ##i18n fetch?  Check symbol
+        my $symbol_name = _get_symbol_name($elem);
+        return unless $symbol_name && exists $self->{_i18n_objects}->{$symbol_name};
+        my $arg_list = $elem->snext_sibling;
+        return unless ref $arg_list eq 'PPI::Structure::List'; 
+        my @arguments = _get_args($arg_list);
+        ##First argument should be a quote, and there shouldn't be any operators when
+        ##constructing arguments for the get call.
+        return if exists $arguments[0]->[1] and $arguments[0]->[1]->isa('PPI::Token::Operator');
+        return unless $arguments[0]->[0]->isa('PPI::Token::Quote');
+        my $firstArgument = $arguments[0]->[0];
+        my $label = $firstArgument->string;
+        ##Can't do variable interpolation
+        return if $firstArgument->isa('PPI::Token::Quote::Double')
+               && $label =~ /\$/;
+        my $namespace = $self->{_i18n_objects}->{$symbol_name};
+        if ($arguments[1]) {
+            $namespace = $arguments[1]->[0]->string;
+        }
+        if (! $self->{i18n}->get($label, $namespace)) {
+            return $self->violation(
+                $DESC,
+                sprintf('label=%s, namespace=%s', $label, $namespace),
+                $elem
+            );
+        }
+        return;
+    }
+    elsif ($elem eq 'setNamespace') {  ##Set the object's default namespace
+        my $symbol_name = _get_symbol_name($elem);
+        return unless $symbol_name && exists $self->{_i18n_objects}->{$symbol_name};
+        my $arg_list = $elem->snext_sibling;
+        return unless ref $arg_list eq 'PPI::Structure::List'; 
+        my @arguments = _get_args($arg_list);
+        ##Many assumptions being made here
+        return unless $arguments[0]->[0]->isa('PPI::Token::Quote');
+        my $new_namespace = $arguments[0]->[0]->string;
+        $self->{_i18n_objects}->{$symbol_name} = $new_namespace;
+        return;
+    }
+    return;
+}
+
+sub _get_args {
+    my ($list) = @_;
+    ##Borrowed from Subroutines/ProhibitManyArgs
+    my @inner = $list->schildren;
+    if (1 == @inner and $inner[0]->isa('PPI::Statement::Expression')) {
+        @inner = $inner[0]->schildren;
+    }
+    my @arguments = split_nodes_on_comma(@inner);
+    return @arguments;
+}
+
+sub _get_symbol_name {
+    my ($class) = @_;
+
+    my $assignment = $class->sprevious_sibling  or return;
+    my $symbol     = $assignment->sprevious_sibling or return;
+    return unless ref($symbol) eq 'PPI::Token::Symbol';
+    my $symbol_name = $symbol.'';  ##Is there a better way to stringify?
+    return $symbol_name;
+}
+
+1;

t/lib/WebGUI/Asset/JSONCollateralDummy.pm

@@ -0,0 +1,79 @@
+package WebGUI::Asset::JSONCollateralDummy;
+
+=head1 LEGAL
+
+ -------------------------------------------------------------------
+  WebGUI is Copyright 2001-2009 Plain Black Corporation.
+ -------------------------------------------------------------------
+  Please read the legal notices (docs/legal.txt) and the license
+  (docs/license.txt) that came with this distribution before using
+  this software.
+ -------------------------------------------------------------------
+  http://www.plainblack.com                     info@plainblack.com
+ -------------------------------------------------------------------
+
+=cut
+
+use strict;
+use Tie::IxHash;
+use Class::C3;
+use base qw/WebGUI::JSONCollateral WebGUI::Asset/;
+
+=head1 NAME
+
+Package WebGUI::Asset::JSONCollateral
+
+=head1 DESCRIPTION
+
+A dummy module for testing the JSON Collateral aspect.  The module really doesn't
+do anything, except provide suport modules for testing.
+
+The module inherits directly from WebGUI::Asset.
+
+=head1 SYNOPSIS
+
+use WebGUI::Asset::JSONCollateralDummy;
+
+=head1 METHODS
+
+These methods are available from this class:
+
+=cut
+
+#-------------------------------------------------------------------
+
+=head2 definition ( )
+
+=cut
+
+sub definition {
+    my $class = shift;
+    my $session = shift;
+    my $definition = shift || [];
+    my %properties;
+    tie %properties, 'Tie::IxHash';
+    %properties = (
+        jsonField => {
+            label        => 'jsonField',
+            hoverHelp    => 'Not really needed, it is for internal data in this test case',
+            fieldType    => 'textarea',
+            serialize    => 1,
+            defaultValue => [],
+            noFormPost   => 1,
+        },
+    );
+    push(@{$definition}, {
+        assetName=>'JSON Collateral Dummy',
+        tableName=>'jsonCollateralDummy',
+        autoGenerateForms=>1,
+        className=>'WebGUI::Asset::JSONCollateralDummy',
+        icon=>'assets.gif',
+        properties=>\%properties
+        }
+    );
+    return $class->next::method($session, $definition);
+}
+
+1;
+
+#vim:ft=perl

t/lib/WebGUI/Asset/RssAspectDummy.pm

@@ -0,0 +1,74 @@
+package WebGUI::Asset::RssAspectDummy;
+
+=head1 LEGAL
+
+ -------------------------------------------------------------------
+  WebGUI is Copyright 2001-2009 Plain Black Corporation.
+ -------------------------------------------------------------------
+  Please read the legal notices (docs/legal.txt) and the license
+  (docs/license.txt) that came with this distribution before using
+  this software.
+ -------------------------------------------------------------------
+  http://www.plainblack.com                     info@plainblack.com
+ -------------------------------------------------------------------
+
+=cut
+
+use strict;
+use Tie::IxHash;
+use Class::C3;
+use base qw/WebGUI::AssetAspect::RssFeed WebGUI::Asset/;
+
+=head1 NAME
+
+Package WebGUI::Asset::RssAspectDummy
+
+=head1 DESCRIPTION
+
+A dummy module for testing the RssAspect.  The module really doesn't
+do anything, except provide suport modules for testing.
+
+The module inherits directly from WebGUI::Asset.
+
+=head1 SYNOPSIS
+
+use WebGUI::Asset::RssAspectDummy;
+
+=head1 METHODS
+
+These methods are available from this class:
+
+=cut
+
+#-------------------------------------------------------------------
+
+=head2 getRssFeedItems ( )
+
+Returns an arrayref of hashrefs, containing information on stories
+for generating an RSS and Atom feeds.
+
+=cut
+
+sub getRssFeedItems {
+
+return [
+    {
+        title       => 'this title',
+        description => 'this description',
+        'link'      => 'this link',
+        author      => 'this author',
+        date        => 'this date',
+    },
+    {
+        title       => 'another title',
+        description => 'another description',
+        author      => 'another author',
+        date        => 'another date',
+    },
+];
+
+}
+
+1;
+
+#vim:ft=perl

t/lib/WebGUI/Form/FormTest.pm

@@ -0,0 +1,52 @@
+package WebGUI::Form::FormTest;
+
+=head1 LEGAL
+
+ -------------------------------------------------------------------
+  WebGUI is Copyright 2001-2009 Plain Black Corporation.
+ -------------------------------------------------------------------
+  Please read the legal notices (docs/legal.txt) and the license
+  (docs/license.txt) that came with this distribution before using
+  this software.
+ -------------------------------------------------------------------
+  http://www.plainblack.com                     info@plainblack.com
+ -------------------------------------------------------------------
+
+=cut
+
+use strict;
+use base 'WebGUI::Form::Control';
+use WebGUI::International;
+
+=head1 NAME
+
+Package WebGUI::Form::FormTest
+
+=head1 DESCRIPTION
+
+Dummy Form plugin for testing dynamic loading of Forms from other locations.
+
+=head1 SEE ALSO
+
+This is a subclass of WebGUI::Form::Control.
+
+=head1 METHODS 
+
+The following methods are specifically available from this class. Check the superclass for additional methods.
+
+=cut
+
+#-------------------------------------------------------------------
+
+=head2 getName ( session )
+
+Returns the human readable name of this control.
+
+=cut
+
+sub getName {
+    my ($self, $session) = @_;
+    return 'FormTest';
+}
+
+1;

t/lib/WebGUI/Form_Checking.pm

@@ -0,0 +1,87 @@
+package WebGUI::Form_Checking;
+
+use Test::MockObject;
+use Test::More;
+use Test::Deep;
+
+sub auto_check {
+	my ($session, $formType, $testBlock) = @_;
+	my $origSessionRequest = $session->{_request};
+
+	##Create a by-name interface to the test to simplify the
+	##mocked request.
+	my %tests = map { $_->{key} => $_ } @{ $testBlock };
+	is(scalar keys %tests, scalar @{ $testBlock }, 'no collisions in testBlock');
+
+	my $request = Test::MockObject->new;
+	$request->mock('body',
+		sub {
+			my ($self, $value) = @_;
+			return unless exists $tests{$value};
+			if (ref $tests{$value}->{testValue} eq "ARRAY") {
+				return @{ $tests{$value}->{testValue} } ;
+			}
+			else {
+				return $tests{$value}->{testValue};
+			}
+		}
+	);
+    $request->mock('param', sub {shift->body(@_)});
+
+	$session->{_request} = $request;
+
+	foreach my $test ( @{ $testBlock } ) {
+		$test->{dataType} ||= 'SCALAR';
+		$test->{expected} = $test->{testValue} if $test->{expected} eq 'EQUAL';
+		if ($test->{dataType} eq 'SCALAR') {
+			my $value = $session->form->get($test->{key}, $formType);
+			is($value, $test->{expected}, $test->{comment});
+		}
+		elsif ($test->{dataType} eq 'ARRAY') {
+			my @value = $session->form->get($test->{key}, $formType);
+			cmp_bag(\@value, $test->{expected}, $test->{comment});
+		}
+	}
+
+	$session->{_request} = $origSessionRequest;
+}
+
+
+
+#######################################################################
+
+=head2 get_request
+
+!!! TODO !!!
+
+Gets a Test::MockObject to be given to the session object that will allow for
+processing of form parameters. 
+
+This will be easier to manage, as you won't have
+to make multiple forms for elements that can return differently formatted data
+based on configuration.
+
+Usage:
+
+ my $old_request = $session->{_request};
+ 
+ my $request = WebGUI::Form_Checking::get_request($session,$value);
+ # $value can be either a scalar value or an array reference
+ $session->{_request} = $request;
+ 
+ # Test the value here
+ # Maybe make more mock request objects and test more values
+ 
+ # Reset the session back
+ $session->{_request} = $old_session;
+ 
+=cut
+
+sub get_request
+{
+	warn "WebGUI::Form_Checking::get_request is still TODO!";
+}
+
+
+
+1;

t/lib/WebGUI/Macro/Callback.pm

@@ -0,0 +1,17 @@
+package WebGUI::Macro::Callback;
+
+use strict;
+use warnings;
+
+my $callback = sub {''};
+
+sub process {
+    return $callback->(@_);
+}
+
+sub setCallback {
+    $callback = shift;
+}
+
+1;
+

t/lib/WebGUI/Macro/InfiniteMacro.pm

@@ -0,0 +1,28 @@
+package WebGUI::Macro::InfiniteMacro;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    my $slow = shift;
+    if ($slow) {
+        my $rand = int(rand(10000));
+        return <<END;
+^InfiniteMacro(^dfkgjhdfgk();dssdfsdfawilygth4 wu gbzwilrstg 
+sdfgdsfg
+r7ilsgg hbawl
+dsfgsdfgiegvgv
+dfggvac
+"sdaf${rand}gsdfgdsfg"
+w3avvbfielysv iw4yvg silyrgvb iyzrsv bilw4u bgizs4rv,
+"efgkhgsdfges.rkdjgdskjghsalkgh\\"\\"\\"sag"       );';
+END
+    }
+    else {
+        return '^InfiniteMacro();';
+    }
+}
+
+1;
+

t/lib/WebGUI/Macro/MacroEmpty.pm

@@ -0,0 +1,12 @@
+package WebGUI::Macro::MacroEmpty;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    return "";
+}
+
+1;
+

t/lib/WebGUI/Macro/MacroEnd.pm

@@ -0,0 +1,12 @@
+package WebGUI::Macro::MacroEnd;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    return "Nest();";
+}
+
+1;
+

t/lib/WebGUI/Macro/MacroNest.pm

@@ -0,0 +1,12 @@
+package WebGUI::Macro::MacroNest;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    return "^Extras;";
+}
+
+1;
+

t/lib/WebGUI/Macro/MacroStart.pm

@@ -0,0 +1,12 @@
+package WebGUI::Macro::MacroStart;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    return "^Macro";
+}
+
+1;
+

t/lib/WebGUI/Macro/MacroUndef.pm

@@ -0,0 +1,12 @@
+package WebGUI::Macro::MacroUndef;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    return;
+}
+
+1;
+

t/lib/WebGUI/Macro/ReverseParams.pm

@@ -0,0 +1,12 @@
+package WebGUI::Macro::ReverseParams;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    return join '', reverse @_;
+}
+
+1;
+

t/lib/WebGUI/Macro/VisualMacro.pm

@@ -0,0 +1,14 @@
+package WebGUI::Macro::VisualMacro;
+
+use strict;
+use warnings;
+
+sub process {
+    my $session = shift;
+    my @params = @_;
+    $_ = "`$_`" for @params;
+    return "\@MacroCall[" . join('.', @params) . "]:";
+}
+
+1;
+

t/lib/WebGUI/PseudoRequest.pm

@@ -0,0 +1,447 @@
+package WebGUI::PseudoRequest;
+
+=head1 LEGAL
+
+ -------------------------------------------------------------------
+  WebGUI is Copyright 2001-2009 Plain Black Corporation.
+ -------------------------------------------------------------------
+  Please read the legal notices (docs/legal.txt) and the license
+  (docs/license.txt) that came with this distribution before using
+  this software.
+ -------------------------------------------------------------------
+  http://www.plainblack.com                     info@plainblack.com
+ -------------------------------------------------------------------
+
+=cut
+
+use strict;
+
+use Test::MockObject;
+
+BEGIN {
+    if( do { no strict 'refs'; ! exists ${"Apache2::"}{"Cookie::"} } ) {
+        Test::MockObject->fake_module(
+            'Apache2::Cookie',
+            new => sub {
+                my $class = shift;
+                my $self = Test::MockObject->new;
+                $self->set_isa($class);
+                $self->set_true(qw(expires domain bake));
+            },
+        );
+    }
+
+    if( do { no strict 'refs'; ! exists ${"APR::"}{"Request::"} } ) {
+        Test::MockObject->fake_module('APR::Request::Apache2',
+            handle => sub {
+                return $_[1];
+            },
+        );
+    }
+}
+
+use WebGUI::PseudoRequest::Headers;
+use WebGUI::PseudoRequest::Upload;
+
+=head1 NAME
+
+Package WebGUI::PseudoRequest
+
+=head1 DESCRIPTION
+
+This is an almost complete imitation of Apache2::Request.  You can use this package to
+create a request object that will work with WebGUI, without actually being inside
+the mod_perl environment.
+
+Why in the world would you want to do this?  Well, when doing API testing sometimes
+you run across things that require a request object, but you don't really want to
+fire up Apache in order to do it.  This will let you bypass that.
+
+=head2 new
+
+Construct a new PseudoRequest object.  Creates a new Headers object as well and places
+it inside the PseudoRequest object.
+
+=cut
+
+sub new {
+	my $this = shift;
+	my $class = ref($this) || $this;
+	my $headers = WebGUI::PseudoRequest::Headers->new();
+	my $self = { headers_out => $headers, headers_in => {} };
+	bless $self, $class;
+	return $self;
+}
+
+sub hostname { 'localhost' }
+
+#----------------------------------------------------------------------------
+
+=head2 body ( [$value])
+
+Compatibility method.  Returns the requested form value, $value.  If $value isn't passed in, returns
+all form variables.
+
+=cut
+
+
+sub body {
+	my $self = shift;
+	my $value = shift;
+    if ( !defined $value ) {
+        return if !$self->{body};
+        return keys %{ $self->{body} } if wantarray;
+        return { %{ $self->{body} } };
+    }
+	if (defined $self->{body}->{$value}) {
+        if (wantarray && ref $self->{body}->{$value} eq "ARRAY") {
+            return @{$self->{body}->{$value}};
+        }
+        elsif (ref $self->{body}->{$value} eq "ARRAY") {
+            return $self->{body}->{$value}->[0];
+        }
+        else {
+            return $self->{body}->{$value};
+        }
+    }
+    else {
+        if (wantarray) {
+            return ();
+        }
+        else {
+            return undef;
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+
+=head2 setup_body ( $value )
+
+Setup the object's body method so that it can be used.  $value should be a hash ref of named
+form variables and values.
+
+=cut
+
+sub setup_body {
+	my $self = shift;
+	my $value = shift;
+	$self->{body} = $value;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 content_type ( [$value] )
+
+Getter and setter for content_type.  If $value is passed in, it will set the content_type of
+the object to that.  Returns the content_type stored in the object.
+
+=cut
+
+sub content_type {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{content_type} = $value;
+	}
+	return $self->{content_type};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 headers_in ( )
+
+Mimics the behavior of Apache2::Request->headers_in.
+
+=cut
+
+sub headers_in {
+       my $self = shift;
+       return $self->{headers_in};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 headers_out ( )
+
+Returns the PseudoRequst::Headers object stored in $self for access to the headers.
+
+=cut
+
+sub headers_out {
+	my $self = shift;
+	return $self->{headers_out}; ##return object for method chaining
+}
+
+#----------------------------------------------------------------------------
+
+=head2 no_cache ( [$value] )
+
+Getter and setter for no_cache.  If $value is passed in, it will set no_cache of
+the object to that.  Returns the no_cache value stored in the object.
+
+=cut
+
+sub no_cache {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{no_cache} = $value;
+	}
+	return $self->{no_cache};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 param ( [$value])
+
+Compatibility method.  Works exactly like the body method.
+
+=cut
+
+sub param {
+	my $self = shift;
+    $self->body(@_);
+}
+
+#----------------------------------------------------------------------------
+
+=head2 setup_param ( $value )
+
+Setup the object's param method so that it can be used.  $value should be a hash ref of named
+form variables and values.
+
+=cut
+
+sub setup_param {
+	my $self = shift;
+    $self->setup_body(@_);
+}
+
+#----------------------------------------------------------------------------
+
+=head2 clear_output ( )
+
+Clear the internally cached request output generated by calling the
+C<print> method.
+
+=cut
+
+sub clear_output {
+    my $self = shift;
+    $self->{output} = '';
+}
+
+#----------------------------------------------------------------------------
+
+=head2 get_output ( )
+
+Get the internally cached request output generated by calling the
+C<print> method.  Returns it as a scalar.
+
+=cut
+
+sub get_output {
+    my $self = shift;
+    return $self->{output};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 method ( [ $method ] )
+
+Getter/setter for the HTTP request method.
+
+=cut
+
+sub method {
+    my ($self, $newMethod) = @_;
+    my $method = $self->{method};
+    if (defined $newMethod) {
+        $self->{method} = $newMethod;
+    }
+    return $method;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 print ( @values )
+
+Fake print method for the PseudoRequest object.  It caches everything printed
+to it by concatenating @values together, just like print would.  Use clear_output
+to clear the cached value, and get_output to access it.
+
+=cut
+
+sub print {
+    my $self = shift;
+    $self->{output} .= join '', @_;
+    return 1;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 protocol ( $value )
+
+Getter and setter for protocol.  If $value is passed in, it will set the protocol of
+the object to that.  Returns the protocol value stored in the object.
+
+=cut
+
+sub protocol {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{protocol} = $value;
+	}
+	return $self->{protocol};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 status ( $value )
+
+Getter and setter for status.  If $value is passed in, it will set the status of
+the object to that.  Returns the status value stored in the object.
+
+=cut
+
+sub status {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{status} = $value;
+	}
+	return $self->{status};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 status_line ( $value )
+
+Getter and setter for status_line.  If $value is passed in, it will set the status_line of
+the object to that.  Returns the status_line value stored in the object.
+
+=cut
+
+sub status_line {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{status_line} = $value;
+	}
+	return $self->{status_line};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 upload ( $formName, [ $uploadFileHandler ] )
+
+Getter and setter for upload objects, which are indexed in this object by $formName.
+Returns what was stored in the slot referred to as $formName.  If $formName is false,
+it returns undef.
+
+=head3 $uploadFileHandle.
+
+$uploadFileHandle should be an array ref of WebGUI::PseudoRequest::Upload objects.  If you
+pass it $uploadFileHandle, it will set store the object under the name, $formName.
+
+=cut
+
+sub upload {
+	my $self = shift;
+    my $formName = shift;
+    my $uploadFileHandles = shift;
+    return unless $formName;
+	if (defined $uploadFileHandles) {
+		$self->{uploads}->{$formName} = $uploadFileHandles;
+	}
+	return @{ $self->{uploads}->{$formName} };
+}
+
+#----------------------------------------------------------------------------
+
+=head2 uploadFiles ( $formName, $filesToUpload )
+
+Convenience method for uploading several files at once into the PseudoRequest object,
+all to be referenced off of $formName.  If $formName is false, it returns undef.
+
+=head3 $fileToUpload
+
+$uploadFileHandle should be an array ref of complete paths to files.  The method will
+create one PseudoRequest::Upload object per file, then store the array ref
+using the upload method.
+
+=cut
+
+sub uploadFiles {
+	my $self = shift;
+    my $formName = shift;
+    my $filesToUpload = shift;
+    return unless $formName;
+    return unless scalar $filesToUpload;
+    my @uploadObjects = ();
+    foreach my $file (@{ $filesToUpload }) {
+        my $upload = WebGUI::PseudoRequest::Upload->new($file);
+        push @uploadObjects, $upload;
+    }
+    $self->upload($formName, \@uploadObjects);
+}
+
+#----------------------------------------------------------------------------
+
+=head2 uri ( $value )
+
+Getter and setter for uri.  If $value is passed in, it will set the uri of
+the object to that.  Returns the uri value stored in the object.
+
+=cut
+
+sub uri {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{uri} = $value;
+	}
+	return $self->{uri};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 user ( $value )
+
+Getter and setter for user.  If $value is passed in, it will set the user of
+the object to that.  Returns the user value stored in the object.
+
+=cut
+
+sub user {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{user} = $value;
+	}
+	return $self->{user};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 jar ( $value )
+
+Getter and setter for cookie jar.  If $value is passed in, it will
+set the cookie jar of the object to that.  Returns the cookie jar
+hash.
+
+=cut
+
+sub jar {
+    my $self = shift;
+    my $value = shift;
+    if (defined $value) {
+        $self->{jar} = $value;
+    }
+    return $self->{jar};
+}
+
+1;
+

t/lib/WebGUI/PseudoRequest/Headers.pm

@@ -0,0 +1,67 @@
+package WebGUI::PseudoRequest::Headers;
+
+=head1 LEGAL
+
+ -------------------------------------------------------------------
+  WebGUI is Copyright 2001-2009 Plain Black Corporation.
+ -------------------------------------------------------------------
+  Please read the legal notices (docs/legal.txt) and the license
+  (docs/license.txt) that came with this distribution before using
+  this software.
+ -------------------------------------------------------------------
+  http://www.plainblack.com                     info@plainblack.com
+ -------------------------------------------------------------------
+
+=cut
+
+use strict;
+
+=head1 NAME
+
+Package WebGUI::PseudoRequest::Headers
+
+=head2 new
+
+Construct a new PseudoRequest::Headers object.  This is just for holding headers.
+It doesn't do any magic.
+
+=cut
+
+sub new {
+	my $this = shift;
+	my $class = ref($this) || $this;
+	my $self = { headers => {} };
+	bless $self, $class;
+	return $self;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 set( $key, $value )
+
+Set a key, value pair in the header object.
+
+=cut
+
+sub set {
+	my $self = shift;
+	my $key = shift;
+	my $value = shift;
+	$self->{headers}->{$key} = $value;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 fetch
+
+Returns the entire internal hashref of headers.
+
+=cut
+
+sub fetch {
+	my $self = shift;
+	return $self->{headers};
+}
+
+1;
+

t/lib/WebGUI/PseudoRequest/Upload.pm

@@ -0,0 +1,119 @@
+package WebGUI::PseudoRequest::Upload;
+
+=head1 LEGAL
+
+ -------------------------------------------------------------------
+  WebGUI is Copyright 2001-2009 Plain Black Corporation.
+ -------------------------------------------------------------------
+  Please read the legal notices (docs/legal.txt) and the license
+  (docs/license.txt) that came with this distribution before using
+  this software.
+ -------------------------------------------------------------------
+  http://www.plainblack.com                     info@plainblack.com
+ -------------------------------------------------------------------
+
+=cut
+
+use strict;
+use File::Copy ();
+
+=head1 NAME
+
+Package WebGUI::PseudoRequest::Upload
+
+=head2 new ( [$file] )
+
+Construct a new PseudoRequest::Upload object.  This is just for holding headers.
+It doesn't do any magic.
+
+=head3 $file
+
+The complete path to a file.  If this is sent to new, it will go ahead and open
+a filehandle to that file for you, saving you the need to call the fh, filename
+and filesize methods.
+
+=cut
+
+sub new {
+	my $this = shift;
+	my $class = ref($this) || $this;
+	my $self = {
+        fh       => undef,
+        size     => 0,
+        filename => '',
+        output   => '',
+    };
+    my $file = shift;
+    if ($file and -e $file) {
+        $self->{filename} = $file;
+        $self->{size} = (stat $file)[7];
+        open my $fh, '<' . $file or
+            die "Unable to open $file for reading and creating a filehandle: $!\n";
+        $self->{fh} = $fh;
+    }
+	bless $self, $class;
+	return $self;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 fh ( [$value] )
+
+Getter and setter for fh.  If $value is passed in, it will set the internal filehandle in
+the object to that.  Returns the filehandle stored in the object.
+
+=cut
+
+sub fh {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{fh} = $value;
+	}
+	return $self->{fh};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 filaname ( [$value] )
+
+Getter and setter for filename.  If $value is passed in, it will set the filename in
+the object to that.  Returns the filename in the object.
+
+=cut
+
+sub filename {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{filename} = $value;
+	}
+	return $self->{filename};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 size ( [$value] )
+
+Getter and setter for size.  If $value is passed in, it will set the internal size in
+the object to that.  Returns the size stored in the object.
+
+=cut
+
+sub size {
+	my $self = shift;
+	my $value = shift;
+	if (defined $value) {
+		$self->{size} = $value;
+	}
+	return $self->{size};
+}
+
+sub link {
+    my $self = shift;
+    my $dest = shift;
+    return File::Copy::copy($self->filename, $dest);
+}
+
+1;
+

t/lib/WebGUI/Serialize.pm

@@ -0,0 +1,56 @@
+package WebGUI::Serialize;
+
+use base qw/WebGUI::Crud/;
+use WebGUI::Utility;
+
+#-------------------------------------------------------------------
+
+=head2 crud_definition
+
+WebGUI::Crud definition for this class.
+
+=head3 tableName
+
+crudSerialize
+
+=head3 tableKey
+
+serializeId
+
+=head3 sequenceKey
+
+None.  Bundles have no sequence amongst themselves.
+
+=head3 properties
+
+=head4 someName
+
+The name of a crud.
+
+=head4 jsonField
+
+JSON blob text field.
+
+=cut
+
+sub crud_definition {
+    my ($class, $session) = @_;
+    my $definition = $class->SUPER::crud_definition($session);
+    $definition->{tableName}   = 'crudSerialize';
+    $definition->{tableKey}    = 'serializeId';
+    $definition->{sequenceKey} = '';
+    my $properties = $definition->{properties};
+    $properties->{someName} = {
+        fieldType    => 'text',
+        defaultValue => 'someName',
+    };
+    $properties->{jsonField} = {
+        fieldType    => 'textarea',
+        defaultValue => [],
+        serialize    => 1,
+    };
+    return $definition;
+}
+
+
+1;

t/lib/WebGUI/SubClass.pm

@@ -0,0 +1,21 @@
+package WebGUI::Crud::Subclass;
+
+use strict;
+
+use base 'WebGUI::Crud';
+
+sub crud_definition {
+    my ($class, $session) = @_;
+    my $definition = $class->SUPER::crud_definition($session);
+    $definition->{tableName}   = 'crudSubclass';
+    $definition->{tableKey}    = 'crudSubclassId';
+    $definition->{sequenceKey} = '';
+    my $properties = $definition->{properties};
+    $properties->{field1} = {
+        fieldType    => 'integer',
+        defaultValue => 5,
+    };    
+    return $definition;
+}
+
+1;

t/lib/WebGUI/Test/Activity.pm

@@ -0,0 +1,109 @@
+package WebGUI::Test::Activity;
+
+use WebGUI::Workflow;
+use WebGUI::Test;
+
+=head Name
+
+package WebGUI::Test::Activity;
+
+=head Description
+
+ This package encapsulates the code required to run
+ an activity.
+
+=head Usage
+
+use WebGUI::Test::Activity;
+
+my $instance = WebGUI::Test::Activity->create( $session, 'WebGUI::Workflow::Activity::RemoveOldCarts', {
+		cartTimeout => 3600,
+} );
+
+is( $instance->run, 'complete', 'activity complete' );
+is( $instance->run, 'done', 'activity done' );
+$instance->reset;
+is( $instance->run, 'complete', 'activity complete' );
+is( $instance->run, 'done', 'activity done' );
+$instance->delete;
+
+=head methods
+
+=head2 create
+
+=params
+
+session -- the session variable
+
+class -- the class for the activity to run
+
+params -- params to set in the workflow
+
+=cut
+
+sub create {
+    my $myClass = shift;
+    my $session = shift;
+    my $activityClass = shift;
+    my $activityParams;
+    if( exists $_[0] and ref $_[0] eq 'HASH' ) {
+        $activityParams = shift ;
+    } else {
+        $activityParams = { @_ };
+    }
+	my $workflow  = WebGUI::Workflow->create($session,
+	    {
+		enabled    => 1,
+		objectType => $activityParams->{objectType} || 'None',
+		mode       => 'realtime',
+	    },
+	);
+        delete $activityParams->{objectType};
+	my $activity = $workflow->addActivity($activityClass);
+    if( scalar( keys %$activityParams ) > 0 ) {
+	$activity->set(%$activityParams);
+    }
+
+	my $instance = WebGUI::Workflow::Instance->create($session,
+	    {
+		workflowId              => $workflow->getId,
+		skipSpectreNotification => 1,
+	    }
+	);
+
+	addToCleanup($workflow);
+
+    return bless { instance => $instance,
+		   session => $session,
+                   workflow => $workflow }, __PACKAGE__;
+}
+
+=head2 run
+
+calls run on the instance of the workflow
+
+=cut
+
+sub run {
+    return $_[0]{instance}->run;
+}
+
+=head2 reset
+
+creates a new instance of the workflow so that it can be re-run
+
+=cut
+
+sub reset {
+    my $self = shift;
+    my $session = $self->{session};
+    $self->{instance} = WebGUI::Workflow::Instance->create($session,
+	{
+	    workflowId              => $self->{workflow}->getId,
+	    skipSpectreNotification => 1,
+	}
+    );
+}
+
+1;
+

t/lib/WebGUI/Test/Event.pm

@@ -0,0 +1,78 @@
+package WebGUI::Test::Event;
+
+use List::Util qw(first);
+use Exporter qw(import);
+
+our @EXPORT = qw(trap);
+
+=head1 LEGAL
+
+ -------------------------------------------------------------------
+  WebGUI is Copyright 2001-2009 Plain Black Corporation.
+ -------------------------------------------------------------------
+  Please read the legal notices (docs/legal.txt) and the license
+  (docs/license.txt) that came with this distribution before using
+  this software.
+ -------------------------------------------------------------------
+  http://www.plainblack.com                     info@plainblack.com
+ -------------------------------------------------------------------
+
+=cut
+
+use strict;
+use warnings;
+
+=head1 SYNOPSIS
+
+Temporarily handle WebGUI::Events.
+
+=head1 METHODS
+
+These methods are available from this class:
+
+=cut
+
+our $session;
+our @names;
+our @trap;
+
+my $handlerName = __PACKAGE__ . '::handler';
+
+sub handler {
+    my ($s, $n) = @_;
+    return unless first { $_ eq $n } @names;
+    push @trap, \@_;
+};
+
+#-------------------------------------------------------------------
+
+=head2 trap ($code, $session, @names)
+
+Traps the events named by @names and returns them as a list of arrayrefs in
+the order they occured. The arrayrefs are all arguments passed to the event
+handler.
+
+=cut
+
+sub trap(&$@) {
+    my $block = shift;
+    local ($session, @names) = @_;
+    local @trap;
+
+    my $config  = $session->config;
+    my $events  = $config->get('events');
+    local %WebGUI::Event::cache;
+    for my $name (@names) {
+        $config->set("events/$name", $handlerName);
+    }
+    eval { $block->() };
+    my $err = $@;
+    if ($events) {
+        $config->set(events => $events);
+    }
+    else {
+        $config->delete('events');
+    }
+    die $err if $err;
+    return @trap;
+}

t/lib/WebGUI/Test/Fork.pm

@@ -0,0 +1,20 @@
+package WebGUI::Test::Fork;
+
+sub simple {
+    my ( $self, $arr ) = @_;
+    $self->update( $arr->[0] );
+}
+
+sub error {
+    my ( $self, $arr ) = @_;
+    die "$arr->[0]\n";
+}
+
+sub complex {
+    my $self = shift;
+    $self->update( sub {'foo'} );
+    $self->update( sub {'bar'} );
+    $self->update( sub {'baz'} );
+}
+
+1;

t/lib/WebGUI/Test/Maker.pm

@@ -0,0 +1,197 @@
+package WebGUI::Test::Maker;
+
+use base 'Test::Builder::Module';
+
+my $CLASS = __PACKAGE__;
+
+=head1 NAME
+
+WebGUI::Test::Maker
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use WebGUI::Test::Maker;
+
+ my $maker   = WebGUI::Test::Maker->new();
+
+ $maker->set( test => sub { ... } );
+ $maker->set( plan_per_test => 2 );
+
+ $maker->prepare({
+            title       => "Test something",
+            args        => [ ... ],
+        });
+
+ plan tests => $maker->plan;
+
+ $maker->run;
+
+=head1 DESCRIPTION
+
+Test generator for generating repeatable tests. 
+
+Set a subroutine that runs some tests and run it over and over with
+different arguments.
+
+=head1 DEPENDS
+
+This module depends on
+
+=over 4
+
+=item * 
+
+Test::More
+
+=back
+
+=head1 METHODS
+
+=head2 new
+
+Create a new WebGUI::Test::Maker object.
+
+=cut
+
+sub new {
+    my $class   = shift;
+    my $self    = {};
+
+    return bless $self, $class;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 get
+
+Get a setting. Set L<set> for a list of settings.
+
+=cut
+
+sub get {
+    my $self    = shift;
+    my $key     = shift;
+
+    return $self->{_settings}->{$key};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 plan
+
+Returns the number of tests currently prepared. This module is so generic
+that you must set the C<plan_per_test> value before calling this method.
+
+=cut
+
+sub plan {
+    my $self        = shift;
+    
+    return $self->plan_per_test * @{$self->{_tests}};
+}
+
+#----------------------------------------------------------------------------
+
+=head2 plan_per_test
+
+Returns the current value of the C<plan_per_test> setting.
+
+=cut
+
+sub plan_per_test {
+    return $self->get("plan_per_test");
+}
+
+#----------------------------------------------------------------------------
+
+=head2 prepare
+
+Prepare a test(s). Returns the object for convenience. The following keys 
+are optional:
+
+=over 4
+
+=item args
+
+An array reference of arguments to the subroutine.
+
+=back
+
+There are no required arguments.
+
+=cut
+
+sub prepare {
+    my $self        = shift;
+    my @tests       = @_;
+    my $test_num    = 0;
+    for my $test (@tests) {
+        $test_num++;
+
+        push @{$self->{_tests}}, $test;
+    }
+
+    return $self;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 run
+
+Run the tests we've prepared and delete them as we run them.
+
+=cut
+
+sub run {
+    my $self        = shift;
+
+    my $tb = $CLASS->builder;
+    # This is to fix SKIP and TODO detection
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+     
+    while (my $test = shift @{ $self->{_tests} }) {
+        my $sub     = $self->get("test");
+        if ($test->{args}) {
+            $sub->(@{ $test->{args} });
+        }
+        else {
+            $sub->();
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+
+=head2 set
+
+Set a setting.
+
+Available settings:
+
+=over 4
+
+=item test
+
+A subref that runs some tests. The first argument to this subref will be the
+WebGUI::Test::Maker object. The second and subsequent arguments will be the
+C<args> key from the prepared test.
+
+=item plan_per_test
+
+Set the number of tests that each C<test> sub runs to be used to plan the 
+number of total tests that will be run.
+
+=back
+
+=cut
+
+sub set {
+    my $self    = shift;
+    my $key     = shift;
+    my $value   = shift;
+
+    $self->{_setting}->{$key} = $value;
+}
+
+1;

t/lib/WebGUI/Test/Maker/HTML.pm

@@ -0,0 +1,256 @@
+package WebGUI::Test::Maker::HTML;
+
+use base 'WebGUI::Test::Maker';
+use Scalar::Util qw( blessed );
+use Carp qw( croak );
+use Test::More;
+
+
+=head1 NAME
+
+WebGUI::Test::Maker::HTML -- Test::Maker subclass for WebGUI HTMLs
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use WebGUI::Test::Maker::HTML;
+
+ my $maker   = WebGUI::Test::Maker::HTML->new();
+
+ $maker->prepare({
+            object      => $object,
+            method      => "www_editSave",
+            user        => WebGUI::User->new,
+            userId      => "userId",
+            formParams  => { ... },
+            uploads     => { ... },
+            
+            # Test for a WebGUI::Session::Privilege page
+            test_privilege  => "permission",
+
+            # Test for some regular expressions
+            test_regex  => [ qr/../, qr/.../, ... ],
+        });
+
+ plan tests => $maker->plan;
+
+ $maker->run;
+
+=head1 DESCRIPTION
+
+This Test::Maker subclass tests the HTML output by WebGUI methods in a 
+variety of ways.
+
+Uses WebGUI::Test->getPage to get the HTML for a page, and so is limited
+to whatever C<getPage> can access.
+
+=head1 TODO
+
+Provide a method to give a proper HTML::Parser to test with.
+
+Provide a method to test that a certain page was created with a certain 
+template.
+
+=head1 DEPENDS
+
+This module depends on
+
+=over 4
+
+=item * 
+
+Test::More
+
+=back
+
+=head1 METHODS
+
+=head2 new
+
+Create a new WebGUI::Test::Maker::HTML object.
+
+=head2 get
+
+Get a setting. Set L<set> for a list of settings.
+
+=cut
+
+#----------------------------------------------------------------------------
+
+=head2 plan
+
+This module plans as follows:
+
+    - 1 and only 1 test for any test_privilege test
+    - 1 test for each member of a test_regex test
+
+=cut
+
+sub plan {
+    my $self        = shift;
+    my $plan;
+    
+    for my $test ( @{ $self->{_tests} } ) {
+        if ($test->{test_privilege}) {
+            $plan++;
+            next;
+        }
+        if ($test->{test_regex}) {
+            $plan += @{$test->{test_regex}};
+        }
+    }
+
+    return $plan;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 plan_per_test
+
+Returns undef. There is no way to pre-calculate how many tests this will run
+
+=cut
+
+sub plan_per_test {
+    return undef;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 prepare
+
+Prepare a test(s). Returns the object for convenience. The following keys 
+are required:
+
+=over 4
+
+=item object
+
+An instanciated object to work on.
+
+=item method
+
+The permissions method to test
+
+=back
+
+At least one of the following keys are required:
+
+=over 4
+
+=item test_privilege
+
+Tests for a WebGUI::Session::Privilege response. Valid values for this key
+are: adminOnly, insufficient, noAccess, notMember, vitalComponent
+
+=item test_regex
+
+Tests for some regular expressions. This key must be an array reference of 
+qr().
+
+=back
+
+The following key are optional:
+
+=over 4
+
+=item user
+
+A WebGUI::User object to use for the test.
+
+=item userId
+
+A user ID to make a WebGUI::User object to use for the test
+
+=item formParams
+
+A hash reference of form parameters to use for the test
+
+=item uploads 
+
+A hash reference of file uploads to use for the test
+
+=back
+
+=cut
+
+sub prepare {
+    my $self        = shift;
+    my @tests       = @_;
+    my $test_num    = 0;
+    for my $test (@tests) {
+        $test_num++;
+
+        croak("Couldn't prepare: Test $test_num has no object")
+            unless $test->{object};
+        croak("Couldn't prepare: Test $test_num has no method")
+            unless $test->{method};
+        croak("Couldn't prepare: Test $test_num has test (test_privilege or test_regex)")
+            unless $test->{test_privilege} || $test->{test_regex};
+        croak("Couldn't prepare: Test $test_num, test_regex is not an array reference")
+            if $test->{test_regex} && ref $test->{test_regex} ne "ARRAY";
+        croak("Couldn't prepare: Test $test_num, $test->{test_privilege} is not a valid test_privilege value (adminOnly, insufficient, noAccess, notMember, vitalComponent)")
+            if $test->{test_privilege} && $test->{test_privilege} !~ m/adminOnly|insufficient|noAccess|notMember|vitalComponent/;
+
+        push @{$self->{_tests}}, $test;
+    }
+
+    return $self;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 run
+
+Run the tests we've prepared and delete them as we run them.
+
+=cut
+
+sub run {
+    my $self        = shift;
+
+    # This is to fix detection of SKIP and TODO
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+     
+    while (my $test = shift @{ $self->{_tests} }) {
+        my $o       = $test->{object};
+        my $m       = $test->{method};
+    
+        # Get the HTML
+        my $opts    = {};
+        for my $key (qw{ }) {
+            $opts->{$key} = $test->{$key};
+        }
+
+        my $html
+            = WebGUI::Test->getPage( $o, $m, $opts );
+
+        # Run the tests
+        if ($test->{test_privilege}) {
+            my $priv_method = $test->{test_privilege};
+            my $test        = $o->session->privilege->$priv_method();
+
+            like( $html, $test, "$m contains privilege message $priv_method for object " . blessed $o );
+
+            next;
+        }
+        
+        if ($test->{test_regex}) {
+            for my $regex ( @{ $test->{test_regex} } ) {
+                like( $html, $regex, "$m contains $regex for object " . blessed $o );
+            }
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+
+=head2 set
+
+Set a setting.
+
+Currently this module has no settings
+
+=cut
+
+1;

t/lib/WebGUI/Test/Maker/Permission.pm

@@ -0,0 +1,303 @@
+package WebGUI::Test::Maker::Permission;
+
+use base 'WebGUI::Test::Maker';
+use Scalar::Util qw( blessed );
+use Carp qw( croak );
+use Test::More;
+
+my $CLASS = __PACKAGE__;
+
+=head1 NAME
+
+WebGUI::Test::Maker::Permission -- Test::Maker subclass for WebGUI Permissions
+
+=head1 SYNOPSIS
+
+ use Test::More;
+ use WebGUI::Test::Maker::Permission;
+
+ my $maker   = WebGUI::Test::Maker::Permission->new();
+
+ $maker->prepare({
+            object      => WebGUI::Asset->new,
+            method      => "canView",
+            pass        => [userId, userId],
+            fail        => [userId, userId],
+        });
+
+ plan tests => $maker->plan;
+
+ $maker->run;
+
+=head1 DESCRIPTION
+
+Test generator for testing WebGUI permissions. WebGUI permissions subroutines
+take a single argument (a userId), or they use the default user from the
+current session. They return true if the user has permission, or false 
+otherwise.
+
+This module tests permissions subroutines by running a list of userIds that
+should either pass or fail the permissions. 
+
+=head1 DEPENDS
+
+This module depends on
+
+=over 4
+
+=item * 
+
+Test::More
+
+=back
+
+=head1 METHODS
+
+=head2 new
+
+Create a new WebGUI::Test::Maker::Permission object.
+
+=cut
+
+=head2 get
+
+Get a setting. See C<set> for a list of settings.
+
+=cut
+
+#----------------------------------------------------------------------------
+
+=head2 plan
+
+Returns the number of tests currently prepared. This module runs two tests 
+for each userId in either the C<pass> or C<fail> keys of the C<prepare()>
+hash reference.
+
+=cut
+
+sub plan {
+    my $self        = shift;
+    my $plan;
+    
+    for my $test ( @{$self->{_tests}} ) {
+        if ($test->{pass}) {
+            $plan += @{$test->{pass}} * 2;
+        }
+        if ($test->{fail}) {
+            $plan += @{$test->{fail}} * 2;
+        }
+    }
+
+    return $plan;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 plan_per_test
+
+Returns undef. There is no way to pre-calculate how many tests this will run
+
+=cut
+
+sub plan_per_test {
+    return undef;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 prepare
+
+Prepare a test(s). Returns the object for convenience. The following keys 
+are required:
+
+=over 4
+
+=item object
+
+An instanciated object to work on.
+
+=item className
+
+The class name of a module to work on.  This would be useful for class methods.
+
+=item method
+
+The permissions method to test
+
+=item pass
+
+An array reference of userIds or WebGUI::User objects that should pass the 
+permissions test.  If each user has a username, it will be used in the
+test comment output instead of the userId.
+
+=item fail
+
+An array reference of userIds or WebGUI::User objects that should fail the 
+permissions test.  If each user has a username, it will be used in the
+test comment output instead of the userId.
+
+
+=back
+
+There are no optional parameters.
+
+=cut
+
+sub prepare {
+    my $self        = shift;
+    my @tests       = @_;
+    my $test_num    = 0;
+    for my $test (@tests) {
+        $test_num++;
+
+        croak("Couldn't prepare: Test $test_num has no object or className")
+            unless $test->{object} || exists($test->{className});
+        croak("Couldn't prepare: Test $test_num has needs a session object")
+            if exists($test->{className}) && !$test->{session};
+        croak("Couldn't prepare: Test $test_num has no method")
+            unless $test->{method};
+        croak("Couldn't prepare: Test $test_num has no pass/fail")
+            unless $test->{pass} || $test->{fail};
+        croak("Couldn't prepare: Test $test_num, pass is not an array reference")
+            if $test->{pass} && ref $test->{pass} ne "ARRAY";
+        croak("Couldn't prepare: Test $test_num, fail is not an array reference")
+            if $test->{fail} && ref $test->{fail} ne "ARRAY";
+
+        # Make sure pass and fail arrayrefs are userIds
+        for my $array ( $test->{'pass'}, $test->{'fail'} ) {
+            for ( my $i = 0; $i < @{ $array }; $i++ ) {
+                # If is a User object, replace with userId
+                if ( blessed $array->[$i] && $array->[$i]->isa("WebGUI::User") ) {
+                    $array->[$i] = $array->[$i]->userId;
+                }
+            }
+        }
+
+        push @{$self->{_tests}}, $test;
+    }
+
+    return $self;
+}
+
+#----------------------------------------------------------------------------
+
+=head2 run
+
+Run the tests we've prepared and delete them as we run them.
+
+=cut
+
+sub run {
+    my $self        = shift;
+
+    while (my $test = shift @{ $self->{_tests} }) {
+        my $session;
+        my @methodArguments = ();
+        my ($o, $m, $comment);
+
+        if (exists $test->{className}) {
+            $o = $test->{className};
+            $m = $test->{method};
+            $session = $test->{session};
+            push @methodArguments, $session;
+            $comment = $test->{className};
+        }
+        else {
+            $o = $test->{object};
+            $m = $test->{method};
+            $session = $o->session;
+            $comment = blessed $o;
+        }
+
+        ##This needs to be refactored into a sub/method, instead of copy/paste
+        ##duplicated in fail, below.
+        if ($test->{pass}) {
+            runUsers($session, $o, $m, \@methodArguments, $test->{pass}, 1, $comment);
+        }
+        if ($test->{fail}) {
+            runUsers($session, $o, $m, \@methodArguments, $test->{fail}, 0, $comment);
+        }
+    }
+}
+
+#----------------------------------------------------------------------------
+
+=head2 set
+
+Set a setting.
+
+Currently this module has no settings
+
+=cut
+
+#----------------------------------------------------------------------------
+
+=head2 runUsers
+
+Process an array of users for tests.
+
+=head3 session
+
+A WebGUI session object, used to access and/or alter the default session
+user for the tests.
+
+=head3 object
+
+A WebGUI object or class, used for testing.
+
+=head3 method
+
+The method on the object or class to call for each test.
+
+=head3 precedingArguments
+
+Any arguments that should be pushed onto the argument list before a userId.
+
+=head3 users
+
+An array ref of users.
+
+=head3 passing
+
+A boolean, which if true, says that the users are expected to pass each test.
+If false, the users will be expected to fail, which means that if they do
+fail that the test itself will pass.
+
+=head3 comment
+
+A specific comment to add to the test's comment.  Usually this would
+be something like the username or userId.
+
+=cut
+
+sub runUsers {
+    my ($session, $object,  $method, $precedingArguments,
+        $users,   $passing, $comment ) = @_;
+    my $failing = !$passing;
+    my $tb = $CLASS->builder;
+    # This is to fix detection of SKIP and TODO
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+    foreach my $userId (@{ $users }) {
+        my @args = @{ $precedingArguments };
+        my $oldUser = $session->user;
+        $session->user( { userId => $userId  } );
+        my $role = $session->user->username
+                 ? "user ".$session->user->username
+                 : "userId ".$userId;
+        $tb->ok(
+            ( $object->$method(@args) xor $failing ),
+            "$role passes $method check using default user for " . $comment
+        );
+        $session->user( { user   => $oldUser } );
+
+        # Test the specified userId
+        push @args, $userId;
+        # Test the userId parameter
+        $tb->ok(
+            ( $object->$method(@args) xor $failing ),
+            "$role passes $method check for " . $comment
+        );
+    }
+}
+
+1;

t/lib/WebGUI/Test/Metadata.pm

@@ -0,0 +1,119 @@
+package WebGUI::Test::Metadata;
+
+use warnings;
+use strict;
+
+=head1 NAME
+
+WebGUI::Test::Metadata
+
+=head1 SYNOPSIS
+
+    use WebGUI::Test::Metadata;
+
+    my $meta = WebGUI::Test::Metadata->new( $asset, fieldName => 'Foobar' );
+    my $type = $meta->fieldType;
+    undef $meta; # or just let it go out of scope, whatever suits you
+
+=head1 METHODS
+
+=cut
+
+#----------------------------------------------------------------------------
+
+=head1 DESTROY
+
+When this object goes out of scope, the metadata field will be cleaned up.
+
+=cut
+
+sub DESTROY {
+    my $self = shift;
+    $self->{asset}->deleteMetaDataField($self->fieldId)
+}
+
+#----------------------------------------------------------------------------
+
+=head1 get ([ $asset ])
+
+Gets the value of this metadata field for the asset you passed in (or the one
+you passed to new).
+
+=cut
+
+sub get {
+    my ($self, $asset) = @_;
+    $asset ||= $self->{asset};
+    return $asset->getMetaDataFields($self->fieldId)->{value};
+}
+#----------------------------------------------------------------------------
+
+=head1 new ($asset, %args)
+
+Needs some kind of asset (any old asset will do), and if you want to override
+any of the arguments to addMetaDataField, name them in the args hash.
+
+=cut
+
+sub new {
+    my $class = shift;
+    my $asset = shift;
+    my $args  = @_ == 1 ? $_[0] : { @_ };
+    my $id = $asset->addMetaDataField(
+        $args->{fieldId},
+        $args->{fieldName},
+        $args->{defaultValue}   || '',
+        $args->{description}    || '',
+        $args->{fieldType}      || 'text',
+        $args->{possibleValues} || '',
+        $args->{classes},
+    );
+
+    bless {
+        asset => $asset,
+        info  => $asset->getMetaDataFields($id),
+    }, $class;
+}
+
+#----------------------------------------------------------------------------
+
+=head1 update ($value, [ $asset ])
+
+Sets the value of this metadata field for the asset you passed in (or the one
+you passed to new).
+
+=cut
+
+sub update {
+    my ($self, $value, $asset) = @_;
+    $asset ||= $self->{asset};
+    $asset->updateMetaData($self->fieldId => $value);
+}
+
+=head1 OTHER METHDOS
+
+fieldId, fieldName, description, defaultvalue, fieldType and possibleValues
+are all available as methods. They'll get you what getMetaDataFields would
+return you.
+
+=cut
+
+BEGIN {
+    for my $key (
+        qw(
+            fieldId
+            fieldName
+            description
+            defaultValue
+            fieldType
+            possibleValues
+        )
+    )
+    {
+        my $accessor = sub { $_[0]->{info}->{$key} };
+        no strict 'refs';
+        *{__PACKAGE__ . "::$key"} = $accessor;
+    }
+}
+
+1;

t/lib/WebGUI/TestException.pm

@@ -0,0 +1,124 @@
+package WebGUI::TestException;
+
+use strict;
+
+use Test::Builder;
+use WebGUI::Exception;
+use Sub::Uplevel qw( uplevel );
+use Exporter qw(import);
+
+our @EXPORT = qw( throws_deeply );
+
+=head1 NAME
+
+Package WebGUI::TestException
+
+=head1 DESCRIPTION
+
+This module provides a convenient way to test for thrown exceptions. The idea is based on Test::Exception, which
+does provide a means to test for a specific exception class, but cannot test attributes of that class, which is
+necessary in the WebGUI test suite. This module can do that.
+
+=head1 CAVEATS
+
+This module uses Sub::Uplevel. In Test::Exception some hocus pocus is being done with the caller() function. The
+functions _quiet_caller and _try_as_caller are directly copied from Test::Exception. I do not know why this
+hocuspocus is being in that module however, since doing 'eval { uplevel 1, $codeRef }' seems to work too. On my
+platform at least =). For the time being, I leave those subs in here so that they may be used. They are commented
+out by default, though.
+=cut
+
+#----------------------------------------------------------------------------
+sub _quiet_caller (;$) { ## no critic Prototypes
+    my $height = $_[0];
+    $height++;
+    if( wantarray and !@_ ) {
+        return (CORE::caller($height))[0..2];
+    }
+    else {
+        return CORE::caller($height);
+    }
+}
+
+#----------------------------------------------------------------------------
+sub _try_as_caller {
+    my $coderef = shift;
+
+    # local works here because Sub::Uplevel has already overridden caller
+    local *CORE::GLOBAL::caller;
+    { no warnings 'redefine'; *CORE::GLOBAL::caller = \&_quiet_caller; }
+
+    eval { uplevel 3, $coderef };
+    return $@;
+};
+
+=head2 throws_deeply ( $codeRef, $expectClass, $fields, $message )
+
+Executes the code ref and verifies it throws an exception of the given class with the given fields.
+
+=head3 $codeRef
+
+The code ref containing the code to be evalled.
+
+=head3 $expectClass
+
+The class name the thrown exception should have.
+
+=head3 $fields
+
+Hashref containg the exception fields and their expected values.
+
+=head3 $message
+
+The message that should be displayed by prove for this test.
+
+=cut
+
+#----------------------------------------------------------------------------
+sub throws_deeply {
+    my $evalBlock   = shift;
+    my $expectClass = shift;
+    my $fields      = shift;
+    my $message     = shift;
+    my $testBuilder = Test::Builder->new;
+
+    # Dunno why uplevel 1 might not work and why caller is redefined. 
+    # Copied _try_as_caller and _quiet_caller are from Test::Exception.
+    # Uplevel 1 seems to work though.
+    #_try_as_caller( $evalBlock );
+    eval { uplevel 1, $evalBlock };
+    
+    my $e = Exception::Class->caught();
+    my $gotClass = ref $e;
+
+    # Check class
+    unless ($gotClass eq $expectClass) {
+        $testBuilder->ok(0, $message);
+        $testBuilder->diag("Wrong class:\n\texpected : '$expectClass'\n\t     got : '$gotClass'");
+
+        return 0;
+    }
+
+    # Check fields
+    my $errors;
+    foreach (keys %$fields) {
+        my $result = $e->$_;
+
+        unless ( $result eq $fields->{$_} ) {
+            $errors .= "'$_' => \n\texpected : '".$fields->{$_}."'\n\t     got : '$result'\n";
+        }
+    }
+    if ($errors) {
+        $testBuilder->ok(0, $message);
+        $testBuilder->diag("Fields do not match:\n$errors");
+
+        return 0;
+    }
+
+    # Test passed.
+    $testBuilder->ok(1, $message);
+    return 1;
+}
+
+1;
+