Menu
▾
▴
everydevel-opers
|
From: <pau...@us...> - 2007-07-24 18:08:02
|
Revision: 976
http://svn.sourceforge.net/everydevel/?rev=976&view=rev
Author: paul_the_nomad
Date: 2007-07-24 11:07:57 -0700 (Tue, 24 Jul 2007)
Log Message:
-----------
Fixes for compatibility with Test::MockObject 1.08
Modified Paths:
--------------
trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm
trunk/ebase/lib/Everything/HTML/FormObject/Test/AuthorMenu.pm
trunk/ebase/lib/Everything/HTTP/Test/Apache.pm
trunk/ebase/lib/Everything/HTTP/Test/CGI.pm
trunk/ebase/lib/Everything/HTTP/Test/URL.pm
trunk/ebase/lib/Everything/Node/Test/Runnable.pm
trunk/ebase/lib/Everything/Node/Test/container.pm
trunk/ebase/lib/Everything/Node/Test/htmlpage.pm
trunk/ebase/lib/Everything/Node/Test/node.pm
trunk/ebase/lib/Everything/Test/CmdLine.pm
trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm
trunk/ebase/lib/Everything/Test/HTML.pm
trunk/ebase/lib/Everything/Test/Node.pm
trunk/ebase/lib/Everything/Test/Nodeball.pm
trunk/ebase/lib/Everything/Test/XML.pm
trunk/ebase/lib/Everything/XML/Test/Node.pm
Property Changed:
----------------
trunk/ebase/
Property changes on: trunk/ebase
___________________________________________________________________
Name: svk:merge
- 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:979
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
+ 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:980
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
Modified: trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm
===================================================================
--- trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Auth/Test/EveryAuth.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -11,7 +11,6 @@
my $self = shift;
my $module = $self->module_class();
my $mock = Test::MockObject->new;
- $mock->fake_module('Everything');
$mock->fake_module('Everything::HTML');
my $cgi = CGI->new;
use_ok($module) or exit;
Modified: trunk/ebase/lib/Everything/HTML/FormObject/Test/AuthorMenu.pm
===================================================================
--- trunk/ebase/lib/Everything/HTML/FormObject/Test/AuthorMenu.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/HTML/FormObject/Test/AuthorMenu.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -8,13 +8,6 @@
use warnings;
use strict;
-sub setup_mocks {
- my $self = shift;
- $self->SUPER;
- $self->{mock}->fake_module('Everything::HTML');
-
-}
-
sub test_cgi_verify : Test(17) {
my $self = shift;
my $mock = $self->{mock};
Modified: trunk/ebase/lib/Everything/HTTP/Test/Apache.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Test/Apache.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/HTTP/Test/Apache.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -11,7 +11,6 @@
sub test_startup : Test(startup => 1) {
my $self = shift;
my $mock = Test::MockObject->new;
- $mock->fake_module('Everything');
$mock->fake_module('Everything::Auth');
my $fake_apache_request = Test::MockObject->new;
my $fake_everything_request = Test::MockObject->new;
Modified: trunk/ebase/lib/Everything/HTTP/Test/CGI.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Test/CGI.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/HTTP/Test/CGI.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -6,6 +6,11 @@
use strict;
use warnings;
+BEGIN {
+ Test::MockObject->fake_module('Everything::HTTP::ResponseFactory');
+ Test::MockObject->fake_module('Everything::HTTP::Request');
+}
+
sub test_handle : Test(17) {
my $self = shift;
my $package = $self->{class};
@@ -25,10 +30,8 @@
);
$mock->set_series( 'isOfType', 0, 0, 1, 1, 0, 1, 1, 0 );
- $mock->fake_module('Everything::HTTP::Request');
$mock->fake_new('Everything::HTTP::Request');
- $mock->fake_module('Everything::HTTP::ResponseFactory');
$mock->fake_new('Everything::HTTP::ResponseFactory');
local $ENV{SCRIPT_NAME} = 'http://foo/bar/';
Modified: trunk/ebase/lib/Everything/HTTP/Test/URL.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Test/URL.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/HTTP/Test/URL.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -36,18 +36,7 @@
}
-sub test_accessors : Test(10) {
- my $self = shift;
- my @attributes = qw/request cgi location path_info url/;
- foreach (@attributes) {
- can_ok($self->{class}, "set_$_");
- can_ok($self->{class}, "get_$_");
- }
-
-}
-
-
sub test_create_nodetype_rule : Test(6) {
my $self = shift;
my $instance = Test::MockObject::Extends->new($self->{instance});
@@ -56,9 +45,7 @@
my $node = $self->{mock};
- $node->{DB}=$self->{mock};
- $instance->set_always('get_e', $node);
- $node->set_always('get_db', $node);
+ $node->set_always('get_nodebase', $node);
$node->set_always('getNode', $node);
$node->{type} = $node;
my $nodetype_name = 'nodetypename';
@@ -68,13 +55,15 @@
my $nodetype_rule;
ok ($nodetype_rule = $instance->create_nodetype_rule($sub, $nodetype_name),
'...should run nodetype rule');
+
is (ref $nodetype_rule, 'CODE', '...and return a code ref.');
$node->set_series('getType', {title => 'nodetypename'}, {title => 'notnodetypename'});
- is ($nodetype_rule->($node), 'for real', '...should run the code if our node conforms.');
+ my $obj = bless {}, 'Everything::Node::nodetypename';
+ is ($nodetype_rule->($obj), 'for real', '...should run the code if our node conforms.');
$node->{title} = "differentname";
is ($nodetype_rule->($node), undef, '...and return undef when it does not.');
- is ($instance->get_select_node_subs_ref->[-1], $nodetype_rule, '...and add it to the subs.')
+ is ($instance->get_node_to_url_subs_ref->[-1], $nodetype_rule, '...and add it to the subs.')
}
sub test_create_linknode : Test(3) {
Modified: trunk/ebase/lib/Everything/Node/Test/Runnable.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Test/Runnable.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Node/Test/Runnable.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -10,10 +10,12 @@
+BEGIN {
+ Test::MockObject->fake_module('Everything::Auth');
+}
-
sub startup_runnable : Test(startup => 1) {
my $self = shift;
my $mock = Test::MockObject->new;
@@ -21,7 +23,6 @@
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);
Modified: trunk/ebase/lib/Everything/Node/Test/container.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Test/container.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Node/Test/container.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -95,6 +95,7 @@
my $result;
my $node_id = 123;
$instance->mock( get_node_id => sub { $node_id } );
+ $instance->set_false( 'get_parent_container' );
is( $result = $instance->generate_container( undef, $mock ),
$expected,
@@ -102,7 +103,7 @@
## test for parent container;
- $instance->set_parent_container($node_id);
+ $instance->mock(get_parent_container => sub { $node_id } );
$mock->set_always( getNode => $instance );
dies_ok { $result = $instance->generate_container( 1, $mock ) }
Modified: trunk/ebase/lib/Everything/Node/Test/htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Test/htmlpage.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Node/Test/htmlpage.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -6,6 +6,7 @@
use base 'Everything::Node::Test::node';
use Test::More;
+use SUPER;
sub test_dbtables
{
@@ -52,6 +53,7 @@
my $class = $self->node_class();
my $instance = $self->{node};
$instance->set_always( 'run', 'some htmlpage html <BacksideErrors>' );
+ $instance->set_always(get_parent_container => 0 );
my $mock = Test::MockObject->new;
$mock->set_always( get_user => $mock );
can_ok($class, 'make_html');
Modified: trunk/ebase/lib/Everything/Node/Test/node.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Test/node.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Node/Test/node.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -76,7 +76,7 @@
my $blank_db = catfile(qw( t ebase.db ));
require 't/lib/build_test_db.pm' unless -e $blank_db;
- my $tempdir = File::Temp::tempdir( DIR => 't', CLEANUP => 1 );
+ my $tempdir = File::Temp::tempdir( DIR => 't', CLEANUP => 1);
my $module = $self->node_class();
my $module_db = catfile( $tempdir, $module . '_base.db' );
Modified: trunk/ebase/lib/Everything/Test/CmdLine.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/CmdLine.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Test/CmdLine.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -14,6 +14,8 @@
BEGIN {
*CORE::GLOBAL::exit = sub { $exited++ };
+ Test::MockObject->fake_module('Everything::NodeBase');
+
}
sub test_get_options : Test(4) {
@@ -97,7 +99,6 @@
|| return 'abs_path not implemented.';
my $mock = Test::MockObject->new;
- $mock->fake_module('Everything::NodeBase');
my @new_args;
my $new_returns = $mock;
Modified: trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -2,7 +2,7 @@
package Everything::Test::Ecore::SimpleServer;
use SUPER;
-use Everything::HTML qw/mod_perlInit/;
+use Everything::HTTP::CGI;
use base 'HTTP::Server::Simple::CGI';
@@ -30,7 +30,7 @@
my $args = $self->{mod_perlInit};
- mod_perlInit( @$args );
+ Everything::HTTP::CGI->handle( @$args );
}
Modified: trunk/ebase/lib/Everything/Test/HTML.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/HTML.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Test/HTML.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -23,7 +23,7 @@
my $self = shift;
my $class = $self->module_class();
my $mock = Test::MockObject->new;
- $mock->fake_module('Everything');
+
$mock->fake_module('Everything::HTTP::Request');
$mock->fake_new('Everything::HTTP::Request');
$mock->set_always( 'get_cgi', $mock )->set_always( 'get_node', $mock );
Modified: trunk/ebase/lib/Everything/Test/Node.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/Node.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Test/Node.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -8,6 +8,11 @@
use strict;
use warnings;
+BEGIN {
+ Test::MockObject->fake_module('Everything::Util');
+ Test::MockObject->fake_module('XML::Dom');
+}
+
sub module_class {
my $self = shift;
my $name = blessed($self);
@@ -29,8 +34,6 @@
}
);
- $mock->fake_module('Everything::Util');
- $mock->fake_module('XML::Dom');
$self->{mock} = $mock;
use_ok( $self->{class} ) || exit;
Modified: trunk/ebase/lib/Everything/Test/Nodeball.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/Nodeball.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Test/Nodeball.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -15,6 +15,10 @@
use strict;
use warnings;
+BEGIN {
+ Test::MockObject->fake_module('Everything::XML::Node');
+}
+
sub startup : Test(startup => +0) {
my $self = shift;
$self->SUPER;
@@ -436,7 +440,6 @@
|| return 'exportNodes not implemented.';
my $instance = $self->{instance};
my $mock = $self->{mock};
- $mock->fake_module('Everything::XML::Node');
$mock->fake_new('Everything::XML::Node');
$mock->mock( toXML => sub { "some xml" } );
my $test_code = \&{ $self->{class} . '::exportNodes' };
Modified: trunk/ebase/lib/Everything/Test/XML.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/XML.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/Test/XML.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -8,6 +8,8 @@
use base 'Everything::Test::Abstract';
+BEGIN { Test::MockObject->fake_module( 'XML::DOM' ); }
+
sub startup : Test(startup => +1) {
my $self = shift;
my $mock = Test::MockObject->new;
@@ -15,7 +17,6 @@
$self->{le} = [];
$mock->fake_module( 'Everything',
logErrors => sub { push @{ $self->{le} }, [@_] } );
- $mock->fake_module('XML::DOM');
# test imports
my %import;
Modified: trunk/ebase/lib/Everything/XML/Test/Node.pm
===================================================================
--- trunk/ebase/lib/Everything/XML/Test/Node.pm 2007-07-24 18:05:18 UTC (rev 975)
+++ trunk/ebase/lib/Everything/XML/Test/Node.pm 2007-07-24 18:07:57 UTC (rev 976)
@@ -8,6 +8,12 @@
use strict;
use warnings;
+BEGIN {
+ Test::MockObject->fake_module('XML::DOM::Text');
+ Test::MockObject->fake_module('XML::DOM::Element');
+ Test::MockObject->fake_module('XML::DOM::Document');
+}
+
sub object_class {
my $self = shift;
my $name = blessed($self);
@@ -177,9 +183,7 @@
$instance->set_node($mock);
$instance->set_nodebase($mock);
- $mock->fake_module('XML::DOM::Element');
$mock->fake_new('XML::DOM::Element');
- $mock->fake_module('XML::DOM::Text');
$mock->fake_new('XML::DOM::Text');
$mock->set_true( 'setAttribute', 'appendChild', '-isOfType', '-getRef' );
@@ -356,8 +360,6 @@
use strict 'refs';
$mock->set_always(getNodeKeys => { key1 => 'value1', key2 => 'value2'} );
- $mock->fake_module('XML::DOM::Document');
- $mock->fake_module('XML::DOM::Text');
$mock->fake_new('XML::DOM::Document');
$mock->fake_new('XML::DOM::Text');
$mock->fake_new('XML::DOM::Element');
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2007-07-24 18:08:53
|
Revision: 977
http://svn.sourceforge.net/everydevel/?rev=977&view=rev
Author: paul_the_nomad
Date: 2007-07-24 11:08:52 -0700 (Tue, 24 Jul 2007)
Log Message:
-----------
Added tests, bug fixes and clean up of the code
Modified Paths:
--------------
trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm
trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm
Property Changed:
----------------
trunk/ebase/
Property changes on: trunk/ebase
___________________________________________________________________
Name: svk:merge
- 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:980
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
+ 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:981
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
Modified: trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm 2007-07-24 18:07:57 UTC (rev 976)
+++ trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm 2007-07-24 18:08:52 UTC (rev 977)
@@ -5,7 +5,7 @@
use base 'Class::Accessor::Fast';
__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors(
- qw/http_header http_body request htmlpage theme allowed/);
+ qw/http_header http_body request htmlpage theme allowed redirect/);
use strict;
### because this is called from a Class::Factory object new is not
@@ -35,8 +35,9 @@
$self->get_request->get_nodebase->getNode( $self->get_redirect );
$self->get_request->set_node($node);
$self->getTheme( $self->get_request );
- die "Incorrect permissions!" unless $htmlpage->check_permissions;
+ die "Incorrect permissions!" unless $self->check_permissions;
+
}
return $self->set_http_body(
$self->get_htmlpage->make_html( $self->get_request ) );
@@ -52,7 +53,7 @@
}
-=head2 C<getPageForType>
+=head2 C<get_page_for_type>
Given a nodetype, get the htmlpages needed to display nodes of this type. This
runs up the nodetype inheritance hierarchy until it finds something.
@@ -73,7 +74,7 @@
=cut
-sub getPageForType {
+sub get_page_for_type {
my ( $self, $TYPE, $displaytype ) = @_;
my %WHEREHASH;
my $PAGE;
@@ -133,7 +134,7 @@
my $NODE = $E->get_node;
my $user = $E->get_user;
my $query = $E->get_cgi;
- my $permission_needed = $PAGE->get_permissionneeded;
+ my $permission_needed = $PAGE->get_permissionneeded();
# If the user does not have the needed permission to view this
# node through the desired htmlpage, we send them to the permission
@@ -141,7 +142,7 @@
#Also check to see if the particular displaytype can be executed by the user
- unless ($NODE->hasAccess( $E->get_user, $permission_needed )
+ unless ($NODE->hasAccess( $user, $permission_needed )
and $PAGE->hasAccess( $user, "x" ) )
{
@@ -186,7 +187,7 @@
# my ($NODE, $displaytype) = @_;
my $TYPE;
- $TYPE = $DB->getType( $$NODE{type_nodetype} );
+ $TYPE = $DB->getType( $NODE->get_type_nodetype );
$displaytype ||= $$VARS{ 'displaypref_' . $$TYPE{title} }
if exists $$VARS{ 'displaypref_' . $$TYPE{title} };
$displaytype ||= $$THEME{ 'displaypref_' . $$TYPE{title} }
@@ -197,12 +198,10 @@
# First, we try to find the htmlpage for the desired display type,
# if one does not exist, we default to using the display page.
- $PAGE ||= $this->getPageForType( $TYPE, $displaytype );
- $PAGE ||= $this->getPageForType( $TYPE, 'display' );
+ $PAGE ||= $this->get_page_for_type( $TYPE, $displaytype );
- die "can't load a page $displaytype for $$TYPE{title} type" unless $PAGE;
+ die "Can't load a page $displaytype for $$TYPE{title} type" unless $PAGE;
- die "NO PAGE!" unless $PAGE;
$this->set_htmlpage($PAGE);
}
Modified: trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm 2007-07-24 18:07:57 UTC (rev 976)
+++ trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm 2007-07-24 18:08:52 UTC (rev 977)
@@ -2,75 +2,189 @@
use Test::More;
use Test::MockObject;
+use Test::MockObject::Extends;
use Scalar::Util 'blessed';
+use Everything::HTTP::Response::Htmlpage;
+use Everything::HTTP::Request;
use base 'Test::Class';
use strict;
use warnings;
-my $mock;
+sub module_class {
+ my $self = shift;
+ my $name = blessed($self);
+ $name =~ s/Test:://;
+ return $name;
+}
-sub module_class
-{
- my $self = shift;
- my $name = blessed( $self );
- $name =~ s/Test:://;
- return $name;
+sub startup : Test(startup=>2) {
+ my $self = shift;
+ $self->{class} = $self->module_class();
+ use_ok( $self->{class} ) || die $self->{class};
+ my $mock = Test::MockObject->new;
+
+ $mock->set_always( getNode => $mock );
+ $mock->set_true( 'set_theme', 'param', 'get_type_nodetype' );
+ $mock->set_always( 'get_user_vars' => {} );
+ $mock->set_always( '-get_theme', $mock );
+ $mock->set_always( '-get_node', $mock );
+ $mock->set_always( '-get_nodebase', $mock );
+ $mock->set_always( '-get_cgi', $mock );
+ $mock->set_always( 'getType', $mock );
+ $mock->{title} = 'a title';
+ $self->{mock} = $mock;
+ isa_ok( $self->{instance} = $self->{class}->new($mock), $self->{class} );
+
}
-use Everything::HTTP::Response::Htmlpage;
-use Everything::HTTP::Request;
+sub test_http_response : Test(3) {
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
+ can_ok( $class, 'create_http_header' );
+ can_ok( $class, 'create_http_body' );
+ can_ok( $class, 'get_mime_type' );
+}
-sub startup : Test(startup=>2) {
- my $self = shift;
- $self->{class} = $self->module_class();
- use_ok($self->{class}) || die $self->{class};
- my $mock = Test::MockObject->new;
+sub test_check_permissions : Test(7) {
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
- $mock->set_always( getNode => $mock );
- $mock->set_true( 'set_theme' );
- $mock->set_always( 'get_theme', $mock );
- $mock->set_always( 'get_node', $mock );
- $mock->set_always( 'get_nodebase', $mock );
- $mock->set_always( 'param', 'display' );
- $mock->set_always( 'get_cgi', $mock );
- $mock->set_always( 'getType', $mock );
- $mock->set_always( 'get_user_vars', { key => 'value' } );
- $mock->{title} = 'a title';
- $self->{mock} = $mock;
- isa_ok ($self->{instance} = $self->{class}->new($mock), $self->{class});
+ my $mock = $self->{mock};
+ $mock->clear;
+ $instance->set_request($mock);
+ $mock->set_always( -get_user => $mock );
+ $mock->set_always( -hasAccess => 0 );
+ $mock->set_always( -get_permissionneeded => 'r' );
+ $mock->set_always( -get_system_vars =>
+ { permissionDenied_node => 999, nodeLocked_node => 1001 } );
+ ok( !$instance->check_permissions,
+ '...if no access check permissions returns false.' );
+ is( $instance->get_redirect, 999,
+ '...and redirects to the permission deniend page.' );
+ $mock->set_always( -hasAccess => 1 );
+ ok( $instance->check_permissions,
+ '...returns true if the user has the correct permissions.' );
+
+ ## check node locking
+ $mock->clear;
+ $mock->set_always( -get_permissionneeded => 'w' );
+ $mock->set_true('lock');
+ ok( $instance->check_permissions,
+ '...access to edit htmlpage if we can obtain node lock.' );
+
+ $mock->clear;
+ $mock->set_false('lock');
+ ok( !$instance->check_permissions,
+ '...but no access to edit htmlpage without the node lock.' );
+ my ( $method, $args ) = $mock->next_call(2);
+ is(
+ "$method@$args",
+ "param$mock displaytype display",
+ '...and sets param on cgi to "display".'
+ );
+ is( $instance->get_redirect, 1001, '...and redirects to nodeLocked_node.' );
}
+sub test_get_theme : Test(2) {
-sub test_http_response : Test(3){
- my $self = shift;
- my $class = $self->{class};
- my $instance = $self->{instance};
- can_ok($class, 'create_http_header');
- can_ok($class, 'create_http_body');
- can_ok($class, 'get_mime_type');
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = $self->{instance};
+ my $e = $instance->get_request;
+ can_ok( $class, 'getTheme' ) || return;
+ my $mock = $self->{mock};
+ $mock->set_always( 'get_user_vars', { key => 'value' } );
+ $e->set_always( get_system_vars => { one => 'two' } )
+ ->set_always( get_db => $mock );
+ $mock->set_series( isOfType => 1, 0 )
+ ->set_always( 'getVars', { var1 => 'one', var2 => 'two' } );
+ ok( $instance->getTheme( $instance->get_request ) );
}
+sub test_select_htmlpage : Test(8) {
-sub test_get_theme : Test(2) {
+ my $self = shift;
+ my $class = $self->{class};
+ my $instance = Test::MockObject::Extends->new( $self->{instance} );
- my $self = shift;
- my $class = $self->{class};
- my $instance = $self->{instance};
- my $e = $instance->get_request;
- can_ok($class, 'getTheme') || return;
- my $mock = $self->{mock};
- $e->set_always(get_system_vars => { one => 'two' })
- ->set_always(get_db => $mock);
- $mock->set_series(isOfType => 1, 0)
- ->set_always('getVars', {var1 => 'one', var2 => 'two'});
- ok($instance->getTheme($instance->get_request));
+ my $mock = $self->{mock};
+ $mock->clear;
+ $instance->set_request($mock);
+
+ $mock->set_always( -get_theme => $mock );
+ $mock->set_always( -get_user_vars => {} );
+ $mock->set_always( -get_cgi => $mock );
+ $mock->set_always( param => 'adisplaytype' );
+ $mock->set_always( '-get_user_vars', { key => 'value' } );
+
+ $mock->set_always( getType => $mock );
+ $mock->set_always( -get_type_nodetype => 222 );
+ $mock->set_always( -get_nodebase => $mock );
+
+ $instance->set_always( get_page_for_type => $mock );
+
+ is( $instance->select_htmlpage, $mock, '...should retrieve an htmlpage.' );
+
+ my ( $method, $args ) = $mock->next_call();
+ is( $method . $$args[1],
+ 'paramdisplaytype', '...gets display type from cgi.' );
+ ( $method, $args ) = $mock->next_call();
+ is( $method . $$args[1], 'getType222', '...retrieves htmlpage nodetype.' );
+ ( $method, $args ) = $instance->next_call();
+ is(
+ "$method@$args",
+ "get_page_for_type$instance $mock adisplaytype",
+ '...gets display type calling with display name.'
+ );
+
+ $mock->set_always( param => '' );
+
+ $instance->set_always( get_page_for_type => 'htmlpagenode' );
+
+ is( $instance->select_htmlpage, 'htmlpagenode',
+ '...should retrieve a page if param is not set.' );
+ ( $method, $args ) = $instance->next_call();
+ is(
+ "$method@$args",
+ "get_page_for_type$instance $mock display",
+ '...and gets the "display" displaytype.'
+ );
+
+ $mock->set_always(
+ -get_user_vars => { 'displaypref_a title' => 'varsdisplaytype' } );
+
+ $instance->select_htmlpage;
+ ( $method, $args ) = $instance->next_call();
+ is(
+ "$method@$args",
+ "get_page_for_type$instance $mock varsdisplaytype",
+ '...and get the display type specified by user vars.'
+ );
+
+ $mock->set_always( -get_user_vars => {} );
+ $mock->{'displaypref_a title'} = 'themedisplaytype';
+ $instance->select_htmlpage;
+ ( $method, $args ) = $instance->next_call();
+ is(
+ "$method@$args",
+ "get_page_for_type$instance $mock themedisplaytype",
+ '...or gets the display type specified by the theme.'
+ );
+
}
+sub test_create_http_header : Test(1) {
+ local $TODO = "create http header should return a valid http header???."
+
+}
+
1;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2007-07-24 18:10:10
|
Revision: 978
http://svn.sourceforge.net/everydevel/?rev=978&view=rev
Author: paul_the_nomad
Date: 2007-07-24 11:10:03 -0700 (Tue, 24 Jul 2007)
Log Message:
-----------
Amendments to URL processing code
Modified Paths:
--------------
trunk/ebase/lib/Everything/HTTP/Apache.pm
trunk/ebase/lib/Everything/HTTP/Request.pm
trunk/ebase/lib/Everything/HTTP/URL/Deconstruct.pm
trunk/ebase/lib/Everything/HTTP/URL/Test/Deconstruct.pm
trunk/ebase/lib/Everything/HTTP/URL.pm
Property Changed:
----------------
trunk/ebase/
Property changes on: trunk/ebase
___________________________________________________________________
Name: svk:merge
- 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:981
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
+ 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:982
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
Modified: trunk/ebase/lib/Everything/HTTP/Apache.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Apache.pm 2007-07-24 18:08:52 UTC (rev 977)
+++ trunk/ebase/lib/Everything/HTTP/Apache.pm 2007-07-24 18:10:03 UTC (rev 978)
@@ -9,6 +9,8 @@
use strict;
use warnings;
+use Carp;
+#BEGIN { $SIG{__WARN__} = \&Carp::cluck;}
## initialise
Everything::HTTP::URL->set_default_sub( \&Everything::HTML::linkNode );
@@ -24,9 +26,11 @@
## scriptname for CGI
my $e =
Everything::HTTP::Request->new( "$db:$user:$password:$host", \%options );
- create_url_parsers( $r, $e )
- unless Everything::HTTP::URL->isset_url_parsers;
+ $e->get_nodebase->resetNodeCache;
+
+ create_url_parsers( $r, $e );
+
## sets up variables for serving web pages mostly pulled from db
$e->setup_standard_system_vars();
@@ -47,17 +51,16 @@
$e->set_node_from_cgi;
- if ( !$e->get_node ) {
- my $node = Everything::HTTP::URL->parse_url($r);
+ if ( !$e->get_node ) {
- if ( $node && !ref $node ) {
- return NOT_FOUND;
- }
- else {
- $e->set_node($node);
- }
- }
+ Everything::HTTP::URL->modify_request($r->path_info, $e);
+ my $node = $e->get_node;
+ if ( $node && !ref $node ) {
+ return NOT_FOUND;
+ }
+ }
+
### if we haven't returned find the default node
if ( !$e->get_node && ( $r->path_info eq '/' || $r->path_info eq '' ) ) {
my $default_node_id = $e->get_system_vars->{default_node};
@@ -99,9 +102,24 @@
## parse the URL
## setup url processing
+ Everything::HTTP::URL->clear_request_modifiers;
+ Everything::HTTP::URL->clear_node_to_url_subs;
+
+ Everything::HTTP::URL->register_request_modifier(
+ sub {
+ my ( $url, $e ) = @_;
+
+ return unless $url eq '/location/';
+ my $node = $e->get_nodebase->getNode( 0 );
+ $e->set_node ($node);
+ return 1;
+
+ });
+
my @url_config = $r->dir_config->get('everything-url');
return unless @url_config;
+
while ( my ( $schema, $linker_arg ) = splice( @url_config, 0, 2 ) ) {
my $url_parser = Everything::HTTP::URL::Deconstruct->new(
@@ -113,12 +131,16 @@
);
$url_parser->set_schema($schema);
$url_parser->make_url_gen;
- $url_parser->register_url_parser;
+ $url_parser->make_modify_request;
$url_parser->create_nodetype_rule( $url_parser->make_link_node,
$linker_arg );
}
+
+ my $link_node = Everything::HTTP::URL->create_linknode;
no warnings 'redefine';
- *Everything::HTML::linkNode = Everything::HTTP::URL->create_linknode;
+
+ *Everything::HTML::linkNode = sub { my $node = shift; $Everything::DB->getRef( $node ); $link_node->( $node, @_ ) };
+ use warnings 'redefine';
}
Modified: trunk/ebase/lib/Everything/HTTP/Request.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Request.pm 2007-07-24 18:08:52 UTC (rev 977)
+++ trunk/ebase/lib/Everything/HTTP/Request.pm 2007-07-24 18:10:03 UTC (rev 978)
@@ -178,8 +178,8 @@
$self, 'user';
tie $Everything::HTML::VARS, "Everything::HTML::Environment::Variable",
$self, 'user_vars';
- $Everything::HTML::NODE = $self->get_node;
- $Everything::HTML::GNODE = $self->get_node;
+ tie $Everything::HTML::NODE, "Everything::HTML::Environment::Variable", $self, 'node';
+ $Everything::HTML::GNODE = $Everything::HTML::NODE;
*Everything::HTML::HTMLVARS = $self->get_system_vars;
*Everything::HTML::GLOBAL = {};
$Everything::HTML::AUTH = $self->get_authorisation;
Modified: trunk/ebase/lib/Everything/HTTP/URL/Deconstruct.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/URL/Deconstruct.pm 2007-07-24 18:08:52 UTC (rev 977)
+++ trunk/ebase/lib/Everything/HTTP/URL/Deconstruct.pm 2007-07-24 18:10:03 UTC (rev 978)
@@ -1,14 +1,15 @@
package Everything::HTTP::URL::Deconstruct;
use strict;
-use base 'Everything::HTTP::URL';
+use base 'Class::Accessor::Fast', 'Everything::HTTP::URL';
use Data::Dumper;
use List::MoreUtils qw(zip);
use URI;
use SUPER;
+__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors(
- qw(re path_vars schema rule attributes tokens urlifier requested_node_id requested_node_ref url_gen matches nodebase )
+ qw(re path_vars schema rule attributes tokens urlifier requested_node_id requested_node_ref url_gen matches nodebase location)
);
#### DISPATCH TABLE FOR DECODING URLS
@@ -19,8 +20,8 @@
my $decode_attributes = {
type => sub {
- my ( $self, $attribute_value ) = @_;
- my $type = $self->get_nodebase->getType( $attribute_value->[1] );
+ my ( $nodebase, $attribute_value ) = @_;
+ my $type = $nodebase->getType( $attribute_value->[1] );
return 'type_nodetype', $type->{node_id};
},
__DEFAULT__ => sub { return @{ $_[1] }; },
@@ -38,8 +39,22 @@
__DEFAULT__ => sub { return $_[0]->{ $_[1] } },
};
+sub make_modify_request {
+ my $self = shift;
+ my $sub = sub {
+ my ( $url, $e ) = @_;
+ return unless $self->match($url);
+ my $node = $self->process($e);
+ $e->set_node($node);
+ return 1;
+ };
+
+ $self->register_request_modifier($sub);
+
+}
+
sub process {
- my $self = shift;
+ my ( $self, $e ) = @_;
my @matches = @{ $self->get_matches };
my %node_params = ();
while ( my ( $attribute, $value ) = splice @matches, 0, 2 ) {
@@ -47,12 +62,13 @@
my $action = $decode_attributes->{ $attribute->[0] }
|| $decode_attributes->{__DEFAULT__};
( $attribute, $value ) =
- $action->( $self, compulsory_value( $attribute, $value ) );
+ $action->( $e->get_nodebase, compulsory_value( $attribute, $value ) );
$node_params{$attribute} = $value;
}
- my $node = $self->make_requested_node_ref( \%node_params );
+ my $node =
+ $self->make_requested_node_ref( \%node_params, $e->get_nodebase );
return $node;
}
@@ -113,7 +129,8 @@
}
sub make_link_node {
- my $self = shift;
+ my $self = shift;
+ my $url_gen = $self->get_url_gen;
sub {
my ( $node, $title, $params, $scripts ) = @_;
@@ -123,7 +140,7 @@
# We do this instead of calling getRef, because we only need the node
# table data to create the link.
- $node = $self->get_nodebase->getNode( $node, 'light' )
+ $Everything::HTML::DB->getNode( $node, 'light' )
unless ( ref $node );
return "" unless ref $node;
@@ -136,7 +153,7 @@
my $scripts = handle_scripts($scripts);
- $link = "<a href=" . $self->get_url_gen->( $params, '', $node ) . $tags;
+ $link = "<a href=" . $url_gen->( $params, '', $node ) . $tags;
$link .= " " . $scripts if ( $scripts ne "" );
$link .= ">$title</a>";
@@ -220,9 +237,9 @@
## Returns nothing of consequence.
sub make_requested_node_ref {
- my ( $self, $matches ) = @_;
+ my ( $self, $matches, $nodebase ) = @_;
- my $nodes = $self->get_nodebase->getNodeWhere($matches);
+ my $nodes = $nodebase->getNodeWhere($matches);
return unless $nodes;
if ( @$nodes == 1 ) {
@@ -304,10 +321,10 @@
=head1 SYNOPSIS
- use Everything::HTTP::URLProcess::Deconstruct;
+ use Everything::HTTP::URL::Deconstruct;
my $r = Apache->request;
my $e = Everything::HTTP::Request->new;
- my $processor = Everything::HTTP::URLProcess::Deconstruct->new({r => $r, e => $e});
+ my $processor = Everything::HTTP::URL::Deconstruct->new({r => $r, e => $e});
$processor->set_schema('/path/text/:node_id');
@@ -335,22 +352,7 @@
=cut
-=head2 C<< $m->require_param NAME, VALUE >>
-NOT USED
-
-This internal method returns the regular expression
-to match a HTTP query parameter and its name.
-
-NAME is the name of the key into which the value will
-be captured.
-
-VALUE is the regular expression that will match
-the value.
-
-=cut
-
-
=head2 C<< $m->make_regex >>
This is the internal method that implements the meat
@@ -362,19 +364,17 @@
=head2 C<< $m->match($url) >>
-This is also an internal method.
-
Returns a list of captured values
if the request matches.
If the request matches but does not capture anything,
-a single 1 is returned. This is ugly but such is life.
+a single 1 is returned.
=cut
-=head2 C<< $m->process($url) >>
+=head2 C<< $m->process ($e) >>
-Takes a URL. Amends the Everything::HTTP::Request object in place setting the requested node to the appropriate values.
+Takes an Everything::HTTP::Request object and modifies it by setting the 'node',attribute. It should be called after 'match' and uses the 'matches' attribute to select the node.
=cut
Modified: trunk/ebase/lib/Everything/HTTP/URL/Test/Deconstruct.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/URL/Test/Deconstruct.pm 2007-07-24 18:08:52 UTC (rev 977)
+++ trunk/ebase/lib/Everything/HTTP/URL/Test/Deconstruct.pm 2007-07-24 18:10:03 UTC (rev 978)
@@ -10,7 +10,7 @@
## needs to be rewritten
-sub test_z_process : Test(5) {
+sub test_z_process : Test(4) {
my $self = shift;
can_ok($self->{class}, 'process') || return;
@@ -19,25 +19,23 @@
my $instance = $self->{instance};
- $instance->set_request($mock);
- $instance->get_request->set_always('get_nodebase',$mock)
- ->set_always('get_cgi', $mock);
$mock->set_true('param');
$instance->mock('make_requested_node_ref' => sub {$_[0]->set_requested_node_ref($mock) });
- $instance->set_always('get_nodebase', $mock);
+
$mock->set_always('getType', $mock);
$instance->set_schema('/node/:node_id');
- ok ($instance->process() );
- my ($method, $args) = $instance->next_call;
- is ($method, 'get_nodebase', '...gets nodebase object.');
+ my $fake_request = Test::MockObject->new;
+ $fake_request->set_always( get_nodebase => $mock );
+ ok ($instance->process( $fake_request ) );
+
$instance->set_schema('/node/:type');
$instance->get_nodebase->set_always('getType', {node_id => 111});
$instance->set_always('get_matches', [['type_nodetype'], 222]);
- ok ($instance->process() );
- my ($method, $args) = $instance->next_call;
+ ok ($instance->process( $fake_request ) );
+ my ($method, $args) = $instance->next_call();
is ($method, 'make_requested_node_ref', '...should call node making method.');
@@ -94,6 +92,7 @@
$instance->make_url_gen;
my $mock = Test::MockObject->new;
+ *Everything::HTML::DB = \$mock;
$mock->{node_id} = 111;
$mock->{title} = "Random node";
@@ -104,7 +103,7 @@
my $linkNode = $instance->make_link_node;
is(ref $linkNode, 'CODE', '...creates a code ref');
- is( $linkNode->(1), '<a href="/node/111">Random node</a>', "linkNode" );
+ is( $linkNode->($mock), '<a href="/node/111">Random node</a>', "linkNode" );
$mock->{node_id} = 222;
$mock->{title} = "Another Random Node";
is( $linkNode->($mock), '<a href="/node/222">Another Random Node</a>',
@@ -148,7 +147,7 @@
my $linkNode = $instance->make_link_node;
is(ref $linkNode, 'CODE', '...creates a code ref');
- is( $linkNode->(1), '<a href="/node/Random%20node">Random node</a>', "...testing node url creation." );
+ is( $linkNode->($mock), '<a href="/node/Random%20node">Random node</a>', "...testing node url creation." );
## testing title
Modified: trunk/ebase/lib/Everything/HTTP/URL.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/URL.pm 2007-07-24 18:08:52 UTC (rev 977)
+++ trunk/ebase/lib/Everything/HTTP/URL.pm 2007-07-24 18:10:03 UTC (rev 978)
@@ -1,13 +1,63 @@
package Everything::HTTP::URL;
-use base 'Class::Accessor::Fast';
-__PACKAGE__->follow_best_practice;
-__PACKAGE__->mk_accessors(
- qw/request path_info url cgi location requested_node_id requested_node_ref/
-);
+=cut
-our @select_node_subs = ();
-our @url_parsers = ();
+=head1 NAME
+
+ Everything::HTTP::URL - process requested urls and turn nodes into urls.
+
+=head1 SYNOPSIS
+
+
+ Everything::HTTP::URL->register_request_modifier(
+ sub { my ( $url, $e ) = @_;
+ return unless $url eq '/location/';
+ my $node = $e->get_nodebase->getNode( 0 );
+ $e->set_node ($node);
+ return 1;
+
+});
+
+ Everything::HTTP::URL->create_url_rule(
+ sub { my $node = shift;
+ return 1 if $node->get_title eq '/';
+ return
+ },
+ sub { '/location/' }
+ );
+
+Everything::HTTP::URL->set_default_sub( \&Everything::HTML::linkNode );
+
+
+The apache handler:
+
+sub handler {
+
+ my $r = shift; # grab the request object;
+
+ my $e = Evertyhing::HTTP::Request->( ...with options....);
+
+ Everything::HTTP::URL->modify_request( $r->path_info, $e );
+
+ *Everything::HTML::linkNode = Everything::HTTP::URL->create_linknode;
+
+
+}
+
+=head1 DESCRIPTION
+
+As you will have noticed all the methods are class methods. This is because all the variables are class variables and they can be modified in httpd.conf or anywhere. It is also because this class is designed to be subclassed, but also to be able to srote all the url parsers and node to url modifiers in the same place.
+
+=cut
+
+
+
+use strict;
+use warnings;
+
+
+our @node_to_url_subs = ();
+our @request_modifiers = ();
our $default_sub;
sub new {
@@ -20,23 +70,64 @@
}
+=head2 C<< create_url_rule >>
+
+Creates a rule for node to url subs.
+
+Takes two arguments.
+
+The first argument is a call back to check whether this rule applies
+to this node. The call back is passed the node as an argument and should
+return true if this rule applies to the node or false otherwise.
+
+The second argument is a call back that turns a node into a url. It is passed the node as an argument and returns a string which is the path to url.
+
+These two arguments are combined into a code reference which is added to the node_to_url_subs attribute and returned.
+
+=cut
+
+
+sub create_url_rule {
+ my ( $self, $check_node_cb, $make_url_cb ) = @_;
+
+ my $rule = sub {
+ return $make_url_cb->( @_ ) if $check_node_cb->( @_ );
+ return;
+ };
+ push @node_to_url_subs, $rule;
+ return $rule;
+
+}
+
+=head2 C<< create_nodetype_rule >>
+
+Creates a rule to test whether a node is of a certain type, if it is then applies the url creation subroutine supplied by the first argument. The second argument is the type name.
+
+Returns a subroutine reference and pushes it onto the class list of subroutine references that can be retrieved by get_node_to_url_subs.
+
+=cut
+
+
sub create_nodetype_rule {
my ( $self, $sub, $typename ) = @_;
- my $rule = sub {
+ my $select_node = sub {
my $node = shift;
- $node = $self->get_request->get_nodebase->getNode($node)
- unless ref $node;
- my $type = $node->{type};
- return unless $type->{title} eq $typename;
- return $sub->( $node, @_ );
+ return 1 if $node->isa( 'Everything::Node::' . $typename );
+ return;
};
- push @select_node_subs, $rule;
- return $rule;
+ return $self->create_url_rule( $select_node, $sub );
}
+
+=head2 C<< create_linknode >>
+
+Concantenates all the subroutines stored in node_to_url_subs adds the default_sub to the end and returns a code ref. This is supposed to be a replacement for Everything::HTML::linkNode;
+
+=cut
+
sub create_linknode {
my ($self) = @_;
- my @subs = @select_node_subs;
+ my @subs = @node_to_url_subs;
push @subs, $self->get_default_sub if $self->get_default_sub;
my $linknode = sub {
foreach (@subs) {
@@ -48,25 +139,32 @@
}
-sub parse_url {
- my ( $this, $r ) = @_;
- return unless @url_parsers;
+=cut
- my $matches;
- my $node;
- PARSERS:
- foreach (@url_parsers) {
+=head2 C<< modify_request >>
- if ( my $m = $_->match( $r->path_info ) ) {
+Goes throught the parsers one by one in order and modifies the request object. Stops once a parser returns a true value. If a parser returns a false value keeps going.
- ++$matches;
- if ( $node = $_->process ) {
- last PARSERS;
- }
- }
+Takes two argumnets. The first is the url being request, the second is a Everything::HTTP::Request object.
+
+Returns a true value if at least one of the request modifiers was successful.
+
+=cut
+
+sub modify_request {
+ my ( $self, $url, $e ) = @_;
+
+ return unless $self->isset_request_modifiers;
+
+ my $found = 0;
+
+ foreach ( @request_modifiers ) {
+ $found++ if $_->( $url, $e );
+ last if $found;
}
- return $matches if !$node;
- return $node;
+
+ return $found if $found;
+ return;
}
sub set_default_sub {
@@ -81,33 +179,61 @@
}
-sub get_select_node_subs {
+sub get_node_to_url_subs {
- @select_node_subs;
+ @node_to_url_subs;
}
-sub get_select_node_subs_ref {
+sub clear_node_to_url_subs {
- \@select_node_subs;
+ @node_to_url_subs = ();
}
-sub set_select_node_subs {
+sub get_node_to_url_subs_ref {
+ \@node_to_url_subs;
+}
+
+sub set_node_to_url_subs {
+
shift;
- @select_node_subs = @_;
+ @node_to_url_subs = @_;
}
-sub register_url_parser {
+=cut
- push @url_parsers, $_[0];
+=head2 C<< register_request_modifier >>
+Pushs the argument, which must be subroutine reference onto the request_modifiers array.
+
+ The subroutine/argument is passed two arguments, the first is a path from a url the second is a Everything::HTTP::Request instance.
+
+ Should return true if it wants to be the last subroutine run.
+
+=cut
+
+
+sub register_request_modifier {
+
+ push @request_modifiers, $_[1];
+
}
-sub isset_url_parsers {
+sub isset_request_modifiers {
- return 1 if @url_parsers;
+ return 1 if @request_modifiers;
return;
}
+sub get_request_modifiers {
+
+ @request_modifiers;
+}
+
+sub clear_request_modifiers {
+
+ @request_modifiers = ();
+}
+
1;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-01-31 19:52:03
|
Revision: 982
http://everydevel.svn.sourceforge.net/everydevel/?rev=982&view=rev
Author: paul_the_nomad
Date: 2008-01-31 11:51:59 -0800 (Thu, 31 Jan 2008)
Log Message:
-----------
Removing exports and parsing subs from HTML. Improvements to argument
passing for method 'run' for executable nodes
Modified Paths:
--------------
trunk/ebase/lib/Everything/HTML.pm
trunk/ebase/lib/Everything/Node/Runnable.pm
trunk/ebase/lib/Everything/Node/javascript.pm
trunk/ebase/lib/Everything/Test/HTML.pm
Property Changed:
----------------
trunk/ebase/
Property changes on: trunk/ebase
___________________________________________________________________
Name: svk:merge
- 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:982
1fb64b4e-7a8b-4dbf-911a-4b487ccca24f:/wip/ebase:984
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
+ 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:982
1fb64b4e-7a8b-4dbf-911a-4b487ccca24f:/wip/ebase:987
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
Modified: trunk/ebase/lib/Everything/HTML.pm
===================================================================
--- trunk/ebase/lib/Everything/HTML.pm 2007-10-01 15:27:34 UTC (rev 981)
+++ trunk/ebase/lib/Everything/HTML.pm 2008-01-31 19:51:59 UTC (rev 982)
@@ -1,10 +1,8 @@
=head1 Everything::HTML.pm
-Copyright 1999 - 2003 Everything Development Company
+A module which handles html rendering.
-A module for the HTML stuff in Everything. This takes care of CGI, cookies,
-and the basic HTML front end.
=cut
@@ -17,33 +15,10 @@
use CGI;
use CGI::Carp qw(fatalsToBrowser);
-use base 'Exporter';
-our @EXPORT_OK = qw(
- $DB
- %HTMLVARS
- %GLOBAL
- $query
- $AUTH
- newFormObject
- parseLinks
- htmlScreen
- htmlFormatErr
- quote
- urlGen
- getPage
- getPageForType
- linkNode
- linkNodeTitle
- searchForNodeByName
- evalX
- evalXTrapErrors
- htmlcode
- embedCode
- displayPage
- gotoNode
- encodeHTML
- decodeHTML
- mod_perlInit);
+use base 'Class::Accessor::Fast';
+__PACKAGE__->follow_best_practice;
+__PACKAGE__->mk_accessors(
+ qw/htmlpage request/);
our ($AUTH, $DB);
use vars qw( $query $GNODE $NODELET $THEME $USER $VARS %HTMLVARS %INCJS );
@@ -886,98 +861,6 @@
=cut
-=head2 C<searchForNodeByName>
-
-This looks for a node by the given name. If it finds something, it displays
-the node.
-
-=over 4
-
-=item * $node
-
-the string name of the node we are looking for.
-
-=item * $user_id
-
-the user trying to view this node (for authorization)
-
-=back
-
-Returns nothing
-
-=cut
-
-sub searchForNodeByName
-{
- my ( $node, $user_id ) = @_;
-
- my @types = $query->param("type");
- foreach (@types)
- {
- $_ = getId( getType($_) );
- }
-
- my %selecthash = ( title => $node );
- my @selecttypes = @types;
- $selecthash{type_nodetype} = \@selecttypes if @selecttypes;
- my $select_group = selectNodeWhere( \%selecthash );
- my $search_group;
- my $NODE;
-
- my $type = $types[0];
- $type ||= "";
-
- if ( not $select_group or @$select_group == 0 )
- {
-
- # We did not find an exact match, so do a search thats a little
- # more fuzzy.
- $search_group = searchNodeName( $node, \@types );
-
- if ( $search_group && @$search_group > 0 )
- {
- $NODE = getNode( $HTMLVARS{searchResults_node} );
- $GLOBAL{searchgroup} = $search_group;
- }
- else
- {
- $NODE = getNode( $HTMLVARS{notFound_node} );
- }
-
- gotoNode( $NODE, $user_id );
- }
- elsif ( @$select_group == 1 )
- {
-
- # We found one exact match, goto it.
- my $node_id = $$select_group[0];
- gotoNode( $node_id, $user_id );
- return;
- }
- else
- {
- my @canread;
- foreach (@$select_group)
- {
- my $N = getNode $_;
- next unless $N->hasAccess( $USER, 'r' );
- push @canread, $_;
- }
-
- return gotoNode( $HTMLVARS{not_found}, $user_id ) unless @canread;
- return gotoNode( $canread[0], $user_id ) if @canread == 1;
-
- #we found multiple nodes with that name. ick
- my $NODE = getNode( $HTMLVARS{duplicatesFound_node} );
-
- $$NODE{group} = \@canread;
- gotoNode( $NODE, $user_id );
- }
-}
-
-=cut
-
-
=head2 C<evalXTrapErrors>
This is a wrapper for the standard eval. This way we can trap eval errors and
@@ -1139,7 +1022,7 @@
# We can only execute this if the logged in user has execute permissions.
return undef unless ( $CODE->hasAccess( $user, 'x' ) );
- return $CODE->run( undef, $HTMLVARS{noCompile}, @_ );
+ return $CODE->run( { no_cache => $HTMLVARS{noCompile}, args => \@_ } );
}
@@ -1447,7 +1330,7 @@
# User must have execute permissions for this to be embedded.
if ( ( defined $node ) && $node->hasAccess( $USER, "x" ) )
{
- $html = $node->run( 'code' );
+ $html = $node->run( { field => 'code' } );
}
return $html;
}
@@ -1455,277 +1338,7 @@
=cut
-=head2 C<embedCode>
-This takes code in the form of [%...%], [{...}], [E<lt>...E<gt>], or ["..."]
-and evals the internal code.
-
-=over 4
-
-=item * $block
-
-The block of code to eval. It must be of one of the forms described above.
-
-=item * $CURRENTNODE
-
-the node in which this code is coming from. Some code may need to know this
-(nodelets that modify themselves). If not defined, this will default to the
-main node we are trying to display
-
-=back
-
-Returns the eval-ed result of the code.
-
-=cut
-
-sub embedCode
-{
- my ( $block, $CURRENTNODE ) = @_;
-
- my $NODE = $GNODE;
-
- if ( $block =~ /^".*"$/ )
- {
-
- # This is used to eval data that a user may have entered. It is
- # wrapped in quotes so that variables are evaled, but if they
- # contain code, that code is not evaled. This prevents users from
- # hacking the system by having node titles like:
- # $DB->do("drop table nodes")
- $block = evalXTrapErrors( $block . ';', $CURRENTNODE );
- }
- elsif ( $block =~ /^\{(.*)\}$/s )
- {
-
- # This is an htmlcode. We need to construct a function call, and
- # eval it. AUTOLOAD will do the rest.
-
- my ( $func, $args ) = split /\s*:\s*/, $1;
- my @args;
- $args ||= "";
-
- @args = split( /\s*,\s*/, $args ) if ($args);
-
- foreach (@args)
- {
-
- # Wrap each argument in quotes, except those that start with
- # a '$'. This way, global vars can be used in calling htmlcode
- # ie [{mycode: hello, $USER}]
- $_ = "'" . $_ . "'" unless ( $_ =~ /^\$/ );
- }
-
- $args = join( ", ", @args );
-
- my $code = $func . "(" . $args . ");";
- $block = evalXTrapErrors( $code, $CURRENTNODE );
- }
- elsif ( $block =~ /^\%(.*)\%$/s )
- {
- $block = evalXTrapErrors( $1, $CURRENTNODE );
- }
- elsif ( $block =~ /^<(.*)>$/s )
- {
- my $snippet = getNode( $1, "htmlsnippet" );
-
- # User must have execute permissions for this to be embedded.
- if ( ( defined $snippet ) && $snippet->hasAccess( $USER, "x" ) )
- {
- $block = parseCode( 'code', $snippet );
- }
- else
- {
- $block = "";
- }
- }
-
- # Block needs to be defined, otherwise the search/replace regex
- # stuff will break when it gets an undefined return from this.
- $block ||= "";
-
- return $block;
-}
-
-=cut
-
-
-=head2 C<parseCode (new)>
-
-Given the text from a node that is to be displayed, parse out the code blocks,
-compile the whole thing into an anonymous subroutine, cache it, and call it.
-Or call it if it's already compiled. WHOOSH!
-
-NOTE!!! This is a full parse and eval. You do NOT NOT NOT want to call this on
-text that an untrusted user can modify. You don't want users creating nodes
-with [% `rm -rf /*` %] in their code. Calling this on untrusted user text is a
-security breach.
-
-=over 4
-
-=item * $field
-
-the field to be parsed for the code blocks
-
-=item * $CURRENTNODE
-
-the node which this text is coming from.
-
-=back
-
-Returns the parsed HTML with the embedded code parsed and replaced with its
-generated result. Given:
-
- E<lt>pE<gt>Hello ["$$USER{title}"]
-
-Will return:
-
- E<lt>pE<gt>Hello Bob
-
-=cut
-
-sub parseCode
-{
- my ( $field, $CURRENTNODE ) = @_;
-
- if ( ( exists( $HTMLVARS{noCompile} ) and $HTMLVARS{noCompile} )
- or exists( $CURRENTNODE->{DB}->{workspace} ) )
- {
- return oldparseCode( $field, $CURRENTNODE );
- }
-
- my $result = executeCachedCode( $field, $CURRENTNODE );
- return $result if ( defined($result) );
-
- my $args = [];
-
- my $sub_text = ' my $result; ';
-
- # the /s modifier makes . match newlines. VERY important.
- for my $chunk (
- split(
- /(\[(?:\{.*?\}|\".*?\"|%.*?%|<.*?>)\])/s, $$CURRENTNODE{$field}
- )
- )
- {
- next unless $chunk =~ /\S/;
-
- $sub_text .= "\n\t";
- my ( $start, $code, $end );
- if ( ( $start, $code, $end ) =
- $chunk =~ /^\[([%"<{])(.+?)([%">}])\]$/s )
- {
-
- # embedded code
- $code =~ s!"!\"!g;
-
- # htmlcode turns into a function call:
- # ( $htmlcode('arg1', 'arg2') || '')
- if ( $start eq '{' )
- {
- my ( $func, $args ) = split( /\s*:\s*/, $code );
- $sub_text .= "\$result .= ( eval { $func(";
- if ( defined $args )
- {
- my @args = do_args($args);
- $sub_text .= join( ", ", @args ) if (@args);
- }
- $sub_text .= ") } || '' );";
-
- # htmlsnippets turn into simpler function calls:
- # htmlsnippet('snippetname')
- }
- elsif ( $start eq '<' )
- {
- $sub_text .= "\$result .= eval {htmlsnippet('$code')} || '';\n";
-
- # embedded code needs a dedicated block to work unmodified:
- # ( eval { return 'foo'; } || '' )
- }
- elsif ( $start eq '"' or $start eq '%' )
- {
- $sub_text .= "\$result .= ( eval {\n$code\n} || '' );\n";
- }
- $sub_text .= qq|\nlogErrors('', \$\@, '', { title =>
- '\Q$$CURRENTNODE{title}\E', node_id => '$$CURRENTNODE{node_id}' })
- if (\$\@);\n|;
-
- # raw text, needs to be quoted -- the quoting should work correctly
- # as there's no need to escape quotes in raw HTML sections anyway
- }
- else
- {
- next unless ( $chunk =~ /\S/ );
-
- # Use single quotes!!! We need to wrap this chunk of text in
- # single quotes because we do not want perl to be evaluating
- # anything outside our embedded code. If this is wrapped in
- # double quotes, things like \n, \t, $hello, and anything the
- # raw text contained that perl would recognize would be evaled
- # and we don't want that. Raw text is raw text and should
- # be left alone.
- $chunk =~ s!\'!\\'!g;
- $sub_text .= qq|\$result .= '$chunk';\n|;
- }
- }
-
- # add newlines so trailing comments don't cause eval() errors
- $sub_text .= qq|\nreturn \$result;\n|;
-
- $sub_text = createAnonSub($sub_text);
-
- $result = compileCache( $sub_text, $CURRENTNODE, $field, $args );
- return $result if defined $result;
-
- # on failure, use old behavior
- return oldparseCode( $field, $CURRENTNODE );
-}
-
-=cut
-
-
-=head2 C<oldparseCode>
-
-Given the text from a node that is to be displayed, parse out the code blocks
-and eval them. No caching here, plod plod.
-
-=over 4
-
-=item * $field
-
-the field to be parsed for the code blocks
-
-=item * $CURRENTNODE
-
-the node which this text is coming from.
-
-=back
-
-=cut
-
-sub oldparseCode
-{
- my ( $field, $CURRENTNODE ) = @_;
-
- my $text = $$CURRENTNODE{$field};
-
- # the embedding styles are:
- $text =~ s/
- \[
- (
- \{.*?\} # [{ }]s -- calls to the code database
- |".*?" # [" "]s -- embedded code strings
- |%.*?% # [% %]s -- full embedded perl
- |<.*?> # [< >]s -- embedded HTML
- )
- \]
- /embedCode($1,$CURRENTNODE)/egsx;
-
- $text;
-}
-
-=cut
-
-
=head2 C<listCode>
To list code so that it will not be parsed by Everything or the browser
@@ -2012,7 +1625,7 @@
if ($debugcontainer)
{
$GLOBAL{debugContainer} = $CONTAINER;
- my $debugtext = parseCode( 'context', $debugcontainer );
+ my $debugtext = $debugcontainer->run( { field => 'context' });
$debugtext =~ s/CONTAINED_STUFF/$middle/s;
$replacetext = $start . $debugtext . $end;
}
Modified: trunk/ebase/lib/Everything/Node/Runnable.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/Runnable.pm 2007-10-01 15:27:34 UTC (rev 981)
+++ trunk/ebase/lib/Everything/Node/Runnable.pm 2008-01-31 19:51:59 UTC (rev 982)
@@ -10,10 +10,40 @@
use warnings;
+=head2 C<run>
+Compiles, if necessary, and executes the node. It also uses the node caching system to cache the code out put.
+
+It takes one hash ref argument. The hash may take keys as follows:
+
+=over 4
+
+=item field
+
+The field name of the node that contains code we wish to compile and run
+
+=item no_cache
+
+If true the code will not be cached in the node casche
+
+=item args
+
+An array ref of arguments to be passed to the compiled code. The code will fail if it is anything other than an array ref. This is a feature.
+
+=back
+
+Returns whatever the output of the code in the node outputs.
+
+=cut
+
+
sub run {
- my ( $self, $field, $no_cache, @args) = @_;
+ my ( $self, $arg_hash ) = @_;
+ my $field = $$arg_hash{ field };
+ my $no_cache = $$arg_hash{ no_cache };
+ my @args = $$arg_hash{args} ? @{ $$arg_hash{args} } : ();
+
$field ||= $self->get_compilable_field;
if ( $no_cache ) {
Modified: trunk/ebase/lib/Everything/Node/javascript.pm
===================================================================
--- trunk/ebase/lib/Everything/Node/javascript.pm 2007-10-01 15:27:34 UTC (rev 981)
+++ trunk/ebase/lib/Everything/Node/javascript.pm 2008-01-31 19:51:59 UTC (rev 982)
@@ -11,7 +11,7 @@
use strict;
use warnings;
-use base 'Everything::Node::node';
+use base 'Everything::Node::node', 'Everything::Node::Parseable';
=head2 C<dbtables()>
Modified: trunk/ebase/lib/Everything/Test/HTML.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/HTML.pm 2007-10-01 15:27:34 UTC (rev 981)
+++ trunk/ebase/lib/Everything/Test/HTML.pm 2008-01-31 19:51:59 UTC (rev 982)
@@ -478,12 +478,6 @@
}
-sub test_parse_code : Test(1) {
- my $self = shift;
- my $package = $self->{class};
- can_ok( $package, 'parseCode' );
-}
-
sub test_insert_nodelet : Test(2) {
my $self = shift;
my $package = $self->{class};
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-01-31 19:52:19
|
Revision: 983
http://everydevel.svn.sourceforge.net/everydevel/?rev=983&view=rev
Author: paul_the_nomad
Date: 2008-01-31 11:52:16 -0800 (Thu, 31 Jan 2008)
Log Message:
-----------
Change: opcodes only have access to the request object. Updating for new
run method argument passing
Modified Paths:
--------------
trunk/ebase/lib/Everything/HTML.pm
trunk/ebase/lib/Everything/HTTP/CGI.pm
trunk/ebase/lib/Everything/HTTP/Request.pm
Property Changed:
----------------
trunk/ebase/
Property changes on: trunk/ebase
___________________________________________________________________
Name: svk:merge
- 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:982
1fb64b4e-7a8b-4dbf-911a-4b487ccca24f:/wip/ebase:987
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
+ 16c2b9cb-492b-4d64-9535-64d4e875048d:/wip/ebase:1030
1b7afbaf-3eae-422c-ad05-e2bef7c06a0f:/wip/ebase:982
1fb64b4e-7a8b-4dbf-911a-4b487ccca24f:/wip/ebase:988
a6810612-c0f9-0310-9d3e-a9e4af8c5745:/ebase/offline:17930
Modified: trunk/ebase/lib/Everything/HTML.pm
===================================================================
--- trunk/ebase/lib/Everything/HTML.pm 2008-01-31 19:51:59 UTC (rev 982)
+++ trunk/ebase/lib/Everything/HTML.pm 2008-01-31 19:52:16 UTC (rev 983)
@@ -2198,6 +2198,10 @@
#############################################################################
sub opNuke
{
+ my $request = shift;
+ my $query = $request->get_cgi;
+ my $USER = $request->get_user;
+ my %HTMLVARS = %{ $request->get_system_vars };
my $NODE = getNode( $query->param("node_id") );
$NODE->nuke($USER) if ($NODE);
@@ -2212,19 +2216,33 @@
#############################################################################
sub opLogin
{
- ( $USER, $VARS ) = $AUTH->loginUser($query->param('user'),
+ my $request = shift;
+ my $query = $request->get_cgi;
+ my $AUTH = $request->get_authorisation;
+ my ( $USER, $VARS ) = $AUTH->loginUser($query->param('user'),
$query->param('passwd'));
+ $request->set_user( $USER );
+ $request->set_user_vars( $VARS );
}
#############################################################################
sub opLogout
{
- ( $USER, $VARS ) = $AUTH->logoutUser();
+ my $request = shift;
+ my $AUTH = $request->get_authorisation;
+ my ( $USER, $VARS ) = $AUTH->logoutUser();
+ $request->set_user( $USER );
+ $request->set_user_vars( $VARS );
}
#############################################################################
sub opNew
{
+ my $request = shift;
+ my $query = $request->get_cgi;
+ my $USER = $request->get_user;
+ my %HTMLVARS = %{ $request->get_system_vars };
+
my $node_id = 0;
my $user_id = $$USER{node_id};
my $type = $query->param('type');
@@ -2255,6 +2273,10 @@
#############################################################################
sub opUnlock
{
+ my $request = shift;
+ my $query = $request->get_cgi;
+ my $USER = $request->get_user;
+
my $LOCKEDNODE = getNode( $query->param('node_id') );
$LOCKEDNODE->unlock($USER);
}
@@ -2262,6 +2284,10 @@
#############################################################################
sub opLock
{
+ my $request = shift;
+ my $query = $request->get_cgi;
+ my $USER = $request->get_user;
+
my $LOCKEDNODE = getNode( $query->param('node_id') );
$LOCKEDNODE->lock($USER);
}
@@ -2304,6 +2330,11 @@
sub opUpdate
{
+ my $request = shift;
+ my $query = $request->get_cgi;
+ my $USER = $request->get_user;
+ my %HTMLVARS = %{ $request->get_system_vars };
+
my @params = $query->param();
my %UPDATENODES;
my %UPDATEOBJECT;
@@ -2555,147 +2586,4 @@
}
}
-=cut
-
-
-C<updateNodeData>
-
-DEPRECATED!!! DO NOT USE!
-
-If we have a node_id, we may be getting some params that indicate that we
-should be updating the node. This checks for those parameters and updates the
-node if necessary.
-
-=cut
-
-sub updateNodeData
-{
-
- #warn("Using updateNodeData() (deprecated!). Stop that!");
- my $node_id = $query->param('node_id');
-
- return undef unless ($node_id);
-
- my $NODE = getNode($node_id);
- my $updateflag = 0;
-
- return 0 unless ($NODE);
-
- if ( $NODE->hasAccess( $USER, 'w' ) )
- {
- if ( my $groupadd = $query->param('add') )
- {
- $NODE->insertIntoGroup( $USER, $groupadd,
- $query->param('orderby') );
- $updateflag = 1;
- }
-
- if ( $query->param('group') )
- {
- my @newgroup;
- my $counter = 0;
-
- while ( my $item = $query->param( $counter++ ) )
- {
- push @newgroup, $item;
- }
-
- $NODE->replaceGroup( \@newgroup, $USER );
- $updateflag = 1;
- }
-
- my @updatefields = $query->param;
- my $RESTRICT = getNode( 'restricted fields', 'setting' );
- my $RESTRICTED = $RESTRICT->getVars() if ($RESTRICT);
-
- $RESTRICTED ||= {};
- foreach my $field (@updatefields)
- {
- if ( $field =~ /^$$NODE{type}{title}\_(\w*)$/ )
- {
- next if exists $$RESTRICTED{$1};
- $$NODE{$1} = $query->param($field);
- $updateflag = 1;
- }
- }
-
- if ($updateflag)
- {
- $NODE->logRevision($USER) unless exists $DB->{workspace};
- $NODE->update($USER);
-
- # This is the case where the user is modifying their own user
- # node. If we want the user node to take effect in one page
- # load, we need to set it here.
- if ( $$USER{node_id} == $$NODE{node_id} ) { $USER = $NODE; }
- }
- }
-}
-
-=cut
-
-
-=head2 C<mod_perlInit>
-
-This is the "main" function of Everything. This gets called for each page load
-in an Everything system.
-
-=over 4
-
-=item * $db
-
-the string name of the database to get our information from.
-
-=item * $options
-
-optional options, see Everything::initEverything
-
-=back
-
-Returns nothing useful
-
-=cut
-
-sub mod_perlInit
-{
- my ( $db, $options, $initializer ) = @_;
-
- initForPageLoad( $db, $options );
-
- setHTMLVARS();
-
- $query = getCGI($initializer);
-
- $options->{nodebase} = $DB;
-
- $options->{query} = $query;
-
- $AUTH = Everything::Auth->new($options);
-
- ( $USER, $VARS ) = $AUTH->authUser();
-
- # join a workspace (if applicable)
- $DB->joinWorkspace( $$USER{inside_workspace} );
-
- # Execute any operations that we may have
- execOpCode();
-
- #an opcode might have changed our workspace. Join again.
- $DB->joinWorkspace( $$USER{inside_workspace} );
-
- # DEPRECATED! DO NOT USE!
- updateNodeData();
-
- # Do the work.
- handleUserRequest();
-
- # Lastly, set the vars on the user node so that things get saved.
- $USER->setVars( $VARS, $USER );
- $USER->update($USER);
-}
-
-#############################################################################
-# End of package
-#############################################################################
-
1;
Modified: trunk/ebase/lib/Everything/HTTP/CGI.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/CGI.pm 2008-01-31 19:51:59 UTC (rev 982)
+++ trunk/ebase/lib/Everything/HTTP/CGI.pm 2008-01-31 19:52:16 UTC (rev 983)
@@ -24,6 +24,8 @@
## execute options
# Execute any operations that we may have
+ $e->execute_opcodes;
+
$e->set_node_from_cgi;
if ( !$e->get_node ) {
@@ -36,8 +38,6 @@
$e->setup_everything_html;
- $e->execute_opcodes;
-
my $response = Everything::HTTP::ResponseFactory->new( 'htmlpage', $e );
$response->create_http_body;
my $html = $response->get_http_body;
Modified: trunk/ebase/lib/Everything/HTTP/Request.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Request.pm 2008-01-31 19:51:59 UTC (rev 982)
+++ trunk/ebase/lib/Everything/HTTP/Request.pm 2008-01-31 19:52:16 UTC (rev 983)
@@ -140,29 +140,29 @@
if ($opcode) {
- $opcode->run;
+ $opcode->run( { args => [ $self ] } );
}
elsif ( $op eq 'login' ) {
- Everything::HTML::opLogin();
+ Everything::HTML::opLogin( $self );
}
elsif ( $op eq 'logout' ) {
- Everything::HTML::opLogout();
+ Everything::HTML::opLogout( $self );
}
elsif ( $op eq 'nuke' ) {
- Everything::HTML::opNuke();
+ Everything::HTML::opNuke( $self );
}
elsif ( $op eq 'new' ) {
- Everything::HTML::opNew();
+ Everything::HTML::opNew( $self );
}
elsif ( $op eq 'update' ) {
- Everything::HTML::opUpdate();
+ Everything::HTML::opUpdate( $self );
}
elsif ( $op eq 'unlock' ) {
- Everything::HTML::opUnlock();
+ Everything::HTML::opUnlock( $self );
}
elsif ( $op eq 'lock' ) {
- Everything::HTML::opLock();
+ Everything::HTML::opLock( $self );
}
}
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-03-08 10:47:38
|
Revision: 990
http://everydevel.svn.sourceforge.net/everydevel/?rev=990&view=rev
Author: paul_the_nomad
Date: 2008-03-08 02:47:35 -0800 (Sat, 08 Mar 2008)
Log Message:
-----------
Apache tests using the Apache::Test module. Only runs if correct apache is running. Currently
only does some url tests.
Modified Paths:
--------------
trunk/ebase/Build.PL
Added Paths:
-----------
trunk/ebase/t/TEST
trunk/ebase/t/apache-server/
trunk/ebase/t/apache-server/url.t
trunk/ebase/t/conf/
trunk/ebase/t/conf/extra.conf.in
Modified: trunk/ebase/Build.PL
===================================================================
--- trunk/ebase/Build.PL 2008-03-08 10:47:16 UTC (rev 989)
+++ trunk/ebase/Build.PL 2008-03-08 10:47:35 UTC (rev 990)
@@ -49,7 +49,8 @@
'Test::Warn' => 0.10,
'Test::Exception' => 0.13,
'Test::Simple' => 0.47,
- 'Template' => 0,
+ 'Template' => 0,
+ 'Proc::ProcessTable' => 0,
},
scripts => [ File::Spec->catfile( 'bin', 'nbmasta' ) ],
test_files => join( ' ', @test_files ),
Added: trunk/ebase/t/TEST
===================================================================
--- trunk/ebase/t/TEST (rev 0)
+++ trunk/ebase/t/TEST 2008-03-08 10:47:35 UTC (rev 990)
@@ -0,0 +1,7 @@
+#!/usr/bin/perl
+
+use Apache::TestRun;
+use strict;
+use warnings;
+
+Apache::TestRun->new->run( @ARGV );
Property changes on: trunk/ebase/t/TEST
___________________________________________________________________
Name: svn:executable
+ *
Added: trunk/ebase/t/apache-server/url.t
===================================================================
--- trunk/ebase/t/apache-server/url.t (rev 0)
+++ trunk/ebase/t/apache-server/url.t 2008-03-08 10:47:35 UTC (rev 990)
@@ -0,0 +1,43 @@
+
+BEGIN {
+ require 'Test/More.pm';
+ if ( !-e 't/conf/httpd.conf' ) {
+ Test::More->import(
+ skip_all => 'Needs proper apache configuration to run.' );
+ }
+}
+
+use Apache::Test '-withtestmore';
+use Apache::TestRequest qw(GET);
+use Apache::TestUtil;
+use Apache2::Const ':common';
+use Proc::ProcessTable;
+
+use strict;
+use warnings;
+
+my $table = Proc::ProcessTable->new;
+my $conf_file = Apache::Test::vars->{t_conf};
+my $flag =
+ grep { /.*apache.*$conf_file/ } map { $_->cmndline } @{ $table->table };
+
+plan
+ tests => 4,
+ need {
+ "Correct apache process must be running." => sub { $flag }
+ };
+
+my $response = GET '/';
+ok( $response->is_success, '...root directory should return OK.' );
+
+$response = GET '/nonsense/url';
+ok( $response->code == NOT_FOUND, "...doesn't find a non-existing url." );
+
+$response = GET '/?node_id=1';
+ok( $response->is_success, '...if we ask for node 1, get OK response.' );
+
+# test simple
+$response = GET '/node/1';
+ok( $response->is_success,
+ '...if we ask for node 1 with url schema, get OK response.' );
+
Added: trunk/ebase/t/conf/extra.conf.in
===================================================================
--- trunk/ebase/t/conf/extra.conf.in (rev 0)
+++ trunk/ebase/t/conf/extra.conf.in 2008-03-08 10:47:35 UTC (rev 990)
@@ -0,0 +1,12 @@
+<Perl>
+use lib '@SERVERROOT@/../lib';
+</Perl>
+
+SetHandler perl-script
+PerlSetVar everything-database @SERVERROOT@/ecore.db
+PerlSetVar everything-database-options dbtype
+PerlAddVar everything-database-options sqlite
+PerlResponseHandler +Everything::HTTP::Apache
+
+PerlSetVar everything-url /node/:node_id
+PerlAddVar everything-url node
\ No newline at end of file
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-06-22 08:20:18
|
Revision: 1003
http://everydevel.svn.sourceforge.net/everydevel/?rev=1003&view=rev
Author: paul_the_nomad
Date: 2008-06-22 01:20:13 -0700 (Sun, 22 Jun 2008)
Log Message:
-----------
Changes to Everything::Config to allow relative config file names in httpd.conf and to allow relative database names when the
database is sqlite.
Changes to the files used by t/TEST to take advantage of relative file names.
Fixes in CGI.pm to allow for the config system. Also changes to SimpleServer.pm so that that now works with Config.pm.
Modified Paths:
--------------
trunk/ebase/bin/simple-server.pl
trunk/ebase/lib/Everything/CmdLine.pm
trunk/ebase/lib/Everything/Config.pm
trunk/ebase/lib/Everything/HTML.pm
trunk/ebase/lib/Everything/HTTP/CGI.pm
trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm
trunk/ebase/lib/Everything/Storage/Test/Nodeball.pm
trunk/ebase/lib/Everything/Test/Config.pm
trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm
trunk/ebase/lib/Everything/Test/HTML.pm
trunk/ebase/scripts/everything-startup.pl
trunk/ebase/t/conf/extra.conf.in
trunk/ebase/t/lib/everything.conf
Modified: trunk/ebase/bin/simple-server.pl
===================================================================
--- trunk/ebase/bin/simple-server.pl 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/bin/simple-server.pl 2008-06-22 08:20:13 UTC (rev 1003)
@@ -3,15 +3,23 @@
use strict;
use warnings;
use Carp qw/croak confess cluck/;
-use Everything::CmdLine qw/abs_path get_options make_nodebase/;
+use Everything::CmdLine qw/abs_path get_options make_nodebase config/;
use Everything::Test::Ecore::SimpleServer;
-$SIG{__DIE__} =\&confess;
+$SIG{__DIE__} = \&confess;
+
#$SIG{__WARN__} =\&cluck;
$|++;
-my $opts = get_options( undef, [ 'listenport=i'] );
+my $opts = get_options( undef, ['listenport=i'] );
$$opts{type} ||= 'sqlite';
-my $server = Everything::Test::Ecore::SimpleServer->new( { mod_perlInit => ["$$opts{database}:$$opts{user}:$$opts{password}:$$opts{host}", { dbtype => $$opts{type}} ], listenport => $$opts{'listenport'} } );
+
+my $config = config($opts);
+
+my $server = Everything::Test::Ecore::SimpleServer->new( {
+ config => $config,
+ listenport => $$opts{'listenport'}
+}
+);
$server->run;
Modified: trunk/ebase/lib/Everything/CmdLine.pm
===================================================================
--- trunk/ebase/lib/Everything/CmdLine.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/CmdLine.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -1,5 +1,6 @@
package Everything::CmdLine;
+use Everything::Config;
use Getopt::Long;
use Term::ReadKey;
use Cwd;
@@ -8,7 +9,7 @@
use strict;
use warnings;
-our @EXPORT_OK = qw(get_options abs_path usage_options make_nodebase readline_quick confirm_yn);
+our @EXPORT_OK = qw(get_options abs_path usage_options make_nodebase readline_quick confirm_yn config);
Getopt::Long::Configure(qw/bundling/);
@@ -104,6 +105,18 @@
return $nb;
}
+sub config {
+ my ( $arg ) = @_;
+ my $opts = $arg || get_options;
+ my $c = Everything::Config->new;
+ $c->database_name( $$opts{ database } );
+ $c->database_user( $$opts{ user } );
+ $c->database_password( $$opts{ password } );
+ $c->database_host( $$opts{ host } );
+ $c->database_port( $$opts{ port } );
+ $c->database_type( $$opts{ type } );
+ return $c;
+}
sub readline_quick
{
Modified: trunk/ebase/lib/Everything/Config.pm
===================================================================
--- trunk/ebase/lib/Everything/Config.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/Config.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -1,6 +1,8 @@
package Everything::Config;
use AppConfig qw/ :argcount /;
+use File::Spec;
+use File::Basename;
use Everything '$DB';
use Everything::NodeBase;
use Cwd qw/abs_path/;
@@ -28,7 +30,7 @@
my $config = AppConfig->new;
foreach (
- qw/database_name database_user database_password database_host database_type/
+ qw/database_name database_user database_password database_host database_port database_type/
)
{
$config->define( $_, { DEFAULT => '', ARGCOUNT => ARGCOUNT_ONE } );
@@ -58,15 +60,19 @@
my $r = $self->get_apache_request;
if ( ! $file && $r ) {
- $file = $r->dir_config->get('everything-config-file');
+ my $f = $r->dir_config->get('everything-config-file');
+ my $base = Apache2::ServerUtil::server_root();
+ $file = File::Spec->rel2abs( $f, $base );
+
}
## first the file
- $config->file( abs_path( $file ) ) if $file;
+ $config->file( $file ) if $file;
+ make_db_path_absolute( $config, ( fileparse( $file ) )[1] ) if $file;
+
## now apache request
- read_apache_request( $config, $self->get_apache_request )
- if $self->get_apache_request;
+ read_apache_request( $config, $r ) if $r;
$self->set( \@config, $config );
@@ -74,13 +80,23 @@
}
}
+
+sub make_db_path_absolute {
+
+ my ( $config, $base ) = @_;
+ return unless $config->get('database_type') eq 'sqlite';
+ my $db_name = File::Spec->rel2abs( $config->get('database_name'), $base );
+ $config->set('database_name', $db_name );
+
+}
+
sub read_apache_request {
my ( $config, $r ) = @_;
my $apr_table = $r->dir_config;
foreach (
- qw/database_name database_user database_password database_host database_type/
+ qw/database_name database_user database_password database_host database_port database_type/
) {
my $attribute = $_;
$attribute =~ s/_/\-/;
@@ -88,17 +104,9 @@
my $value = $apr_table->get( $attribute );
$config->set( $_, $value ) if $value;
}
-# $config->set( 'database_name',
-# $apr_table->get('everything-database-name') || '' );
-# $config->set( 'database_user',
-# $apr_table->get('everything-database-user') || '' );
-# $config->set( 'database_password',
-# $apr_table->get('everything-database-password') || '' );
-# $config->set( 'database_host',
-# $apr_table->get('everything-database-host') || '' );
-# $config->set( 'database_type',
-# $apr_table->get('everything-database-type') || '' );
+ make_db_path_absolute( $config, Apache2::ServerUtil::server_root() );
+
}
@@ -261,7 +269,9 @@
=item database_name
-The name of the database
+The name of the database. In the case of sqlite, this is a file
+name. A relative path may be specified, in which case it is relative
+to the location of the config file.
=item database_user
@@ -275,6 +285,10 @@
The host
+=item database_port
+
+The port to which to connect to the database.
+
=item database_type
The type of the database we will connect to must be 'mysql', 'sqlite' or 'Pg' without the quotes.
@@ -316,6 +330,14 @@
Where C< /schema/type > is the schema and C<nodetypename> is the nodetype.
+=item location_code
+
+There may be more than one of these. This is perl code that must be
+able to eval'd as an anonymous subroutine. It will be passed one
+argument, a node object, and should return the local url location of
+that node, say, for example, C</node/nodeid>.
+
+
=back
@@ -333,11 +355,12 @@
=item everything-config-file
-Name of the config file
+Name of the config file. If a relative path, it must be relative to
+value set by Apache's ServerRoot directive.
=item everything-database-name
-Database name to connect to
+Database name to connect to. If the database type is 'sqlite', this is a file name which may be relative to the Apache directive C<ServerRoot>.
=item everything-database-user
@@ -347,6 +370,14 @@
The database password for the above mentioned user
+=item everything-database-host
+
+The host
+
+=item everything-database-port
+
+The port
+
=item everything-database-type
The type of database "mysql", "Pg" or "sqlite".
Modified: trunk/ebase/lib/Everything/HTML.pm
===================================================================
--- trunk/ebase/lib/Everything/HTML.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/HTML.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -646,7 +646,11 @@
my $scripts = handle_scripts($SCRIPTS);
my $node_location = $self->node_location( $NODE );
- $$PARAMS{node_id} = $NODE->{node_id} unless $node_location;
+
+ if ( ! $node_location ) {
+ $$PARAMS{node_id} = $NODE->{node_id};
+ $node_location = '/';
+ }
$link = "<a href=" . $self->url_gen($PARAMS, undef, $node_location) . $tags;
$link .= " " . $scripts if ( $scripts ne "" );
Modified: trunk/ebase/lib/Everything/HTTP/CGI.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/CGI.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/HTTP/CGI.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -41,7 +41,7 @@
my $response = Everything::HTTP::ResponseFactory->new( 'htmlpage', $e );
$response->create_http_body;
my $html = $response->get_http_body;
- my $header = $e->http_header( $response->get_mime_type );
+ my $header = $e->http_header( $response->content_type );
$e->get_cgi->print($header);
$e->get_cgi->print($html);
Modified: trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -33,7 +33,10 @@
my $config = $$args{ config };
my $ehtml = Everything::HTML->new;
- $ehtml->set_node_locators( $config->node_locations );
+ if ( $config ) {
+ $ehtml->set_node_locators( $config->node_locations );
+ }
+
$self->getTheme( $self->get_request );
$ehtml->set_request( $self->get_request );
Modified: trunk/ebase/lib/Everything/Storage/Test/Nodeball.pm
===================================================================
--- trunk/ebase/lib/Everything/Storage/Test/Nodeball.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/Storage/Test/Nodeball.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -8,7 +8,7 @@
use File::Temp;
use File::Path;
use File::Find;
-use Archive::Tar;
+#use Archive::Tar;
use IO::File;
use SQL::Statement;
use Cwd;
@@ -16,10 +16,12 @@
use warnings;
sub startup : Test(+1) {
+
+ ### use-ing Archive::Tar causes a seg fault. Bug in perl 5.10??
+ require 'Archive/Tar.pm';
my $self = shift;
$self->SUPER::startup;
my $instance = $self->{class}->new;
-
my ( $test_nodeball_d, $test_nodeball ) = $self->make_test_nodeball;
$self->{test_nodeball_d} = $test_nodeball_d;
$self->{test_nodeball} = $test_nodeball;
Modified: trunk/ebase/lib/Everything/Test/Config.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/Config.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/Test/Config.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -4,8 +4,9 @@
use SUPER;
use Test::More;
use Test::MockObject;
+use File::Basename;
+use File::Spec;
use File::Temp qw/:seekable/;
-#use Everything::Config;
use strict;
use warnings;
@@ -205,4 +206,41 @@
is ( $inst->database_type, '', '...database type defaults to empty string.');
}
+sub test_sqlite_file_paths : Test(2) {
+
+ my $self = shift;
+ my $fh = File::Temp->new();
+ print $fh <<HERE;
+database_name = sqlite_db
+database_type = sqlite
+HERE
+
+ $fh->seek( 0, SEEK_SET );
+ my $inst = $self->{class}->new( file => "$fh" );
+ my $path = ( fileparse("$fh") )[1];
+ is(
+ $inst->get_config->get('database_name'),
+ File::Spec->catfile( $path, 'sqlite_db' ),
+ '...makes sqlite file name absolute.'
+ );
+
+ my $mock = Test::MockObject->new;
+ $mock->set_always( dir_config => $mock );
+ $mock->set_series( get => 'apache_sqlite_db', '', '', '', 'sqlite' );
+
+ local *Apache2::ServerUtil::server_root;
+ *Apache2::ServerUtil::server_root =
+ sub { File::Spec->catfile( File::Spec->rootdir, qw/blah blah blah/ ) };
+
+ $fh->seek( 0, SEEK_SET );
+ $inst = $self->{class}->new( file => "$fh", apache_request => $mock );
+ is(
+ $inst->get_config->get('database_name'),
+ File::Spec->catfile(
+ File::Spec->rootdir, qw/blah blah blah apache_sqlite_db/
+ ),
+ '...makes sqlite file name, set in httpd.conf absolute.'
+ );
+}
+
1;
Modified: trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/Test/Ecore/SimpleServer.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -12,6 +12,7 @@
my $port = $$args{listenport};
my $self = $class->SUPER($port);
$self->{mod_perlInit} = $$args{mod_perlInit};
+ $self->{config} = $$args{config};
## to deal with unwanted behaviour
$Everything::commandLine = 0;
@@ -28,9 +29,9 @@
local *Everything::HTML::getCGI;
*Everything::HTML::getCGI = sub { $cgi };
- my $args = $self->{mod_perlInit};
+ my $args = $self->{config};
- Everything::HTTP::CGI->handle( @$args );
+ Everything::HTTP::CGI->handle( $args );
}
Modified: trunk/ebase/lib/Everything/Test/HTML.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/HTML.pm 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/lib/Everything/Test/HTML.pm 2008-06-22 08:20:13 UTC (rev 1003)
@@ -144,15 +144,15 @@
$mock->{title} = "Random node";
$m->set_always( getNode => $mock );
- is( $inst->link_node(1), '<a href="?node_id=111">Random node</a>', "linkNode" );
+ is( $inst->link_node(1), '<a href="/?node_id=111">Random node</a>', "linkNode" );
$mock->{node_id} = 222;
$mock->{title} = "Another Random Node";
- is( $inst->link_node($mock), '<a href="?node_id=222">Another Random Node</a>',
+ is( $inst->link_node($mock), '<a href="/?node_id=222">Another Random Node</a>',
"linkNode" );
is( $inst->link_node( $mock, "Different Title" ),
- '<a href="?node_id=222">Different Title</a>', "linkNode" );
+ '<a href="/?node_id=222">Different Title</a>', "linkNode" );
is( $inst->link_node( $mock, "Different Title", { op => 'hello' } ),
- '<a href="?node_id=222;op=hello">Different Title</a>', "linkNode" );
+ '<a href="/?node_id=222;op=hello">Different Title</a>', "linkNode" );
is(
$inst->link_node(
@@ -161,7 +161,7 @@
{ op => 'hello' },
{ style => "Foo: bar" }
),
- '<a href="?node_id=222;op=hello" style="Foo: bar">Different Title</a>',
+ '<a href="/?node_id=222;op=hello" style="Foo: bar">Different Title</a>',
"linkNode"
);
@@ -179,7 +179,7 @@
$mock->{title} = "Random node";
$m->set_always( getNode => $mock );
- is( $inst->link_node(1), '<a href="?node_id=111">Random node</a>', "...if no location returns node_id as param." );
+ is( $inst->link_node(1), '<a href="/?node_id=111">Random node</a>', "...if no location returns node_id as param." );
$inst->set_node_locators ( [ sub{ '/a/location' } ] );
is( $inst->link_node(1), '<a href="/a/location">Random node</a>', "...if location returns location" );
Modified: trunk/ebase/scripts/everything-startup.pl
===================================================================
--- trunk/ebase/scripts/everything-startup.pl 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/scripts/everything-startup.pl 2008-06-22 08:20:13 UTC (rev 1003)
@@ -7,9 +7,9 @@
use Everything::Node::setting ();
use Everything::HTTP::Request ();
use Everything::HTTP::Apache ();
-use Everything::HTTP::URL ();
-use Everything::HTTP::URL::Deconstruct ();
+use Everything::Config ();
use Everything::CacheQueue ();
+use Apache::DBI;
use Everything::NodeCache ();
use Carp;
Modified: trunk/ebase/t/conf/extra.conf.in
===================================================================
--- trunk/ebase/t/conf/extra.conf.in 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/t/conf/extra.conf.in 2008-06-22 08:20:13 UTC (rev 1003)
@@ -3,10 +3,5 @@
</Perl>
SetHandler perl-script
-PerlSetVar everything-config-file @SERVERROOT@/lib/everything.conf
-PerlSetVar everything-database-name @SERVERROOT@/ecore.db
-PerlSetVar everything-database-type sqlite
+PerlSetVar everything-config-file lib/everything.conf
PerlResponseHandler +Everything::HTTP::Apache
-
-#PerlSetVar everything-url /node/:node_id
-#PerlAddVar everything-url node
Modified: trunk/ebase/t/lib/everything.conf
===================================================================
--- trunk/ebase/t/lib/everything.conf 2008-06-15 13:20:32 UTC (rev 1002)
+++ trunk/ebase/t/lib/everything.conf 2008-06-22 08:20:13 UTC (rev 1003)
@@ -1,5 +1,6 @@
+database_name = ../ecore.db
+database_type = sqlite
-
location_schema_nodetype = /node/:node_id node
request_modifier_code = <<"FOOFOO"
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-06-23 08:30:48
|
Revision: 1005
http://everydevel.svn.sourceforge.net/everydevel/?rev=1005&view=rev
Author: paul_the_nomad
Date: 2008-06-23 01:30:43 -0700 (Mon, 23 Jun 2008)
Log Message:
-----------
Methods in NodeBase.pm that govern the insertion, deletion, retrieval and counting of links.
Modified Paths:
--------------
trunk/ebase/TODO
trunk/ebase/lib/Everything/NodeBase.pm
trunk/ebase/lib/Everything/Test/NodeBase.pm
Modified: trunk/ebase/TODO
===================================================================
--- trunk/ebase/TODO 2008-06-22 08:21:12 UTC (rev 1004)
+++ trunk/ebase/TODO 2008-06-23 08:30:43 UTC (rev 1005)
@@ -42,8 +42,6 @@
** removing sql tables from nodeballs
** allowing schemae that are optimised for each of the databases
-* Add nodebase.pm methods to allow retrieval of links
-
* Allow retrieval of objects other than nodes from the DB e.g. links
This may involve creating objects that are a superclass of nodes,
Modified: trunk/ebase/lib/Everything/NodeBase.pm
===================================================================
--- trunk/ebase/lib/Everything/NodeBase.pm 2008-06-22 08:21:12 UTC (rev 1004)
+++ trunk/ebase/lib/Everything/NodeBase.pm 2008-06-23 08:30:43 UTC (rev 1005)
@@ -766,4 +766,220 @@
}
+
+=head2 C<retrieve_links>
+
+Retrieves 'links' from the database. It takes one argument which is a
+hash ref. This hash ref provides the search criteria to return
+links. It may have the following keys:
+
+=over 4
+
+=item from_node
+
+The node being linked from
+
+
+=item to_node
+
+The node being linked to
+
+=item linktype
+
+The type of link.
+
+=back
+
+Returns an array of hash refs.
+
+=cut
+
+sub retrieve_links {
+
+ my ( $self, $args ) = @_;
+
+ my @column_names = keys %$args;
+ my $where = join ' AND ', map "$_ = ?", @column_names;
+
+ my $cursor = $self->sqlSelectMany( "from_node, to_node, linktype, hits, food", 'links', $where, undef, [ @$args{ @column_names } ] );
+
+ my @results = ();
+
+ while (my $link = $cursor->fetchrow_hashref) {
+ push @results, $link;
+ }
+
+ return \@results;
+}
+
+
+=head2 C<retrieve_nodes_linked>
+
+Retrieves 'links' from the database. It takes two compulsory
+arguments and a third optional one:
+
+=over 4
+
+=item direction
+
+The first argument must be the word 'to' or the word 'from' indicating
+whether we are searching for nodes linking to or nodes linking from.
+
+=item node
+
+This is a node being linked to or from
+
+=item arg_hash
+
+This argument is optional. It must be a hashref containing arguments
+that are passed directly to C<retrieve_links>.
+
+=back
+
+Returns an array ref of node objects.
+
+=cut
+
+sub retrieve_nodes_linked {
+ my ( $self, $direction, $node, $args ) = @_;
+
+ $args ||= {};
+ $$args{ $direction . '_node' } = $node->get_node_id;
+ my $links = $self->retrieve_links( $args );
+
+ my @nodes = ();
+ my $wanted_direction = $direction eq 'to' ? 'from_node' : 'to_node';
+ foreach ( @$links ) {
+ my $node = $self->getNode( $_->{ $wanted_direction } );
+ push @nodes, $node;
+ }
+
+ return \@nodes;
+}
+
+=head2 C<total_links>
+
+Counts the number of 'links' in the database. It takes one argument which is a
+hash ref. This hash ref provides the search criteria to return
+links. It may have the following keys:
+
+=over 4
+
+=item from_node
+
+The node being linked from. This may be a node object or a node id.
+
+
+=item to_node
+
+The node being linked to. This may be a node object or a node id.
+
+=item linktype
+
+The type of link.
+
+=back
+
+Returns an integer. May possibly return '0 but true', so you should
+use a numeric test if you want to test for the absence of links.
+
+=cut
+
+sub total_links {
+ my ( $self, $args ) = @_;
+
+ foreach (qw/from_node to_node/) {
+ $$args{ $_ } = $$args{ $_ }->get_node_id if ref $$args{ $_ };
+ }
+
+ my @column_names = keys %$args;
+ my $where = join ' AND ', map "$_ = ?", @column_names;
+
+ $self->sqlSelect( 'count(1)', 'links', $where, undef, [ @$args{ @column_names } ] );
+
+}
+
+
+=head2 C<insert_link>
+
+Inserts a link into the database. Takes one argument, a hash ref
+whose keys are the attribute names of the new link. The keys may be:
+
+=over 4
+
+=item from_node
+
+The node being linked from. This may be a node object or a node id.
+
+
+=item to_node
+
+The node being linked to. This may be a node object or a node id.
+
+=item linktype
+
+The type of link.
+
+=back
+
+Returns true on success.
+
+=cut
+
+sub insert_link {
+
+ my ( $self, $args ) = @_;
+
+ foreach (qw/from_node to_node/) {
+ $$args{ $_ } = $$args{ $_ }->get_node_id if ref $$args{ $_ };
+ }
+
+ $self->sqlInsert( 'links', $args );
+}
+
+
+=head2 C<delete_links>
+
+Deletes one or several links from the database. It takes one argument
+which is a hash ref. This hash ref provides the search criteria
+(i.e. the 'where' clause) that governs what link(s) are deleted. The
+hash ref may have the following keys:
+
+=over 4
+
+=item from_node
+
+The node being linked from
+
+
+=item to_node
+
+The node being linked to
+
+=item linktype
+
+The type of link.
+
+=back
+
+Returns true on success.
+
+=cut
+
+sub delete_links {
+
+ my ( $self, $args ) = @_;
+
+ foreach (qw/from_node to_node/) {
+ $$args{ $_ } = $$args{ $_ }->get_node_id if ref $$args{ $_ };
+ }
+
+ my @column_names = keys %$args;
+ my $where = join ' AND ', map "$_ = ?", @column_names;
+
+ $self->sqlDelete( 'links', $where, [ @$args{ @column_names } ] );
+}
+
+
+
1;
Modified: trunk/ebase/lib/Everything/Test/NodeBase.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/NodeBase.pm 2008-06-22 08:21:12 UTC (rev 1004)
+++ trunk/ebase/lib/Everything/Test/NodeBase.pm 2008-06-23 08:30:43 UTC (rev 1005)
@@ -569,4 +569,103 @@
is( join( '', @$found ), '123', '... and should return results' );
}
+sub test_retrieve_links : Test(4) {
+ my $self = shift;
+
+ my $inst = $self->{ nb };
+ my $mock = Test::MockObject->new;
+
+ $inst->set_always( sqlSelectMany => $mock );
+ $mock->set_series( fetchrow_hashref => { qw/key1 value1 key2 value2/ }, undef );
+
+ my %arg_hash = (to_node => 1, from_node => 2, linktype => 3 );
+ my %hash_arg = reverse %arg_hash;
+
+ ok( my $rv = $inst->retrieve_links( \%arg_hash ), '...retrieve_links works ok');
+
+ my ( $method, $args ) = $inst->next_call;
+ is( $method, 'sqlSelectMany', '...calls DB function.' );
+ my @values = @{ $$args[5] };
+ my $where = join ' AND ', map "$_ = ?", @hash_arg{ @values };
+ is( $$args[3], $where, '... constructs where clause.');
+ is_deeply( $rv, [ { key1 => 'value1', key2 => 'value2' } ], '...returns an array ref of hash refs.');
+}
+
+sub test_retrieve_nodes_linked : Test( 9 ) {
+
+ my $self = shift;
+ my $inst = $self->{ nb };
+ $inst->set_always( retrieve_links => [ {from_node => 'from', to_node => 'to' } ] );
+
+ my $mock = Test::MockObject->new;
+ $mock->set_always( get_node_id => 999 );
+ $inst->set_always( getNode => $mock );
+ my $rv = $inst->retrieve_nodes_linked( 'to', $mock );
+ is_deeply( $rv, [ $mock ], '...returns an array of nodes.');
+ my( $method, $args ) = $inst->next_call;
+ is( $method, 'retrieve_links', '...calls retrieve links.');
+ is_deeply( $$args[1], { to_node => 999 }, '...with to_node arg_hash.');
+ ( $method, $args ) = $inst->next_call;
+ is( $method, 'getNode', '...retrieves nodes.');
+ is( $$args[1], 'from', '...using the from_node value.');
+
+ $inst->retrieve_nodes_linked( 'from', $mock );
+ ( $method, $args ) = $inst->next_call;
+ is( $method, 'retrieve_links', '...calls retrieve links.');
+ is_deeply( $$args[1], { from_node => 999 }, '...with from_node arg_hash.');
+ ( $method, $args ) = $inst->next_call;
+ is( $method, 'getNode', '...retrieves nodes.');
+ is( $$args[1], 'to', '...using the to_node value.');
+
+}
+
+sub test_total_links : Test(2) {
+ my $self = shift;
+
+ my $inst = $self->{ nb };
+ my $mock = Test::MockObject->new;
+
+ $inst->set_always( sqlSelect => 2 );
+
+ my %arg_hash = (to_node => 1, from_node => 2, linktype => 3 );
+ my %hash_arg = reverse %arg_hash;
+
+ $inst->total_links( \%arg_hash );
+
+ my ( $method, $args ) = $inst->next_call;
+ is( $method, 'sqlSelect', '...calls DB function.' );
+ my @values = @{ $$args[5] };
+ my $where = join ' AND ', map "$_ = ?", @hash_arg{ @values };
+ is( $$args[3], $where, '... constructs where clause.');
+
+}
+
+sub test_delete_links : Test( 2 ) {
+ my $self = shift;
+
+ my $inst = $self->{ nb };
+ my $mock = Test::MockObject->new;
+
+ $inst->set_always( sqlDelete => 2 );
+
+ $mock->set_series( get_node_id => 1, 2 );
+
+ ## setting mocks here and manipulating arg_hash to know that we
+ ## can pass nodes rather than just node_ids
+
+ my %arg_hash = (to_node => $mock, from_node => $mock, linktype => 3 );
+ $inst->delete_links( \%arg_hash );
+ $arg_hash{to_node} = 2;
+ $arg_hash{from_node} = 1;
+
+ my %hash_arg = reverse %arg_hash;
+
+ my ( $method, $args ) = $inst->next_call;
+ is( $method, 'sqlDelete', '...calls DB function.' );
+ my @values = @{ $$args[3] };
+ my $where = join ' AND ', map "$_ = ?", @hash_arg{ @values };
+ is( $$args[2], $where, '... constructs where clause.');
+
+}
+
1;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-06-24 15:52:26
|
Revision: 1006
http://everydevel.svn.sourceforge.net/everydevel/?rev=1006&view=rev
Author: paul_the_nomad
Date: 2008-06-24 08:52:14 -0700 (Tue, 24 Jun 2008)
Log Message:
-----------
FIXES:
NodeBase.pm/DB.pm - loadNodetypeModules had a hard to reproduce bug. This was caused by loading a nodetype module before the nodetype
module itself was loaded. The bug would only appear when the DB backend returned nodetype names (fetched by
fetch_all_nodetype_names) in an order that put the nodetype nodetype after other nodetypes. Because nodetype has the lowest
node_id 'ORDER BY node_id' fixes this.
Pg.pm - postgresql SQL assumes that anything quoted in double quotes is a column name. Literal values should use single quotes. Additional type
checking added in addFieldToTable so that if we pass an empty string as a default it is changed to '0' for default.
Build.PL - Test suite uses features only available in File::Temp 0.18 and later.
Modified Paths:
--------------
trunk/ebase/Build.PL
trunk/ebase/lib/Everything/DB/Pg.pm
trunk/ebase/lib/Everything/DB/Test/Pg.pm
trunk/ebase/lib/Everything/DB.pm
trunk/ebase/lib/Everything/NodeBase.pm
trunk/ebase/lib/Everything/Test/DB.pm
Modified: trunk/ebase/Build.PL
===================================================================
--- trunk/ebase/Build.PL 2008-06-23 08:30:43 UTC (rev 1005)
+++ trunk/ebase/Build.PL 2008-06-24 15:52:14 UTC (rev 1006)
@@ -51,6 +51,7 @@
'Test::Simple' => 0.47,
'Template' => 0,
'Proc::ProcessTable' => 0,
+ 'File::Temp' => 0.18,
},
scripts => [ File::Spec->catfile( 'bin', 'nbmasta' ) ],
test_files => join( ' ', @test_files ),
Modified: trunk/ebase/lib/Everything/DB/Pg.pm
===================================================================
--- trunk/ebase/lib/Everything/DB/Pg.pm 2008-06-23 08:30:43 UTC (rev 1005)
+++ trunk/ebase/lib/Everything/DB/Pg.pm 2008-06-24 15:52:14 UTC (rev 1006)
@@ -246,61 +246,52 @@
# Returns
# 1 if successful, 0 if failure.
#
-sub addFieldToTable
-{
- my ( $this, $table, $fieldname, $type, $primary, $default ) = @_;
- my $sql;
+sub addFieldToTable {
+ my ( $this, $table, $fieldname, $type, $primary, $default ) = @_;
+ my $sql;
- return 0 if ( ( $table eq "" ) || ( $fieldname eq "" ) || ( $type eq "" ) );
+ return 0 if ( ( $table eq "" ) || ( $fieldname eq "" ) || ( $type eq "" ) );
- if ( not defined $default )
- {
- if ( $type =~ /^int/i )
- {
- $default = 0;
- }
- else
- {
- $default = "";
- }
- }
- elsif ( $type =~ /^text/i )
- {
+ if ( ( ( not defined($default) ) || ( $default eq '' ) )
+ && ( $type =~ /^int/i || $type =~ /(?:big)|(?:small)int/i ) )
+ {
+ $default = 0;
+ }
- # Text blobs cannot have default strings. They need to be empty.
- $default = "";
- }
+ elsif ( ( not defined($default) ) && $type =~ /^text/i ) {
- $sql = "alter table \"$table\" add $fieldname $type";
- $sql .= " default \"$default\" not null";
+ # Text blobs cannot have default strings. They need to be empty.
+ $default = "";
+ }
- $this->{dbh}->do($sql);
+ $sql = "alter table \"$table\" add $fieldname $type";
+ $sql .= " default '$default' not null";
- if ($primary)
- {
+ $this->{dbh}->do($sql);
- # This requires a little bit of work. We need to figure out what
- # primary keys already exist, drop them, and then add them all
- # back in with the new key.
- my @fields = $this->getFieldsHash($table);
- my @prikeys;
- my $primaries;
- my $field;
+ if ($primary) {
- foreach $field (@fields)
- {
- push @prikeys, $$field{Field} if ( $$field{Key} eq "PRI" );
- }
+ # This requires a little bit of work. We need to figure out what
+ # primary keys already exist, drop them, and then add them all
+ # back in with the new key.
+ my @fields = $this->getFieldsHash($table);
+ my @prikeys;
+ my $primaries;
+ my $field;
- $this->{dbh}->do("alter table \"$table\" drop primary key")
- if ( @prikeys > 0 );
+ foreach $field (@fields) {
+ push @prikeys, $$field{Field} if ( $$field{Key} eq "PRI" );
+ }
- push @prikeys, $fieldname; # add the new field to the primaries
- $primaries = join ',', @prikeys;
- $this->{dbh}->do("alter table \"$table\" add primary key($primaries)");
- }
+ $this->{dbh}->do("alter table \"$table\" drop primary key")
+ if ( @prikeys > 0 );
- return 1;
+ push @prikeys, $fieldname; # add the new field to the primaries
+ $primaries = join ',', @prikeys;
+ $this->{dbh}->do("alter table \"$table\" add primary key($primaries)");
+ }
+
+ return 1;
}
#############################################################################
Modified: trunk/ebase/lib/Everything/DB/Test/Pg.pm
===================================================================
--- trunk/ebase/lib/Everything/DB/Test/Pg.pm 2008-06-23 08:30:43 UTC (rev 1005)
+++ trunk/ebase/lib/Everything/DB/Test/Pg.pm 2008-06-24 15:52:14 UTC (rev 1006)
@@ -37,7 +37,7 @@
sub test_fetch_all_nodetype_names : Test(+0) {
my $self = shift;
- $self->add_expected_sql('SELECT title FROM "node" WHERE type_nodetype=1 ');
+ $self->add_expected_sql('SELECT title FROM "node" WHERE type_nodetype=1 ORDER BY node_id');
$self->SUPER;
}
@@ -274,7 +274,7 @@
}
-sub test_add_field_to_table : Test(22) {
+sub test_add_field_to_table : Test(25) {
my $self = shift;
$self->{instance}->{dbh}
->set_always( 'prepare_cached', $self->{instance}->{dbh} );
@@ -307,22 +307,42 @@
);
like(
$args->[1],
- qr/default "" not null/,
+ qr/default '' not null/,
'... with a blank default for text fields'
);
+
$self->{instance}->addFieldToTable( 't', 'f', 'int', 0 );
( $method, $args ) = $self->{instance}->{dbh}->next_call();
like(
$args->[1],
- qr/default "0" not null/,
+ qr/default '0' not null/,
'... a zero default for int fields'
);
$self->{instance}->{dbh}->clear;
+
+ $self->{instance}->addFieldToTable( 't', 'f', 'bigint', 0 );
+ ( $method, $args ) = $self->{instance}->{dbh}->next_call();
+ like(
+ $args->[1],
+ qr/default '0' not null/,
+ '... a zero default for bigint fields'
+ );
+ $self->{instance}->{dbh}->clear;
+
+ $self->{instance}->addFieldToTable( 't', 'f', 'smallint', 0 );
+ ( $method, $args ) = $self->{instance}->{dbh}->next_call();
+ like(
+ $args->[1],
+ qr/default '0' not null/,
+ '... a zero default for smallint fields'
+ );
+ $self->{instance}->{dbh}->clear;
+
$self->{instance}->addFieldToTable( 't', 'f', 'something else', 0 );
( $method, $args ) = $self->{instance}->{dbh}->next_call();
like(
$args->[1],
- qr/default "" not null/,
+ qr/default '' not null/,
'... a blank default for all other fields'
);
@@ -333,10 +353,21 @@
( $method, $args ) = $self->{instance}->{dbh}->next_call();
like(
$args->[1],
- qr/default "default" not null/,
+ qr/default 'default' not null/,
'... and the given default, if given'
);
+ $self->{instance}->{dbh}->clear;
+ $self->{instance}->{dbh}->set_series( 'fetchrow_hashref', @$fields );
+ $self->{instance}
+ ->addFieldToTable( 't', 'f', 'smallint', 0, '' );
+ ( $method, $args ) = $self->{instance}->{dbh}->next_call();
+ like(
+ $args->[1],
+ qr/default '0' not null/,
+ '... default moved to 0 if empty string and type is int.'
+ );
+
$self->{instance}->{dbh}->clear();
$self->{instance}
->addFieldToTable( 't', 'f', 'something else', 1, 'default' );
@@ -344,7 +375,7 @@
is( $method, 'do', '... for table' );
is(
$args->[1],
- 'alter table "t" add f something else default "default" not null',
+ q|alter table "t" add f something else default 'default' not null|,
'... makes some sql to amend a table.'
);
Modified: trunk/ebase/lib/Everything/DB.pm
===================================================================
--- trunk/ebase/lib/Everything/DB.pm 2008-06-23 08:30:43 UTC (rev 1005)
+++ trunk/ebase/lib/Everything/DB.pm 2008-06-24 15:52:14 UTC (rev 1006)
@@ -25,15 +25,17 @@
=head2 C<fetch_all_nodetype_names()>
-This method returns a list of the names of all nodetypes in the system.
+This method returns a list of the names of all nodetypes in the system. Takes an optional argument, which is text passed to sqlSelectMany.
=cut
sub fetch_all_nodetype_names
{
- my $self = shift;
- my $csr = $self->sqlSelectMany( 'title', 'node', 'type_nodetype=1' );
+ my ( $self, $order_by ) = @_;
+ $order_by ||= 'ORDER BY node_id';
+ my $csr = $self->sqlSelectMany( 'title', 'node', 'type_nodetype=1', $order_by );
+
return unless $csr;
my @modules;
Modified: trunk/ebase/lib/Everything/NodeBase.pm
===================================================================
--- trunk/ebase/lib/Everything/NodeBase.pm 2008-06-23 08:30:43 UTC (rev 1005)
+++ trunk/ebase/lib/Everything/NodeBase.pm 2008-06-24 15:52:14 UTC (rev 1006)
@@ -165,7 +165,7 @@
my %modules;
- for my $nodetype ( $self->{storage}->fetch_all_nodetype_names() )
+ for my $nodetype ( $self->{storage}->fetch_all_nodetype_names( 'ORDER BY node_id' ) )
{
my $module = "Everything::Node::$nodetype";
if ($self->loadNodetypeModule( $module ) ){
Modified: trunk/ebase/lib/Everything/Test/DB.pm
===================================================================
--- trunk/ebase/lib/Everything/Test/DB.pm 2008-06-23 08:30:43 UTC (rev 1005)
+++ trunk/ebase/lib/Everything/Test/DB.pm 2008-06-24 15:52:14 UTC (rev 1006)
@@ -258,7 +258,7 @@
my $self = shift;
$self->{instance}->{dbh}->clear;
- $self->add_expected_sql('SELECT title FROM node WHERE type_nodetype=1 ') unless $self->isset_expected_sql;
+ $self->add_expected_sql('SELECT title FROM node WHERE type_nodetype=1 ORDER BY node_id') unless $self->isset_expected_sql;
{
my @a = @lists;
$self->{instance}->{dbh}->mock( 'fetchrow_array',
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-07-11 20:26:51
|
Revision: 1010
http://everydevel.svn.sourceforge.net/everydevel/?rev=1010&view=rev
Author: paul_the_nomad
Date: 2008-07-11 13:26:45 -0700 (Fri, 11 Jul 2008)
Log Message:
-----------
Changes to ResponseFactory and Apache.pm to allow more flexible responses.
Inclusion of a Nodeball response type to allow direct downloads of nodeballs.
Modified Paths:
--------------
trunk/ebase/TODO
trunk/ebase/lib/Everything/Config.pm
trunk/ebase/lib/Everything/HTTP/Apache.pm
trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm
trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm
trunk/ebase/lib/Everything/HTTP/ResponseFactory.pm
trunk/ebase/lib/Everything/HTTP/Test/Apache.pm
trunk/ebase/t/lib/everything.conf
Modified: trunk/ebase/TODO
===================================================================
--- trunk/ebase/TODO 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/TODO 2008-07-11 20:26:45 UTC (rev 1010)
@@ -5,6 +5,9 @@
* Amend ecore to ensure XHTML 1.0 compliance
+* Amend FromObject.pm so that form objects return labels with a 'for'
+ attribute and id in the input tag.
+
* Require Everything::HTML::Response classes to create certain HTTP headers
* Everything::HTML::Response classes to return error values on error -
Modified: trunk/ebase/lib/Everything/Config.pm
===================================================================
--- trunk/ebase/lib/Everything/Config.pm 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/lib/Everything/Config.pm 2008-07-11 20:26:45 UTC (rev 1010)
@@ -202,11 +202,22 @@
javascript => sub {
my ( $url, $e ) = @_;
return unless $url =~ /\/javascript\/([0-9]+)\.js$/;
- my $js_node = $e->get_nodebase->get_node($1);
+ my $js_node = $e->get_nodebase->getNode($1);
$e->set_response_type('javascript');
$e->set_node($js_node);
1;
},
+
+ nodeball_download => sub {
+ my ( $url, $e ) = @_;
+ return unless $url =~ m{^/repositories/nodeballs/(\d+)};
+ my $node = $e->get_nodebase->getNode( $1 );
+ return unless ref $node;
+ return unless $node->isa( 'Everything::Node::nodeball' );
+ $e->set_node( $node );
+ $e->set_response_type( 'nodeball' );
+ return 1;
+ }
);
sub get_standard_modifier { $standard_modifiers{ $_[1] } }
Modified: trunk/ebase/lib/Everything/HTTP/Apache.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Apache.pm 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/lib/Everything/HTTP/Apache.pm 2008-07-11 20:26:45 UTC (rev 1010)
@@ -72,21 +72,34 @@
### XXX- set in config file response factory
### XXX- response factory should set up the environment that htmlpage needs
- my $response = Everything::HTTP::ResponseFactory->new( $e->get_response_type || 'htmlpage', $e );
- $response->create_http_body( { config => $config } );
- my $html = $response->get_http_body;
+ my $response = Everything::HTTP::ResponseFactory->new( $e->get_response_type || 'htmlpage', { config => $config, request => $e } );
+ ### new actually creates the response - so get rid of 'create http body'
+ ### check response code
+ ### check headers
+ ### check content
+ ### return status_code
+
+ my $html = $response->content();
+
$r->content_type( $response->content_type );
$r->headers_out->set( 'Set-Cookie' => $e->get_user->{cookie} );
+ my %headers = $response->headers;
+
+ foreach ( keys %headers ) {
+ $r->headers_out->set( $_ => $headers{ $_ } );
+ }
+
$r->print($html);
- # To ensure any changes in VARS are saved to the db
+ # XXX: These should be set in the Response object
+ # NB: These lines ensure any changes in VARS are saved to the db
$e->get_user->setVars( $e->get_user_vars, $e->get_user );
$e->get_user->update( $e->get_user );
- return OK;
+ return $response->status_code;
}
Modified: trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/lib/Everything/HTTP/Response/Htmlpage.pm 2008-07-11 20:26:45 UTC (rev 1010)
@@ -6,7 +6,7 @@
use base 'Class::Accessor::Fast';
__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors(
- qw/http_header http_body request htmlpage theme allowed redirect/);
+ qw/http_header http_body request htmlpage theme allowed redirect config/);
use strict;
### because this is called from a Class::Factory object new is not
@@ -19,18 +19,19 @@
}
sub init {
- my ( $self, $e ) = @_;
- $self->set_request($e);
+ my ( $self, $args ) = @_;
+ $self->set_request( $args->{request} );
+ $self->set_config( $args->{config} );
$self->select_htmlpage;
return $self;
}
-sub create_http_body {
+sub content {
my ( $self, $args ) = @_;
my $htmlpage = $self->get_htmlpage;
- my $config = $$args{ config };
+ my $config = $self->get_config;
my $ehtml = Everything::HTML->new;
if ( $config ) {
@@ -58,7 +59,31 @@
}
+=head2 headers
+
+The headers other than Content-Type
+
+=cut
+
+sub headers {
+
+ ();
+
+}
+
+=head2 status_code
+
+Returns the HTTP status code of the response. This is always 'OK', because HTMLPAGES always accept a request.
+
+=cut
+
+sub status_code {
+
+ 0; ## Apache prefers this to 200.
+}
+
sub charset {
+
'utf-8'
}
Modified: trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/lib/Everything/HTTP/Response/Test/Htmlpage.pm 2008-07-11 20:26:45 UTC (rev 1010)
@@ -34,7 +34,7 @@
$mock->set_always( 'getType', $mock );
$mock->{title} = 'a title';
$self->{mock} = $mock;
- isa_ok( $self->{instance} = $self->{class}->new($mock), $self->{class} );
+ isa_ok( $self->{instance} = $self->{class}->new( { request => $mock } ), $self->{class} );
}
@@ -42,7 +42,7 @@
my $self = shift;
my $class = $self->{class};
my $instance = $self->{instance};
- can_ok( $class, 'create_http_body' );
+ can_ok( $class, 'content' );
can_ok( $class, 'content_type' );
}
Modified: trunk/ebase/lib/Everything/HTTP/ResponseFactory.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/ResponseFactory.pm 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/lib/Everything/HTTP/ResponseFactory.pm 2008-07-11 20:26:45 UTC (rev 1010)
@@ -7,6 +7,7 @@
__PACKAGE__->add_factory_type('htmlpage' => 'Everything::HTTP::Response::Htmlpage');
+__PACKAGE__->add_factory_type('nodeball' => 'Everything::HTTP::Response::Nodeball');
=head1 Everything::HTTP::ResponseFactory
@@ -18,58 +19,75 @@
Everything::HTTP::ResponseFactory->add_factory_type('anothertype' => 'Name::of::another::package');
-my $response = Everything::HTTP::ResponseFactory->new(<response type>, [@args]);
+my $response = Everything::HTTP::ResponseFactory->new(<response type>, { args } );
-$response->create_http_body;
+my $html = $response->content;
-my $html = $response->get_http_body;
+my $content_type = $response->content_type;
-my $mime_type = $response->get_mime_type;
-my $header = $response->create_http_header;
-
-
=head1 DESCRIPTION
This is a factory class, that is, the constructor returns instances that are blessed into other classes, not this one.
This class inherits from C<Class::Factory>, so the rules for adding types and the rules instanciation are the same as they are in C<Class::Factory>. In essense, if you want to customise the way your classes are instanciated you should use the C<init> method.
-In addition, the instances that this class provides must support the following methods:
+The objects created by this class must return values that allow a
+response be sent back to the client browser.
=over 4
-=item get_http_body set_http_body
+=item C<new>
-Getters and setters for the http_body attribute.
+This is the constructor. It takes two arguments:
-=item get_http_header set_http_header
+=over
-Getters and setters for the http_header attribute.
+=item
-=item get_mime_type set_mime_type
+The first is a string that determines the type of object return.
-Getters and setters for the mime_type attribute.
+=item
+The second is a hash ref that is passed straight to the created objects. Attributes may include:
+
+=over
+
+=item config
+
+An Everything::Config object.
+
+=item request
+
+An Everything::HTTP::Request object.
+
=back
-In addition, the followimg methods must be supported:
+=back
+=back
+
+In addition, the instances that this class provides must support the following methods:
+
=over 4
-=item create_http_header
+=item content_type
-Conjures a conforming http header and sets the http_header attribute.
+Returns the data for the Content-Type header.
-=item create_http_body
+=item headers
-Conjures up a conforming http body and sets the http_body attribute.
+Returns a hash of headers. By default does not return the Content-Type header.
-=item create_mime_type
+=item content
-Conjures up a mime type (from where is not important) and sets the mime_type attribute.
+Returns the message body
+=item status_code
+
+Returns the HTTP status code.
+
=back
=cut
Modified: trunk/ebase/lib/Everything/HTTP/Test/Apache.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Test/Apache.pm 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/lib/Everything/HTTP/Test/Apache.pm 2008-07-11 20:26:45 UTC (rev 1010)
@@ -21,10 +21,11 @@
$mock->fake_module('Everything::HTTP::ResponseFactory');
$mock->fake_new('Everything::HTTP::ResponseFactory');
- $mock->set_true(qw/create_http_body/)
+ $mock->set_true(qw/content/)
->set_always( content_type => 'a mime type' )
- ->set_always( 'get_http_body', 'the html body' );
+ ->set_always( 'content', 'the html body' );
+ $mock->set_always( status_code => 0 );
$self->{class} = $self->module_class;
use_ok( $self->{class} );
@@ -42,7 +43,7 @@
return $name;
}
-sub test_handler : Test(23) {
+sub test_handler : Test(22) {
my $self = shift;
my $mock = $self->{mock};
my $fake_everything_request = $self->{fake_everything_request};
@@ -128,18 +129,15 @@
( $method, $args ) = $fake_apache_request->next_call;
is( $method, 'print',
- '...currently do our own cookies until Auth.pm rewrite.' );
+ '...prints response.' );
is( $args->[1], 'the html body', '...prints http header.' );
is( $result, 0, '...should return correct result' );
( $method, $args ) = $mock->next_call;
- is( $method, 'create_http_body', '...factory creates http body.' );
+ is( $method, 'content', '...factory creates http body.' );
( $method, $args ) = $mock->next_call;
- is( $method, 'get_http_body', '...retrieves http body.' );
-
- ( $method, $args ) = $mock->next_call;
is( $method, 'content_type', '...returns mime type.' );
( $method, $args ) = $mock->next_call;
Modified: trunk/ebase/t/lib/everything.conf
===================================================================
--- trunk/ebase/t/lib/everything.conf 2008-07-11 20:20:42 UTC (rev 1009)
+++ trunk/ebase/t/lib/everything.conf 2008-07-11 20:26:45 UTC (rev 1010)
@@ -2,6 +2,8 @@
database_type = sqlite
location_schema_nodetype = /node/:node_id node
+request_modifier_standard = nodeball_download
+
request_modifier_code = <<"FOOFOO"
sub { my ($url, $e ) = @_;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <pau...@us...> - 2008-07-12 11:56:54
|
Revision: 1011
http://everydevel.svn.sourceforge.net/everydevel/?rev=1011&view=rev
Author: paul_the_nomad
Date: 2008-07-12 04:56:47 -0700 (Sat, 12 Jul 2008)
Log Message:
-----------
Nodeball response type
Added Paths:
-----------
trunk/ebase/lib/Everything/HTTP/Response/Nodeball.pm
trunk/ebase/lib/Everything/HTTP/Response/Test/Nodeball.pm
trunk/ebase/t/nodeball-responder.t
Added: trunk/ebase/lib/Everything/HTTP/Response/Nodeball.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Response/Nodeball.pm (rev 0)
+++ trunk/ebase/lib/Everything/HTTP/Response/Nodeball.pm 2008-07-12 11:56:47 UTC (rev 1011)
@@ -0,0 +1,106 @@
+package Everything::HTTP::Response::Nodeball;
+
+use Everything::Storage::Nodeball;
+use Apache2::Const qw/FORBIDDEN OK/;
+use File::Temp qw/ :seekable /;
+use strict;
+
+use base 'Class::Accessor::Fast';
+__PACKAGE__->follow_best_practice;
+__PACKAGE__->mk_accessors(
+ qw/request headers/);
+use strict;
+use warnings;
+
+sub new {
+ my $class = shift;
+ my $self = bless {}, $class;
+ $self->init(@_);
+}
+
+sub init {
+ my ( $self, $args ) = @_;
+ $self->set_request( $args->{ request } );
+ $self->authorise;
+ $self->{ headers } = {};
+ return $self;
+}
+
+sub authorise {
+ my $self = shift;
+ my $e = $self->get_request;
+ my $user = $e->get_user;
+ my $node = $e->get_node;
+ return $self->allowed( 1 ) if $node->hasAccess( $user, 'r' );
+ return $self->allowed( undef );
+
+}
+
+sub content {
+
+ my $self = shift;
+ return unless $self->allowed;
+ my $e = $self->get_request;
+ my $nb = $e->get_nodebase;
+ my $node = $e->get_node;
+ my $file = File::Temp->new;
+
+ my $ball_title = $node->get_title;
+
+ my $storage = Everything::Storage::Nodeball->new ( nodebase => $nb );
+
+ $storage->cleanup( 1 );
+ $storage->export_nodeball_to_file( $ball_title, "$file" );
+
+ $ball_title =~ s/[^\w\.\-]/-/g;
+ $self->add_header( 'Content-Disposition', "attachment; filename=" . $ball_title . '.nbz' );
+
+ $file->seek( SEEK_SET, 0 );
+ local $/;
+ return <$file>;
+}
+
+sub headers {
+
+ return %{ $_[0]->get_headers };
+
+}
+
+sub content_type {
+
+'application/x-gzip';
+
+}
+
+sub status_code {
+ my $self = shift;
+ return OK if $self->allowed;
+ return FORBIDDEN;
+
+}
+
+sub allowed {
+
+ my $self = shift;
+
+ if ( ! @_ ) {
+ return $self->{allowed};
+ } else {
+ return $self->{allowed} = $_[0];
+ }
+
+}
+
+=head2 add_header
+
+Adds a header to the headers attribute. Takes two arguments. The first is the name of the header, the second is the header value.
+
+=cut
+
+sub add_header {
+ my ( $self, $key, $value ) =@_;
+ $self->get_headers->{ $key } = $value;
+
+}
+
+1;
Property changes on: trunk/ebase/lib/Everything/HTTP/Response/Nodeball.pm
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
Added: trunk/ebase/lib/Everything/HTTP/Response/Test/Nodeball.pm
===================================================================
--- trunk/ebase/lib/Everything/HTTP/Response/Test/Nodeball.pm (rev 0)
+++ trunk/ebase/lib/Everything/HTTP/Response/Test/Nodeball.pm 2008-07-12 11:56:47 UTC (rev 1011)
@@ -0,0 +1,94 @@
+package Everything::HTTP::Response::Test::Nodeball;
+
+use base 'Everything::Test::Abstract';
+use Test::MockObject;
+use Test::More;
+use IO::File;
+use SUPER;
+use strict;
+use warnings;
+
+sub startup : Test(startup => +0) {
+
+ my $self = shift;
+ my $class = $self->module_class;
+
+ Test::MockObject->fake_module(
+ 'Apache2::Const',
+ import => sub {
+ no strict 'refs';
+ *{ $class . '::OK' } = sub { 'ok status code' };
+ *{ $class . '::FORBIDDEN' } = sub { 'forbidden status code' };
+ use strict 'refs';
+ }
+ );
+
+ $self->SUPER;
+
+}
+
+sub setup :Test(setup) {
+ my $self = shift;
+ my $mock = Test::MockObject->new;
+ $mock->set_always( get_user => $mock );
+ $mock->set_always( get_node => $mock );
+ $mock->set_true(qw/hasAccess/);
+ $self->{ mock } = $mock;
+ $self->{instance} = $self->{class}->new( { request => $mock } );
+
+}
+
+sub test_status_code : Test(2) {
+ my $self = shift;
+ my $i = $self->{instance};
+ $i->allowed( 1 );
+ is ( $i->status_code, 'ok status code', '...returns OK if download allowed.');
+ $i->allowed( 0 );
+ is ( $i->status_code, 'forbidden status code', '...returns FORBIDDEN if download allowed.');
+
+}
+
+sub test_content : Test(3) {
+ my $self = shift;
+
+ my $mock = $self->{ mock };
+ $mock->set_always( get_request => $mock );
+ $mock->set_always( get_nodebase => $mock );
+ $mock->set_always( get_node => $mock );
+ $mock->set_always( get_title => 'a nodeball title' );
+
+ my @args = ();
+
+ local *Everything::Storage::Nodeball::export_nodeball_to_file;
+ *Everything::Storage::Nodeball::export_nodeball_to_file = sub {
+ push @args, @_;
+ my $file = $_[2];
+ my $fh = IO::File->new( $file, 'w' );
+ print $fh "nodeball contents";
+ return 1;
+ };
+
+ my $i = $self->{ instance };
+ $i->allowed( 1 );
+
+ is( my $rv = $i->content, 'nodeball contents', '... returns contents written to file.' );
+ is ( $args[1], 'a nodeball title', '...title of a nodeball.' );
+ my %headers = $i->headers;
+ is_deeply( \%headers, { 'Content-Disposition' => 'attachment; filename=a-nodeball-title.nbz' }, '...sets the Content-Disposition header' );
+}
+
+sub test_headers :Test(2) {
+
+ my $self = shift;
+ my $i = $self->{instance};
+ my %headers = $i->headers;
+ is_deeply( \%headers, {}, '...returns an empty list when initialised.' );
+
+ $i->add_header( Foo => 'Bar' );
+ %headers = $i->headers;
+ is_deeply( \%headers, { Foo => 'Bar' }, '...returns one header when added.' );
+
+
+}
+
+1;
Property changes on: trunk/ebase/lib/Everything/HTTP/Response/Test/Nodeball.pm
___________________________________________________________________
Name: svn:mime-type
+ text/plain
Name: svn:eol-style
+ native
Added: trunk/ebase/t/nodeball-responder.t
===================================================================
--- trunk/ebase/t/nodeball-responder.t (rev 0)
+++ trunk/ebase/t/nodeball-responder.t 2008-07-12 11:56:47 UTC (rev 1011)
@@ -0,0 +1,11 @@
+#!/usr/bin/perl -w
+
+use lib 'blib/lib', 'lib/';
+use Everything::HTTP::Response::Test::Nodeball;
+
+use strict;
+
+
+
+
+Everything::HTTP::Response::Test::Nodeball->runtests;
Property changes on: trunk/ebase/t/nodeball-responder.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.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X