Menu
▾
▴
[Everydevel-opers] SF.net SVN: everydevel: [960] trunk/ebase
|
From: <pau...@us...> - 2007-05-22 23:14:11
|
Revision: 960
http://svn.sourceforge.net/everydevel/?rev=960&view=rev
Author: paul_the_nomad
Date: 2007-05-22 16:14:00 -0700 (Tue, 22 May 2007)
Log Message:
-----------
New method-based flexible parsing system for parseable and runnable nodes.
Modified Paths:
--------------
trunk/ebase/lib/Everything/Node/Test/htmlpage.pm
trunk/ebase/lib/Everything/Node/container.pm
trunk/ebase/lib/Everything/Node/htmlcode.pm
trunk/ebase/lib/Everything/Node/htmlpage.pm
trunk/ebase/lib/Everything/Node/htmlsnippet.pm
trunk/ebase/lib/Everything/Node/nodegroup.pm
trunk/ebase/lib/Everything/Node/nodelet.pm
trunk/ebase/lib/Everything/Node/superdoc.pm
Added Paths:
-----------
trunk/ebase/lib/Everything/Node/Parseable.pm
trunk/ebase/lib/Everything/Node/Runnable.pm
trunk/ebase/lib/Everything/Node/Test/Parseable.pm
trunk/ebase/lib/Everything/Node/Test/Runnable.pm
trunk/ebase/t/Node/parseable.t
trunk/ebase/t/Node/runnable.t
Property Changed:
----------------
trunk/ebase/
Property changes on: trunk/ebase
___________________________________________________________________
Name: svk:merge
- 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:992
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
+ 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:994
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
Added: trunk/ebase/lib/Everything/Node/Parseable.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Parseable.pm (rev 0)
+++ trunk/ebase/lib/Everything/Node/Parseable.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -0,0 +1,255 @@
+package Everything::Node::Parseable;
+
+use SUPER;
+use base 'Everything::Node::Runnable';
+use strict;
+use warnings;
+
+
+=head1 <tokens_to_perl>
+
+This is a function.
+
+It takes two arguments: an array ref of tokens and a call back. Turns each token into executable perl in accordance with the dispatch table returned by the method 'get_handlers'.
+
+Returns an array ref.
+
+=cut
+
+sub tokens_to_perl {
+ my ( $tokens, $error_cb ) = @_;
+
+ my $dispatch_table = get_handlers();
+
+ my @encoded = ();
+ foreach (@$tokens) {
+ my ( $token, $text ) = @$_;
+ my $encoded = $dispatch_table->{$token}->($text);
+
+ if ( $error_cb && $token ne 'TEXT' ) {
+ $encoded .= $error_cb->() || '';
+ }
+
+ push @encoded, [ $token => $encoded ];
+ }
+
+ return \@encoded;
+
+}
+
+
+=head1 C<compile>
+
+Overrides the super class compile.
+
+Takes one argument which is the text to be compiled and sends it to
+the parser before being compiled.
+
+=cut
+
+sub compile {
+ my ( $self, $text ) = @_;
+
+ my $code = $self->parse($text);
+ return $self->SUPER($code);
+}
+
+sub basic_handler {
+ my ($specific_cb) = @_;
+
+ return sub {
+ my ($text) = @_;
+ $text =~ s!"!\"!g;
+ $text = $specific_cb->($text);
+ my $wrapped = " eval {$text} || '';\n";
+ return $wrapped;
+ };
+
+}
+
+## class variable
+my %handlers;
+
+sub set_default_handlers {
+ %handlers = (
+ HTMLCODE => basic_handler(
+ sub {
+ my ( $func, $args ) = split( /\s*:\s*/, $_[0] );
+
+ my $rv = " $func(";
+ if ( defined $args ) {
+ my @args = do_args($args);
+ $rv .= join( ", ", @args ) if (@args);
+ }
+ $rv .= ") ";
+ return $rv;
+ }
+ ),
+ TEXT => sub {
+ my $text = shift;
+ $text =~ s!\'!\\'!g;
+ return " '$text';";
+ },
+ HTMLSNIPPET =>
+ basic_handler( sub { "htmlsnippet('$_[0]')" } ),
+ PERL => basic_handler( sub { " \n$_[0]\n" } ),
+ );
+}
+
+BEGIN { set_default_handlers() }
+
+sub get_handlers {
+ \%handlers;
+}
+
+sub delete_handlers {
+ %handlers = ();
+
+}
+
+sub set_handler {
+ my ( $self, $text_type, $code ) = @_;
+ $handlers{$text_type} = $code;
+}
+
+=head1 C<tokenise>
+
+This is a function.
+
+It takes one argument of text and splits it into 'tokens'.
+
+Text wrapped in [{ }] is labelled 'HTMLCODE'.
+
+Text wrapped in [% %] or [" "] is labelled 'PERL'
+
+Text wrapped in [< >] is labelled 'HTMLSNIPPET'.
+
+Everything else is labelled 'TEXT'.
+
+Returns an array ref of array refs. These latter have two elements 'LABEL' and 'text'
+
+=cut
+
+sub tokenise {
+ my ($text) = @_;
+
+ my @tokens;
+
+ for my $chunk ( split( /(\[(?:\{.*?\}|\".*?\"|%.*?%|<.*?>)\])/s, $text ) ) {
+ next unless $chunk =~ /\S/;
+
+ my ( $start, $code, $end );
+ if ( ( $start, $code, $end ) =
+ $chunk =~ /^\[([%"<{])(.+?)([%">}])\]$/s )
+ {
+
+ if ( $start eq '{' ) {
+ push @tokens, [ 'HTMLCODE', $code ];
+ }
+ elsif ( $start eq '<' ) {
+ push @tokens, [ 'HTMLSNIPPET', $code ];
+ }
+ elsif ( $start eq '"' or $start eq '%' ) {
+ push @tokens, [ 'PERL', $code ];
+ }
+ }
+ else {
+
+ next unless ( $chunk =~ /\S/ );
+ push @tokens, [ 'TEXT', $chunk ];
+ }
+ }
+ return \@tokens;
+}
+
+
+sub add_error_text {
+ my ($CURRENTNODE) = @_;
+
+ my $error_text = qq|\nEverything::logErrors('', \$\@, '', { title =>
+ '\Q$$CURRENTNODE{title}\E', node_id => '$$CURRENTNODE{node_id}' })
+ if (\$\@);\n|;
+ return $error_text;
+}
+
+=head1 C<parse>
+
+This looks for code wrapped in:
+
+=over 4
+
+=item C<[{ }]>
+
+In which case the enclosed is the name of an htmlcode node which must be retrieved form the db and executed.
+
+
+=item C<[< >]>
+
+In which case the enclosed is the name of an htmlsnippet which must be retrieved from the db.
+
+=item C<[% %]>
+
+In which case the enclosed is perl
+
+=item C<[" "]>
+
+Once again, the enclosed is perl
+
+=back
+
+Everything else is text or html.
+
+
+
+=cut
+
+sub parse {
+ my $self = shift;
+ my $data = shift;
+ my $tokens = tokenise($data);
+ my $encoded_tokens =
+ tokens_to_perl( $tokens, sub { add_error_text($self) } );
+
+ my $text = 'my $result;' . "\n\n";
+
+ $text .= join '', map { '$result .= ' . $_->[1] . "\n\n" }
+ grep /\S/, @$encoded_tokens;
+
+ $text .= 'return $result;';
+ return $text;
+
+}
+
+=head2 C<do_args>
+
+This is a supporting function for compileCache(). It turns a comma-delimited
+list of arguments into an array, performing variable interpolation on them.
+It's probably not necessary once things move over to the new AUTOLOAD htmlcode
+scheme.
+
+=over 4
+
+=item * $args
+
+a comma-delimited list of arguments
+
+=back
+
+Returns an array of manipulated arguments.
+
+=cut
+
+sub do_args {
+ my $args = shift;
+ $args =~ s/\s+$//;
+ my @args = split( /\s*,\s*/, $args ) or ();
+ foreach my $arg (@args) {
+ unless ( $arg =~ /^\$/ ) {
+ $arg = "'" . $arg . "'";
+ }
+ }
+
+ return @args;
+}
+
+1;
Property changes on: trunk/ebase/lib/Everything/Node/Parseable.pm
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
Added: trunk/ebase/lib/Everything/Node/Runnable.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Runnable.pm (rev 0)
+++ trunk/ebase/lib/Everything/Node/Runnable.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -0,0 +1,143 @@
+package Everything::Node::Runnable;
+
+use Everything ();
+use Everything::HTML;
+
+use base 'Class::Accessor';
+__PACKAGE__->follow_best_practice;
+
+use strict;
+use warnings;
+
+
+
+sub run {
+ my ( $self, $field, $no_cache, @args) = @_;
+
+ $field ||= $self->get_compilable_field;
+
+ if ( $no_cache ) {
+
+ my $code = $self->compile( $self->{$field} );
+ return $self->eval_code( $code, $field, \@args );
+ }
+
+ my $ret = $self->execute_cached_code( $field, \@args );
+ return $ret if $ret;
+ my $code = $self->compile( $self->{ $field } );
+ die "Cache failed" unless $self->cache_code( $field, $code );
+ return $self->execute_cached_code( $field, \@args );
+
+}
+
+
+sub cache_code {
+ my ($self, $field, $code_ref) = @_;
+ $field ||= $self->get_compilable_field;
+
+ return 1 if $self->{DB}->{cache}->cacheMethod($self, $field, $code_ref);
+
+
+}
+
+sub execute_cached_code {
+ my ($self, $field, $args) = @_;
+
+ $field ||= $self->get_compilable_field;
+
+ $args ||= [];
+
+ my $code_ref;
+
+ if ($code_ref = $self->{"_cached_$field"}) {
+
+ if (ref($code_ref) eq 'CODE' and defined &$code_ref) {
+
+
+ return $self->eval_code($code_ref, $field, $args);
+ }
+ }
+}
+
+
+sub compile {
+ my ( $self, $code ) = @_;
+
+ my $anon = Everything::HTML::createAnonSub($code);
+ return Everything::HTML::make_coderef($anon, $self);
+
+
+}
+
+sub get_compilable_field {
+
+ die "Sub-class responsibility";
+
+}
+
+sub eval_code {
+ my $self = shift;
+ my $sub = shift;
+ my $field = shift;
+ $field ||= $self->get_compilable_field;
+ my @args = @_;
+
+
+ my $html = Everything::HTML::execute_coderef( $sub, $field, $self, @args );
+ return $html;
+}
+
+
+sub createAnonSub {
+ my ($self, $code) = @_;
+
+### package name as to be put here to make sure we know which subs we are executing --------- set up environment
+ "sub {
+ $code
+ }\n";
+}
+
+=head2 C<compileCache>
+
+Common compilation and caching and initial calling of htmlcode and
+nodemethod functions. Hopefully it keeps common code in one spot. For
+internal use only!
+
+=over 4
+
+=item * $code
+
+the text to eval() into an anonymous subroutine
+
+=item * $NODE
+
+the node object from which the code came
+
+=item * $field
+
+the field of the node that holds the code for that nodetype
+
+=item * $args
+
+a reference to a list of arguments to pass
+
+=back
+
+Returns a string containing results of the code or a blank string. Undef if
+the compilation fails -- in case we need to default to old behavior.
+
+=cut
+
+sub compileCache
+{
+ my ($self, $code_ref, $args) = @_;
+ my $field = $self->get_compilable_field;
+ my $NODE = $self->getNODE;
+ return unless $code_ref;
+
+ return 1 if $NODE->{DB}->{cache}->cacheMethod($NODE, $field, $code_ref);
+
+}
+
+
+1;
Property changes on: trunk/ebase/lib/Everything/Node/Runnable.pm
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
Added: trunk/ebase/lib/Everything/Node/Test/Parseable.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Test/Parseable.pm (rev 0)
+++ trunk/ebase/lib/Everything/Node/Test/Parseable.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -0,0 +1,278 @@
+package Everything::Node::Test::Parseable;
+
+
+use base 'Everything::Node::Test::Runnable';
+use Test::More;
+use Test::MockObject;
+use Test::MockObject::Extends;
+use Test::Exception;
+use Scalar::Util 'blessed';
+use SUPER;
+
+use strict;
+
+
+
+sub startup_parseable : Test(startup => +0) {
+ my $self = shift;
+ $self->SUPER;
+ require Everything::Node::Parseable;
+
+
+}
+
+
+sub test_do_args : Test(2) {
+
+ my $self = shift;
+ can_ok( $self->{class}, 'do_args' ) || return;
+ my $arg = "first, sec ond ,third";
+ my $expected_result = [ q{'first'}, q{'sec ond'}, q{'third'} ];
+ my $do_args = \&{ $self->{class} . '::do_args' };
+ is_deeply( [ $do_args->($arg) ],
+ $expected_result,
+ 'do_args turns comma-delimited arguments into an array' );
+
+}
+
+sub test_createAnonSub : Test(2) {
+
+ my $self = shift;
+ can_ok( $self->{class}, 'createAnonSub' ) || return;
+ my $arg = "some random data";
+ like( $self->{instance}->createAnonSub($arg),
+ qr/^\s*sub\s*\{\s*$arg\s*\}/s, 'createAnonSub wraps args in sub{}' );
+
+}
+
+sub test_parse : Test(20) {
+ my $self = shift;
+
+ my $test_suite = htmlcode_hash();
+ foreach ( keys %$test_suite ) {
+
+ $self->{instance}->{title} = 'Fake Node';
+ $self->{instance}->{node_id} = 222;
+ $self->{instance}->{code} = $test_suite->{$_}->{input};
+ my $rv = $self->{instance}->parse($self->{instance}->{code});
+ my $main_code = $test_suite->{$_}->{output};
+ like( $rv, $main_code, "Should wrap $_ code in the right way." );
+
+ ## We also need to test the wrap code:
+ my $start_wrap = qr/^\s*my\s+\$result;\s+\$result\s*\.=\s*/s;
+ like( $rv, $start_wrap, 'Should start the eval block properly' );
+
+ my $error_code = qr//;
+
+ unless ( $_ eq 'TEXT' ) {
+
+ $error_code =
+qr/\s*Everything::logErrors\('',\s+ \$@,\s+ '',\s+ \{\s+ title\s+ =>\s* 'Fake\\\sNode',\s+node_id\s+ =>\s+ '222'\s+ \}\)\s*if\s+\(\$@\);
+/sx;
+ }
+ my $final_code = qr/\s+return\s+\$result\s*;\s*$/sx;
+ like( $rv, qr/$error_code$final_code/,
+ 'Should end the eval block properly' );
+ like(
+ $rv,
+ qr/$start_wrap$main_code$error_code$final_code/,
+ 'The whole lot'
+ );
+ }
+
+}
+
+sub htmlcode_hash {
+ {
+ TEXT => {
+ input => q/Some "text" <html> text's stuff/,
+ output => qr/'Some "text" <html> text\\'s stuff'\s*;/s
+
+ },
+
+ HTMLCODE => {
+ input => q/[{anhtmlcodething: one, two ,three }]/,
+ output =>
+qr/\s*eval\s*\{\s*anhtmlcodething\s*\(\s*'one'\s*,\s*'two'\s*,\s*'three'\s*\)\s+\}\s+\|\|\s+''\s*;/s
+
+ },
+
+ PERL1 => {
+ input => q/[% do { "$stuff" = %thing{3} } while ($x == 2) %]/,
+ output =>
+qr/\s*eval\s*\{\s* do \{ "\$stuff" = %thing\{3\} \} while \(\$x == 2\)\s*\}\s+\|\|\s+''\s*;/s
+ },
+
+ PERL2 => {
+ input => q/[" do { $stuff = "%thing{3}" } while ($x == 2) "]/,
+ output =>
+qr/\s*eval\s*\{\s* do \{ \$stuff = "%thing\{3\}" \} while \(\$x == 2\)\s*\}\s+\|\|\s+''\s*;/s
+ },
+
+### Note the html code does not allow spaced between < and the name of
+### the htmlsnippet
+ HTMLSNIPPET => {
+ input => q/[<htmlsnippettext>]/,
+ output =>
+qr/eval\s*\{\s*htmlsnippet\s*\(\s*'htmlsnippettext'\s*\)\s*\}\s+\|\|\s+''\s*;/s
+
+ },
+ }
+
+}
+
+sub test_make_eval_text : Test(2) {
+ return 'unimplemented';
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
+ can_ok( $class, 'make_eval_text' ) || return;
+ my $make_eval_text = \&{ $class . '::make_eval_text' };
+ my $tokens = [ [ PERL => 'one' ], [ TEXT => 'two' ], [ TEXT => 'three' ] ];
+ is(
+ $make_eval_text->($tokens), 'my $result;
+
+$result .= one
+
+$result .= two
+
+$result .= three
+
+return $result;', 'Making up the eval text'
+ );
+
+}
+
+# tokenise - does it tokenise properly
+sub test_tokenise : Test(13) {
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
+ can_ok( $class, 'tokenise' ) || return "Can't tokenise";
+ my $tokenise = \&{ $class . '::tokenise' };
+ my @input = discrete_snippets();
+
+ my $tokens = [];
+ foreach (@input) {
+ my $result = $tokenise->($_);
+ push @$tokens, @$result;
+ }
+ is(
+ $tokens->[0]->[1],
+ 'ahtmlcodebit:one, two , three ',
+ "Tokenise a single expression"
+ );
+ is( $tokens->[1]->[1], ' $pure @perl', "Tokenise a single expression" );
+ is( $tokens->[2]->[1], ' $pure @perl', "Tokenise a single expression" );
+ is( $tokens->[3]->[1], 'somehtmlsnippet', "Tokenise a single expression" );
+ is( $tokens->[4]->[1], q{random's text"!$},
+ "Tokenise a single expression" );
+
+ my $input = trial_text();
+ ok( $tokens = $tokenise->($input), "Run tokenise" );
+
+ is( $tokens->[0]->[1], '<some text> ', "Tokenising a block of text" );
+ is( $tokens->[1]->[1], 'htmlcode:one', "Tokenising a block of text" );
+ is( $tokens->[2]->[1], "\nsome more text ", "Tokenising a block of text" );
+ is( $tokens->[3]->[1], ' &then some @perl ', "Tokenising a block of text" );
+ is( $tokens->[4]->[1], " finally\n ", "Tokenising a block of text" );
+ is( $tokens->[5]->[1], 'asnippet', "Tokenising a block of text" );
+
+}
+
+sub discrete_snippets {
+
+ (
+ '[{ahtmlcodebit:one, two , three }]',
+ '[% $pure @perl%]',
+ '[" $pure @perl"]',
+ '[<somehtmlsnippet>]',
+ q{random's text"!$},
+ )
+
+}
+
+
+sub test_tokens_to_perl : Test(12) {
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
+
+ can_ok( $class, 'tokens_to_perl' ) || return;
+ my @snippets = discrete_snippets();
+ my $tokenise = \&{ $class . '::tokenise' };
+ my $code_up_tokens = \&{ $class . '::tokens_to_perl' };
+
+ my $tokens = [];
+ foreach (@snippets) {
+ my $toke;
+ ok( $toke = $tokenise->($_) );
+ push @$tokens, @$toke;
+ }
+
+ my $tokens = $code_up_tokens->($tokens, sub {} );
+ is( ref $tokens, 'ARRAY', "tokens_to_perl tokens returns an array ref." );
+ my @encoded = @$tokens;
+ is(
+ $encoded[0]->[1],
+ q! eval { ahtmlcodebit('one', 'two', 'three') } || '';! . "\n",
+ "Encoding HTMLCODE"
+ );
+ is(
+ $encoded[1]->[1],
+ qq! eval { \n \$pure \@perl\n} || '';\n!,
+ "Encoding PERL"
+ );
+ is(
+ $encoded[2]->[1],
+ qq! eval { \n \$pure \@perl\n} || '';\n!,
+ "Encoding PERL"
+ );
+ is(
+ $encoded[3]->[1],
+ qq! eval {htmlsnippet('somehtmlsnippet')} || '';\n!,
+ "Encoding HTMLSNIPPET"
+ );
+ is( $encoded[4]->[1], q{ 'random\'s text"!$';}, "Encoding TEXT" );
+}
+
+sub test_add_error_text : Test(8) {
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
+
+ can_ok( $class, 'add_error_text' ) || return;
+ my $add_error_text = \&{ $class . '::add_error_text' };
+ my $error_code =
+qr/\s*Everything::logErrors\('',\s+ \$@,\s+ '',\s+ \{\s+ title\s+ =>\s* 'Fake\\\sNode',\s+node_id\s+ =>\s+ '222'\s+ \}\)\s*if\s+\(\$@\);
+/sx;
+ my $current_node = { title => 'Fake Node', node_id => 222 };
+ ### set up our encoded text
+ my @snippets = discrete_snippets();
+
+ my $tokenise = \&{ $class . '::tokenise' };
+ my @tokens = ();
+ foreach (@snippets) {
+ my $toke;
+ ok( $toke = $tokenise->($_) );
+ push @tokens, @$toke;
+ }
+
+ my $code_up_tokens = \&{ $class . '::tokens_to_perl' };
+ my $encoded_tokens = $code_up_tokens->( \@tokens );
+ is( ref $encoded_tokens, 'ARRAY', "Code up tokens returns an array ref." );
+ my $error_text = $add_error_text->( $current_node );
+ like( $error_text, qr/Everything::logErrors/, "Add error text works" );
+
+}
+
+sub trial_text {
+
+ q/<some text> [{htmlcode:one}]
+some more text [% &then some @perl %] finally
+ [<asnippet>] and Title:[{morehtmlcode}]/
+
+}
+
+1;
+
Property changes on: trunk/ebase/lib/Everything/Node/Test/Parseable.pm
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
Added: trunk/ebase/lib/Everything/Node/Test/Runnable.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Test/Runnable.pm (rev 0)
+++ trunk/ebase/lib/Everything/Node/Test/Runnable.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -0,0 +1,113 @@
+package Everything::Node::Test::Runnable;
+
+use strict;
+use base 'Test::Class';
+use Test::More;
+use Test::MockObject;
+use Test::MockObject::Extends;
+use Test::Exception;
+use Scalar::Util 'blessed';
+
+
+
+
+
+
+
+sub startup_runnable : Test(startup => 1) {
+ my $self = shift;
+ my $mock = Test::MockObject->new;
+ $mock->fake_module('Everything',
+ flushErrorsToBackside => sub {1},
+ getBacksideErrors => sub {1});
+
+ $mock->fake_module('Everything::Auth');
+ *Everything::HTTP::Request::DB = \$mock;
+ $mock->set_always('get_db', $mock);
+ $mock->set_always('getNodeById', $mock);
+
+ $mock->set_always('getNode', $mock);
+ $mock->set_always('get_user', $mock);
+ $mock->set_always('get_db', $mock);
+
+
+
+
+ $mock->set_true('update');
+ $mock->set_true('setVars');
+ $mock->set_series('isGod', 0, 1);
+
+ $mock->set_always('param', $mock);
+
+ $self->{mock} = $mock;
+
+ *Everything::HTML::Code::Environment::flushErrorsToBackside = sub {1};
+ *Everything::HTML::Code::Environment::clearFrontside = sub {1};
+ *Everything::HTML::Code::Environment::getFrontsideErrors = sub {[]};
+
+ my $class = $self->module_class();
+
+ $self->{class} = $class;
+ use Everything;
+ use_ok($class) or die;
+
+
+}
+
+
+sub module_class
+{
+ my $self = shift;
+ my $name = blessed( $self );
+ $name =~ s/Test:://;
+ return $name;
+}
+
+
+sub fixture_environment : Test(setup) {
+ my $self=shift;
+ $self->{instance} = $self->{class}->new;
+
+
+}
+
+
+### A utility sub for eval
+sub test_createAnonSub : Test(2) {
+ my $self = shift;
+ can_ok($self->{class}, 'createAnonSub') || return;
+ my $arg = "some random data";
+ like( $self->{instance}->createAnonSub($arg), qr/^\s*sub\s*\{\s*$arg\s*\}/s, 'createAnonSub wraps args in sub{}');
+}
+
+
+
+## takes text which should be an eval-able sub as an argument, returns
+## a string.
+sub test_eval_code : Test(4) {
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
+ can_ok($class, 'eval_code');
+
+
+ my $errors = '';
+
+ local *Everything::HTML::flushErrorsToBackside;
+ *Everything::HTML::flushErrorsToBackside = sub { 1 };
+
+
+ local *Everything::HTML::getFrontsideErrors;
+ *Everything::HTML::getFrontsideErrors = sub { [] };
+
+ local *Everything::HTML::logErrors;
+ *Everything::HTML::logErrors = sub { $errors = "@_" };
+
+ my $code = eval "sub {'random text'}";
+ is (ref $code, 'CODE', '...we get a code ref.');
+ is($instance->eval_code($code, 'page'), 'random text', 'Eval code works');
+ is ($errors, '', '...runs without errors.') || diag $errors;
+}
+
+1;
+
Property changes on: trunk/ebase/lib/Everything/Node/Test/Runnable.pm
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
Modified: trunk/ebase/lib/Everything/Node/Test/htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Test/htmlpage.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/Test/htmlpage.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -19,41 +19,6 @@
'dbtables() should return node tables' );
}
-sub test_insert :Test( +5 )
-{
- my $self = shift;
- my $node = $self->{node};
- my $db = $self->{mock_db};
-
- $node->{parent_container} = 'npc';
- $self->SUPER();
-
- $node->{DB} = $db;
- delete $node->{parent_container};
- $node->set_true( 'SUPER' )
- ->clear();
- $db->set_series( -getNode => undef, 'gnc' );
-
- $node->insert( 'user' );
- is( $node->{parent_container}, 0,
- 'insert() should set node parent container to 0 without it and a GNC' );
-
- $node->insert( 'user' );
- is( $node->{parent_container}, 'gnc',
- '... but should set it to GNC if that exists' );
-
- $node->{parent_container} = 'npc';
- $node->insert( 'user' );
- is( $node->{parent_container}, 'npc',
- '... but should not override an existing parent container' );
-
- my ($method, $args) = $node->next_call();
- is( $method, 'SUPER', '... and should call SUPER()' );
- is( $args->[1], 'user', '... passing user' );
-
- $node->clear();
-}
-
sub test_insert_access :Test( +0 )
{
my $self = shift;
Modified: trunk/ebase/lib/Everything/Node/container.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/container.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/container.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -11,7 +11,7 @@
use strict;
use warnings;
-use base 'Everything::Node::node';
+use base 'Everything::Node::Parseable', 'Everything::Node::node';
=head2 C<dbtables()>
@@ -25,4 +25,8 @@
return 'container', $self->SUPER::dbtables();
}
+sub get_compilable_field {
+ 'context';
+}
+
1;
Modified: trunk/ebase/lib/Everything/Node/htmlcode.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/htmlcode.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/htmlcode.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -11,7 +11,7 @@
use strict;
use warnings;
-use base 'Everything::Node::node';
+use base 'Everything::Node::node', 'Everything::Node::Runnable';
=head2 C<dbtables()>
@@ -59,4 +59,8 @@
return 1;
}
+sub get_compilable_field {
+ 'code';
+}
+
1;
Modified: trunk/ebase/lib/Everything/Node/htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/htmlpage.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/htmlpage.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -11,7 +11,7 @@
use strict;
use warnings;
-use base 'Everything::Node::node';
+use base 'Everything::Node::node', 'Everything::Node::Parseable';
=head2 C<dbtables()>
@@ -25,25 +25,8 @@
return 'htmlpage', $self->SUPER::dbtables();
}
-=head2 C<insert>
-
-We need to set up some default settings when a htmlpage is inserted.
-
-=cut
-
-sub insert
-{
- my ( $this, $USER ) = @_;
-
- # If there is no parent container set, we need a default
- unless ( $this->{parent_container} )
- {
- my $GNC =
- $this->{DB}->getNode( "general nodelet container", "container" );
- $this->{parent_container} = $GNC ? $GNC : 0;
- }
-
- $this->SUPER( $USER );
+sub get_compilable_field {
+ 'page';
}
1;
Modified: trunk/ebase/lib/Everything/Node/htmlsnippet.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/htmlsnippet.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/htmlsnippet.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -11,6 +11,12 @@
use strict;
use warnings;
-use base 'Everything::Node::htmlcode';
+use base 'Everything::Node::Parseable', 'Everything::Node::htmlcode';
+sub get_compilable_field {
+
+ 'code'
+
+}
+
1;
Modified: trunk/ebase/lib/Everything/Node/nodegroup.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/nodegroup.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/nodegroup.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -418,7 +418,7 @@
=back
-Returns a reference to an array of node hashes that belong to this group.
+Returns a reference to an array of node instances that belong to this group.
=cut
Modified: trunk/ebase/lib/Everything/Node/nodelet.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/nodelet.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/nodelet.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -11,7 +11,7 @@
use strict;
use warnings;
-use base 'Everything::Node::node';
+use base 'Everything::Node::Parseable', 'Everything::Node::node';
=head2 C<dbtables()>
@@ -60,4 +60,8 @@
return $keys;
}
+sub get_compilable_field {
+ 'nlcode';
+}
+
1;
Modified: trunk/ebase/lib/Everything/Node/superdoc.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/superdoc.pm 2007-05-22 23:13:06 UTC (rev 959)
+++ trunk/ebase/lib/Everything/Node/superdoc.pm 2007-05-22 23:14:00 UTC (rev 960)
@@ -11,6 +11,8 @@
use strict;
use warnings;
-use base 'Everything::Node::document';
+use base 'Everything::Node::Parseable', 'Everything::Node::document';
+sub get_compilable_field { 'doctext' }
+
1;
Added: trunk/ebase/t/Node/parseable.t
===================================================================
--- trunk/ebase/t/Node/parseable.t (rev 0)
+++ trunk/ebase/t/Node/parseable.t 2007-05-22 23:14:00 UTC (rev 960)
@@ -0,0 +1,6 @@
+#!/usr/bin/perl
+
+use Everything::Node::Test::Parseable;
+
+use strict;
+Everything::Node::Test::Parseable->runtests;
Property changes on: trunk/ebase/t/Node/parseable.t
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
Added: trunk/ebase/t/Node/runnable.t
===================================================================
--- trunk/ebase/t/Node/runnable.t (rev 0)
+++ trunk/ebase/t/Node/runnable.t 2007-05-22 23:14:00 UTC (rev 960)
@@ -0,0 +1,7 @@
+#!/usr/bin/perl -w
+
+use Everything::Node::Test::Runnable;
+
+use strict;
+
+Everything::Node::Test::Runnable->runtests;
Property changes on: trunk/ebase/t/Node/runnable.t
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
