Merge remote-tracking branch 'upstream/WebGUI8' into 8

Conflicts:
	docs/previousVersion.sql

lib/WebGUI/Command/changeIobStatus.pm

@@ -1,4 +1,4 @@
-#!/usr/bin/env perl
+package WebGUI::Command::changeIobStatus;
 
 #-------------------------------------------------------------------
 # WebGUI is Copyright 2001-2009 Plain Black Corporation.
@@ -10,39 +10,38 @@
 # http://www.plainblack.com                     info@plainblack.com
 #-------------------------------------------------------------------
 
+use WebGUI::Command -command;
 use strict;
-use WebGUI::Paths -inc;
+use warnings;
-use Getopt::Long;
-use Pod::Usage;
-use WebGUI::Session;
-use WebGUI::User;
-use WebGUI::Inbox;
 
-$|=1;
+sub opt_spec {
+    return (
+        [ 'configFile=s', 'The WebGUI config file to use.  This parameter is required.'],
+        [ 'quiet', q{Disable all output unless there's an error.} ],
+        [ 'whatsHappening:s', q{The message attached to the InOut Board when changing status.  If left unspecified it defaults to 'Automatically signed out.'}],
+        [ 'userMessage:s', q{Text of the message to be sent to the user after changing the status.  If left unspecified it will default to 'You were logged out of the In/Out Board automatically.'}],
+        [ 'userMessageFile:s', q{Pathname to a file whose contents will be sent to the user after changing the status. Using this option overrides whatever messages is set with --userMessage (see above).}],
+        [ 'currentStatus:s', q{Check users in the IOB having status status. If left unspecified, it will default to In.}],
+        [ 'newStatus:s', q{Change users status in the IOB to status status. If left unspecified, it will default to Out.}],
+    );
+}
 
-my $configFile;
+sub validate_args {
-my $help;
+    my ($self, $opt, $args) = @_;
-my $quiet;
+    if (! $opt->{configfile}) {
-my $whatsHappening = "Automatically signed out.";
+        $self->usage_error('You must specify the --configFile option.');
-my $newStatus = "Out";
+    }
-my $currentStatus = "In";
+}
-my $userMessage = "You were logged out of the In/Out Board automatically.";
-my $userMessageFile;
 
+sub run {
+    my ($self, $opt, $args) = @_;
 
-GetOptions(
+my ($configFile, $help, $quiet, $whatsHappening, $newStatus, $currentStatus, $userMessage, $userMessageFile) =
-	'configfile=s'=>\$configFile,
+    @{$opt}{qw(configfile help quiet whatshappening newstatus currentstatus usermessage usermessagefile)};
-	'help'=>\$help,
+$whatsHappening ||= "Automatically signed out.";
-	'quiet'=>\$quiet,
+$newStatus ||= "Out";
-	'whatsHappening:s'=>\$whatsHappening,
+$currentStatus ||= "In";
-	'userMessage:s'=>\$userMessage,
+$userMessage ||= "You were logged out of the In/Out Board automatically.";
-	'userMessageFile:s'=>\$userMessageFile,
-	'currentStatus:s'=>\$currentStatus,
-	'newStatus:s'=>\$newStatus
-);
-
-pod2usage( verbose => 2 ) if $help;
-pod2usage() unless $configFile;
 
 print "Starting up...\n" unless ($quiet);
 my $session = WebGUI::Session->open($configFile);
@@ -100,22 +99,26 @@ $session->var->end;
 $session->close;
 print "OK\n" unless ($quiet);
 
+}
+
+1;
+
 __END__
 
 =head1 NAME
 
-changeIobStatus - Automate WebGUI's InOut Board User status switching.
+WebGUI::Command::changeIobStatus - Automate WebGUI's InOut Board User status switching.
 
 =head1 SYNOPSIS
 
- changeIobStatus --configFile config.conf
+ webgui.pl changeiobstatus --configFile config.conf
                  [--currentStatus status]
                  [--newStatus status]
                  [--userMessage text|--userMessageFile pathname]
                  [--whatsHappening text]
                  [--quiet]
 
- changeIobStatus --help
+ webgui.pl changeiobstatus --help
 
 =head1 DESCRIPTION
 
@@ -177,3 +180,4 @@ Shows this documentation, then exits.
 Copyright 2001-2009 Plain Black Corporation.
 
 =cut
+

lib/WebGUI/Template/Plugin/Asset.pm

@@ -1,6 +1,7 @@
 package WebGUI::Template::Plugin::Asset;
 
 use base 'Template::Plugin';
+use WebGUI::Template::Proxy::Asset;
 
 sub new {
     my $config = ref($_[-1]) eq 'HASH' ? pop(@_) : { };
@@ -9,42 +10,33 @@ sub new {
     my $stash = $context->stash;
     my $session = $stash->{_session};
 
-    my $self = bless {
-        _session => $session,
-        _context => $context,
-    }, $class;
-
     if ( ref $asset) {
     }
     elsif ( defined $asset ) {
-        $asset = $self->_getAsset($asset);
+        $asset = $class->_getAsset($session, $asset);
     }
     elsif ( $stash->{_asset} ) {
         $asset = $stash->{_asset};
     }
     elsif ( $stash->{assetId} ) {
-        $asset = $self->_getAsset($stash->{assetId});
+        $asset = $class->_getAsset($session, $stash->{assetId});
     }
     else {
         $asset = $session->asset;
     }
-    $self->{_asset} = $asset;
 
-    my %properties = map { $_ => 1 } $asset->meta->get_all_properties_list;
+    return WebGUI::Template::Proxy::Asset->_new($context, $asset);
-    $self->{_callable} = \%properties;
-
-    return $self;
 }
 
 sub _getAsset {
-    my ( $self, $id ) = @_;
+    my ( $class, $session, $id ) = @_;
     my ( $asset );
     try {
-        $asset = WebGUI::Asset->newByUrl( $self->session, $id );
+        $asset = WebGUI::Asset->newByUrl( $session, $id );
     }
     catch {
         try {
-            $asset = WebGUI::Asset->newById( $self->session, $id );
+            $asset = WebGUI::Asset->newById( $session, $id );
         }
         catch {
             die "Could not find asset $id to include in template: " . $_;
@@ -53,37 +45,5 @@ sub _getAsset {
     return $asset;
 }
 
-sub DESTROY {
-    # prevent AUTOLOADing
-}
-
-sub AUTOLOAD {
-    my $sub = our $AUTOLOAD;
-    $sub =~ s/.*:://;
-    my $self = shift;
-    if ($self->{_callable}{$sub}) {
-        my $result = $self->{_asset}->();
-        if ( eval { $result->isa('WebGUI::Asset'); 1 } ) {
-            return $self->_wrap($result);
-        }
-        return $result;
-    }
-    die 'Not allowed to call ' . $sub;
-}
-
-sub _wrap {
-    my $self = shift;
-    my $wrap = shift;
-    my $class = ref $self;
-    return $class->new($self->{_context}, $wrap);
-}
-
-sub parent {
-    my $self = shift;
-    my $parent = $self->{_asset}->parentNode;
-    return $self->_wrap($parent);
-}
-
 1;
 
-

lib/WebGUI/Template/Proxy.pm

@@ -0,0 +1,127 @@
+package WebGUI::Template::Proxy;
+use strict;
+use warnings;
+use Scalar::Util qw(blessed);
+use mro;
+use Try::Tiny;
+use namespace::clean;
+
+sub new {
+    my $class = shift;
+    $class = __PACKAGE__->_classify($class);
+    return $class->_new(@_);
+}
+
+sub _new {
+    my ($class, $context, $object) = @_;
+
+    my $stash = $context->stash;
+    my $session = $stash->{_session};
+
+    my $self = bless {
+        _session => $session,
+        _context => $context,
+        _object  => $object,
+    }, $class;
+
+    $self->{_methods} = $self->_get_methods($object);
+    return $self;
+}
+
+sub DESTROY {
+    # prevent AUTOLOADing
+}
+
+sub AUTOLOAD {
+    my $subname = our $AUTOLOAD;
+    $subname =~ s/.*:://;
+    my $self = shift;
+    if (my $sub = $self->can($subname)) {
+        return $self->$sub(@_);
+    }
+    die 'Method not found: ' . $subname;
+}
+
+sub can {
+    my ($self, $subname) = @_;
+    my $sub = $self->SUPER::can($subname);
+    if ($sub) {
+        return $sub;
+    }
+    elsif (ref $self) {
+        if ($self->{_methods}{$subname}) {
+            return $self->{_methods}{$subname};
+        }
+    }
+    return;
+}
+
+my %classified;
+sub _classify {
+    my $self = shift;
+    my $class = shift;
+    if ($classified{$class}) {
+        return $classified{$class};
+    }
+    my $classes = mro::get_linear_isa($class);
+    my @proxyclasses = map { (/^WebGUI::(.*)/ ? (__PACKAGE__ . '::' . $1) : (), __PACKAGE__ . '::' . $_) } @$classes;
+    for my $isa ( @proxyclasses ) {
+        (my $module = $isa . '.pm') =~ s{::}{/}g;
+        try {
+            require $module;
+            $classified{$class} = $isa;
+        } || next;
+        return $isa;
+    }
+    die "Cannot proxy $class";
+}
+
+sub _get_methods {
+    my $self = shift;
+    my $object = shift;
+    my @allowed = $self->_get_allowed($object);
+    my %methods;
+    for my $method ( @allowed ) {
+        $methods{$method} = $self->_gen_wrapped($method);
+    }
+    return \%methods;
+}
+
+sub _gen_wrapped {
+    my $self = shift;
+    my $method = shift;
+    my $context = $self->{_context};
+    my $object = $self->{_object};
+    return sub {
+        my @res;
+        if (wantarray) {
+            @res = $object->$method;
+        }
+        else {
+            $res[0] = $object->$method;
+        }
+        for my $res ( @res ) {
+            $self->_wrap(@res);
+        }
+        return wantarray ? @res : $res[0];
+    };
+}
+
+sub _wrap {
+    my $self = shift;
+    my $context = $self->{_context};
+    for my $item ( @_ ) {
+        if ( blessed $item ) {
+            if (! $item->isa(__PACKAGE__) ) {
+                $item = __PACKAGE__->new($context, $item);
+            }
+        }
+    }
+}
+
+sub _get_allowed {
+    return ();
+}
+
+1;
+

lib/WebGUI/Template/Proxy/Asset.pm

@@ -0,0 +1,22 @@
+package WebGUI::Template::Proxy::Asset;
+use strict;
+use warnings;
+
+use base 'WebGUI::Template::Proxy';
+
+sub _get_allowed {
+    my $self = shift;
+    my $asset = shift;
+    my @properties = $asset->meta->get_all_property_list;
+    return @properties;
+}
+
+sub parent {
+    my $self = shift;
+    my $parent = $self->{_asset}->parentNode;
+    $self->_wrap($parent);
+    return $parent;
+}
+
+1;
+

sbin/preload.perl

@@ -1,30 +0,0 @@
-use strict;
-
-use WebGUI::Paths -preload;
-
-use Log::Log4perl;
-use DBI;
-use WebGUI;
-use WebGUI::Config;
-use Apache2::Cookie;
-use Apache2::ServerUtil;
-
-Log::Log4perl->init( WebGUI::Paths->logConfig );
-DBI->install_driver("mysql");
-
-if ( $ENV{MOD_PERL} ) {
-    # Add WebGUI to Apache version tokens
-    my $server = Apache2::ServerUtil->server;
-    $server->push_handlers(PerlPostConfigHandler => sub {
-        $server->add_version_component('WebGUI/' . $WebGUI::VERSION);
-    });
-}
-
-$| = 1;
-
-print "\nStarting WebGUI ".$WebGUI::VERSION."\n";
-
-WebGUI::Config->loadAllConfigs;
-
-1;
-

t/Template/Proxy.t

@@ -0,0 +1,31 @@
+use strict;
+use warnings;
+
+use WebGUI::Test;
+use Test::More 'no_plan';
+
+use WebGUI::Asset;
+use WebGUI::Asset::Template::TemplateToolkit;
+
+my $parser = WebGUI::Asset::Template::TemplateToolkit->new(WebGUI::Test->session);
+
+my $vars = {
+    _asset => WebGUI::Test->asset(
+        title => 'proxied asset'
+    ),
+};
+
+my $template = <<'END_TEMPLATE';
+[% USE Asset -%]
+[%+ Asset.title +%]
+[%+ Asset.title('new title') +%]
+[%+ Asset.title +%]
+END_TEMPLATE
+
+my $out = $parser->process($template, $vars);
+
+my @lines = split /\n/, $out;
+
+is $lines[0], 'proxied asset', 'title retrieved';
+is $lines[2], 'proxied asset', 'title not able to be changed';
+