[Rt-commit] [svn] r1500 - in experiments/Bamboo: . lib/Bamboo
lib/Bamboo/Controller lib/Bamboo/Model
lib/Bamboo/Model/ProxyObject/RT t tools
jesse at pallas.eruditorum.org
jesse at pallas.eruditorum.org
Fri Sep 17 00:40:57 EDT 2004
Author: jesse
Date: Fri Sep 17 00:40:55 2004
New Revision: 1500
Added:
experiments/Bamboo/Makefile.PL
experiments/Bamboo/tools/
experiments/Bamboo/tools/extract_pod_tests (contents, props changed)
experiments/Bamboo/tools/testifypods (contents, props changed)
Removed:
experiments/Bamboo/Build.PL
Modified:
experiments/Bamboo/ (props changed)
experiments/Bamboo/META.yml
experiments/Bamboo/lib/Bamboo/Base.pm
experiments/Bamboo/lib/Bamboo/Controller.pm
experiments/Bamboo/lib/Bamboo/Controller/Object.pm
experiments/Bamboo/lib/Bamboo/Model/ProxyObject.pm
experiments/Bamboo/lib/Bamboo/Model/ProxyObject/RT/Ticket.pm
experiments/Bamboo/t/1basicparse.t
Log:
r10282 at tinbook: jesse | 2004-09-17T04:19:31.545246Z
Now we fail tests!
Modified: experiments/Bamboo/META.yml
==============================================================================
--- experiments/Bamboo/META.yml (original)
+++ experiments/Bamboo/META.yml Fri Sep 17 00:40:55 2004
@@ -12,4 +12,4 @@
no_index:
directory:
- inc
-generated_by: Module::Install version 0.33
+generated_by: Module::Install version 0.35
Added: experiments/Bamboo/Makefile.PL
==============================================================================
--- (empty file)
+++ experiments/Bamboo/Makefile.PL Fri Sep 17 00:40:55 2004
@@ -0,0 +1,37 @@
+ use inc::Module::Install;
+
+ name ('Bamboo');
+ abstract ('An MVC framework');
+ author ('Jesse Vincent <jesse at bestpractical.com>');
+ version_from ('lib/Bamboo.pm');
+ license ('perl');
+
+ requires ('perl' => 5.005);
+ build_requires ('Test::More');
+ build_requires ('Test::Inline');
+
+# auto_bundle(); # optional: bundle run-time dependencies
+# auto_include(); # optional: include build-time dependencies
+# auto_install(); # optional: auto-install all dependencies from
+
+
+ {
+ package MY;
+ sub top_targets {
+ my($self) = @_;
+ my $out = "POD2TEST_EXE = pod2test\n";
+
+ $out .= $self->SUPER::top_targets(@_);
+ $out =~ s/^(pure_all\b.*)/$1 testifypods/m;
+
+ $out .= "\n\ntestifypods : \n";
+ $out .= "\ttools/testifypods\n";
+
+ return $out;
+ }
+ }
+
+
+
+ &WriteAll;
+
Modified: experiments/Bamboo/lib/Bamboo/Base.pm
==============================================================================
--- experiments/Bamboo/lib/Bamboo/Base.pm (original)
+++ experiments/Bamboo/lib/Bamboo/Base.pm Fri Sep 17 00:40:55 2004
@@ -2,5 +2,15 @@
use strict;
use warnings;
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ bless( $self, $class );
+
+ $self->_Init(@_);
+ return $self;
+}
+
1;
Modified: experiments/Bamboo/lib/Bamboo/Controller.pm
==============================================================================
--- experiments/Bamboo/lib/Bamboo/Controller.pm (original)
+++ experiments/Bamboo/lib/Bamboo/Controller.pm Fri Sep 17 00:40:55 2004
@@ -7,12 +7,8 @@
use base qw/Bamboo::Base/;
use CGI;
-sub new {
- my $proto = shift;
- my $class = ref($proto) || $proto;
- my $self = {};
- bless( $self, $class );
-
+sub _Init {
+ my $self = shift;
$self->{obj_cache} = Bamboo::Controller::ObjectCollection->new();
return $self;
}
Modified: experiments/Bamboo/lib/Bamboo/Controller/Object.pm
==============================================================================
--- experiments/Bamboo/lib/Bamboo/Controller/Object.pm (original)
+++ experiments/Bamboo/lib/Bamboo/Controller/Object.pm Fri Sep 17 00:40:55 2004
@@ -61,7 +61,20 @@
sub validate_method {
- warn "Everything is valid";
return 1;
}
+
+
+sub type {
+ my $self = shift;
+ return($self->{'type'});
+}
+
+
+sub moniker {
+ my $self = shift;
+ return($self->{'moniker'});
+}
+
+
1;
Modified: experiments/Bamboo/lib/Bamboo/Model/ProxyObject.pm
==============================================================================
--- experiments/Bamboo/lib/Bamboo/Model/ProxyObject.pm (original)
+++ experiments/Bamboo/lib/Bamboo/Model/ProxyObject.pm Fri Sep 17 00:40:55 2004
@@ -1,16 +1,13 @@
use strict;
-package RT::Web::ProxyObject;
+
+package Bamboo::Model::ProxyObject;
use Params::Validate qw(:all);
+use base qw/Bamboo::Base/;
+our %_NOTES;
use vars qw($_RENDER $_METHODS $_ERRORS );
-=head2 new
-
-=item Type
-=item CurrentUser
-=item id
-
=begin testing
@@ -20,83 +17,109 @@
RT::LoadConfig;
RT::Init();
-use_ok(RT::Web::ProxyObject);
-my $blank = RT::Web::ProxyObject->new();
-ok(!$blank,$blank);
+use_ok(Bamboo::Model::ProxyObject);
+my $blank = Bamboo::Model::ProxyObject->new();
+ok( !$blank, $blank );
use_ok(RT::Queue);
use_ok(RT::CurrentUser);
-my $rtuser = 'RT::Queue';
-my $foo = RT::Web::ProxyObject->new(
- Type => $rtuser,
- id => '1'
+my $rtqueue = 'RT::Queue';
+my $foo = Bamboo::Model::ProxyObject->new(
+ Type => $rtqueue,
+ id => '1'
);
-ok(!$foo,$foo);
- $foo = RT::Web::ProxyObject->new(
+
+
+is($foo, undef, $foo );
+$foo = Bamboo::Model::ProxyObject->new(
CurrentUser => RT::CurrentUser->new('root'),
id => '1'
);
-ok(!$foo,$foo);
- $foo = RT::Web::ProxyObject->new(
- Type => $rtuser,
+is($foo, undef, $foo );
+
+
+$foo = Bamboo::Model::ProxyObject->new(
+ Type => $rtqueue,
CurrentUser => RT::CurrentUser->new('root'),
);
-ok(!$foo,$foo);
- $foo = RT::Web::ProxyObject->new(
- Type => $rtuser,
+is($foo, undef, $foo );
+
+$foo = Bamboo::Model::ProxyObject->new(
+ Type => $rtqueue,
CurrentUser => RT::CurrentUser->new('root'),
id => '1'
);
-ok($foo, "Type is $rtuser, Currentuser is root and id is 1 - '$foo'");
-is(ref($foo), 'RT::Web::ProxyObject::RT::Queue');
+ok( $foo, "Type is $rtqueue, Currentuser is root and id is 1 - '$foo'" );
+is( ref($foo), 'Bamboo::Model::ProxyObject::RT::Queue' );
=end testing
+
+=cut
+
+
+=head2 new PARAMHASH
+
+Create a new proxy object for some object type that Bamboo knows about.
+
+=over
+
+=item Type
+
+The type of the _original_ object, not the Bamboo:: proxy for it.
+
+=item CurrentUser
+
+=item id
+
+The id of the original object.
+
+=back
+
=cut
sub new {
- my $proto = shift;
- my $self = {};
my %args;
-
+ my $self = {};
eval {
- %args = validate( @_, {
- Type => { type => SCALAR },
- CurrentUser => {isa => 'RT::CurrentUser'},
- id => { regex => qr/^\d+$/ }
- });
+ %args = validate(
+ @_,
+ {
+ Type => { type => SCALAR },
+ CurrentUser => { isa => 'RT::CurrentUser' },
+ id => { regex => qr/^\d+$/ }
+ }
+ );
};
if ($@) {
- $RT::Logger->debug($@);
- return ($@);
+ #RecordNote(undef, Message => $@);
+ return (undef);
}
- my $object_type = "RT::Web::ProxyObject::".$args{'Type'};
- warn "OBject type is $object_type";
- eval "require $object_type";
- if ($@){
- warn $@;
- $RT::Logger->debug($@);
+ warn "XXX: We need to validate against a typemap of safe objects";
+ my $object_type = "Bamboo::Model::ProxyObject::" . $args{'Type'};
+ print "OBject type is $object_type";
+ eval "require $object_type";
+ if ($@) {
+ return("-1");
}
- bless ($self, $object_type);
+ bless( $self, $object_type );
- return($self);
+ return ($self);
}
-
sub ProxyForObject {
my $self = shift;
- if ($_[0]) {
- my $object = shift;
+ if ( $_[0] ) {
+ my $object = shift;
- $self->{_Object} = $object;
+ $self->{_Object} = $object;
}
- return ($self->{_Object});
+ return ( $self->{_Object} );
}
-
sub HasMethod { # should this be called 'can'
my $self = shift;
my $method = shift;
@@ -119,7 +142,6 @@
=cut
-
sub MethodParameters {
my $self = shift;
my $method = shift;
@@ -165,7 +187,6 @@
return ($renderer);
}
-
=head2 ValidateMethodCall { Method => SCALAR, Parameters => HASHREF }
@@ -178,8 +199,6 @@
=cut
-
-
sub ValidateMethodCall {
my $self = shift;
my %args = (
@@ -189,24 +208,27 @@
);
# make sure it's an ok method
- return undef unless ($self->HasMethod($args{'Method'}));
+ return undef unless ( $self->HasMethod( $args{'Method'} ) );
-
# canonicalize each parameter
- $self->CanonicalizeMethodParameters(Parameters => $args{'Parameters'}, Method => $args{'Method'});
-
+ $self->CanonicalizeMethodParameters(
+ Parameters => $args{'Parameters'},
+ Method => $args{'Method'}
+ );
+
# make sure only known parameters are listed
-
- $self->PruneMethodParameters(Parameters => $args{'Parameters'}, Method => $args{'Method'});
-
+
+ $self->PruneMethodParameters(
+ Parameters => $args{'Parameters'},
+ Method => $args{'Method'}
+ );
+
# make sure that each of the parameters is valid
#XX Call the validate sub
-
}
-
sub PruneMethodParameters {
my $self = shift;
my %args = (
@@ -215,10 +237,8 @@
@_
);
-
}
-
sub CanonicalizeMethodParameters {
my $self = shift;
my %args = (
@@ -227,19 +247,41 @@
@_
);
- foreach my $param (keys %{$args{'Parameters'}}) {
- unless ($self->MethodHasParameter(Method => $args{'Method'}, Parameter => $param )) {
+ foreach my $param ( keys %{ $args{'Parameters'} } ) {
+ unless (
+ $self->MethodHasParameter(
+ Method => $args{'Method'},
+ Parameter => $param
+ )
+ )
+ {
+ $self->RecordNote( Object => $self,
+ Method => $args{'Method'},
+ Parameter => $param,
+ Message => 'No such parameter');
delete $args{'Parameters'}->{$param};
}
}
-
}
+sub RecordNote {
+ my $self = shift;
+ my %args = ( Object => 'No object',
+ Method => 'unknown',
+ Parameter => undef,
+ Severity => undef,
+ Value => undef,
+ Message => undef,
+ @_
+ );
+
+ push @{$_NOTES{$args{'Object'}}{$args{'Method'}}}, \%args;
+}
- 1;
+1;
Modified: experiments/Bamboo/lib/Bamboo/Model/ProxyObject/RT/Ticket.pm
==============================================================================
--- experiments/Bamboo/lib/Bamboo/Model/ProxyObject/RT/Ticket.pm (original)
+++ experiments/Bamboo/lib/Bamboo/Model/ProxyObject/RT/Ticket.pm Fri Sep 17 00:40:55 2004
@@ -1,7 +1,7 @@
use strict;
-package RT::Interface::Web::ObjectType::RT::Ticket;
-use base qw/RT::Interface::Web::ObjectType/;
+package Bamboo::Model::ProxyObject::RT::Ticket;
+use base qw/Bamboo::Model::ProxyObject/;
Modified: experiments/Bamboo/t/1basicparse.t
==============================================================================
Added: experiments/Bamboo/tools/extract_pod_tests
==============================================================================
--- (empty file)
+++ experiments/Bamboo/tools/extract_pod_tests Fri Sep 17 00:40:55 2004
@@ -0,0 +1,151 @@
+#!/usr/bin/perl
+# {{{ BEGIN BPS TAGGED BLOCK
+#
+# COPYRIGHT:
+#
+# This software is Copyright (c) 1996-2004 Best Practical Solutions, LLC
+# <jesse at bestpractical.com>
+#
+# (Except where explicitly superseded by other copyright notices)
+#
+#
+# LICENSE:
+#
+# This work is made available to you under the terms of Version 2 of
+# the GNU General Public License. A copy of that license should have
+# been provided with this software, but in any event can be snarfed
+# from www.gnu.org.
+#
+# This work is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# CONTRIBUTION SUBMISSION POLICY:
+#
+# (The following paragraph is not intended to limit the rights granted
+# to you to modify and distribute this software under the terms of
+# the GNU General Public License and is only of importance to you if
+# you choose to contribute your changes and enhancements to the
+# community by submitting them to Best Practical Solutions, LLC.)
+#
+# By intentionally submitting any modifications, corrections or
+# derivatives to this work, or any other work intended for use with
+# Request Tracker, to Best Practical Solutions, LLC, you confirm that
+# you are the copyright holder for those contributions and you grant
+# Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable,
+# royalty-free, perpetual, license to use, copy, create derivative
+# works based on those contributions, and sublicense and distribute
+# those contributions and any derivatives thereof.
+#
+# }}} END BPS TAGGED BLOCK
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.06';
+
+use Pod::Tests;
+use Symbol;
+
+=pod
+
+=head1 NAME
+
+extract_pod_tests - RT-specific variant of pod2tests
+
+=head1 SYNOPSIS
+
+ pod2test [-Mmodule] [input [output]]
+
+=head1 DESCRIPTION
+
+B<pod2test> is a front-end for Test::Inline. It generates the
+"Bodies" of MakeMaker style .t testing files from embedded tests and
+code examples.
+
+If output is not specified, the resulting .t file will go to STDOUT.
+Otherwise, it will go to the given output file. If input is not
+given, it will draw from STDIN.
+
+If the given file contains no tests or code examples, no output will
+be given and no output file will be created.
+
+=cut
+
+my($infile, $outfile) = @ARGV;
+my($infh,$outfh);
+
+
+if( defined $infile ) {
+ $infh = gensym;
+ open($infh, $infile) or
+ die "Can't open the POD file $infile: $!";
+}
+else {
+ $infh = \*STDIN;
+}
+
+unless ($outfile) {
+ ( my $test = $infile ) =~ s/\.(pm|pod)$//;
+ $test =~ s/^lib\W//;
+ $test =~ s/\W/-/;
+ $test =~ s/\//__/g;
+
+ $outfile = "t/autogen-$test.t";
+}
+
+
+my $p = Pod::Tests->new;
+$p->parse_fh($infh);
+
+# XXX Hack to put the filename into the #line directive
+$p->{file} = $infile || '';
+
+my @tests = $p->build_tests($p->tests);
+my @examples = $p->build_examples($p->examples);
+
+exit unless @tests or @examples;
+
+
+if( defined $outfile) {
+ $outfh = gensym;
+ open($outfh, ">$outfile") or
+ die "Can't open the test file $outfile: $!";
+}
+else {
+ $outfh = \*STDOUT;
+}
+
+print $outfh "# Autogenerated! Warning\n";
+print $outfh "use Test::More qw/no_plan/;\n";
+
+foreach my $test (@tests, @examples) {
+ print $outfh "$test\n";
+}
+
+print $outfh "1;\n";
+
+=pod
+
+=head1 BUGS and CAVEATS
+
+This is a very simple rough cut. It only does very rudimentary tests
+on the examples.
+
+=head1 AUTHOR
+
+
+
+Based on pod2tests by Michael G Schwern <schwern at pobox.com>
+
+=head1 SEE ALSO
+
+L<Test::Inline>
+
+=cut
+
+1;
Added: experiments/Bamboo/tools/testifypods
==============================================================================
--- (empty file)
+++ experiments/Bamboo/tools/testifypods Fri Sep 17 00:40:55 2004
@@ -0,0 +1,2 @@
+#!/bin/sh
+find lib -type f -name \*.pm -exec tools/extract_pod_tests {} \;
More information about the Rt-commit
mailing list