Merge remote-tracking branch 'upstream/WebGUI8' into 8
Conflicts: docs/previousVersion.sql
This commit is contained in:
Doug Bell
commit
02c0da33e4
7 changed files with 223 additions and 2636 deletions
File diff suppressed because one or more lines are too long
68
sbin/changeIobStatus.pl → lib/WebGUI/Command/changeIobStatus.pm
Executable file → Normal file
68
sbin/changeIobStatus.pl → lib/WebGUI/Command/changeIobStatus.pm
Executable file → Normal file
|
|
@ -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 Getopt::Long;
|
||||
use Pod::Usage;
|
||||
use WebGUI::Session;
|
||||
use WebGUI::User;
|
||||
use WebGUI::Inbox;
|
||||
use warnings;
|
||||
|
||||
$|=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;
|
||||
my $help;
|
||||
my $quiet;
|
||||
my $whatsHappening = "Automatically signed out.";
|
||||
my $newStatus = "Out";
|
||||
my $currentStatus = "In";
|
||||
my $userMessage = "You were logged out of the In/Out Board automatically.";
|
||||
my $userMessageFile;
|
||||
sub validate_args {
|
||||
my ($self, $opt, $args) = @_;
|
||||
if (! $opt->{configfile}) {
|
||||
$self->usage_error('You must specify the --configFile option.');
|
||||
}
|
||||
}
|
||||
|
||||
sub run {
|
||||
my ($self, $opt, $args) = @_;
|
||||
|
||||
GetOptions(
|
||||
'configfile=s'=>\$configFile,
|
||||
'help'=>\$help,
|
||||
'quiet'=>\$quiet,
|
||||
'whatsHappening:s'=>\$whatsHappening,
|
||||
'userMessage:s'=>\$userMessage,
|
||||
'userMessageFile:s'=>\$userMessageFile,
|
||||
'currentStatus:s'=>\$currentStatus,
|
||||
'newStatus:s'=>\$newStatus
|
||||
);
|
||||
|
||||
pod2usage( verbose => 2 ) if $help;
|
||||
pod2usage() unless $configFile;
|
||||
my ($configFile, $help, $quiet, $whatsHappening, $newStatus, $currentStatus, $userMessage, $userMessageFile) =
|
||||
@{$opt}{qw(configfile help quiet whatshappening newstatus currentstatus usermessage usermessagefile)};
|
||||
$whatsHappening ||= "Automatically signed out.";
|
||||
$newStatus ||= "Out";
|
||||
$currentStatus ||= "In";
|
||||
$userMessage ||= "You were logged out of the In/Out Board automatically.";
|
||||
|
||||
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
|
||||
|
||||
|
|
@ -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;
|
||||
$self->{_callable} = \%properties;
|
||||
|
||||
return $self;
|
||||
return WebGUI::Template::Proxy::Asset->_new($context, $asset);
|
||||
}
|
||||
|
||||
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;
|
||||
|
||||
|
||||
|
|
|
|||
127
lib/WebGUI/Template/Proxy.pm
Normal file
127
lib/WebGUI/Template/Proxy.pm
Normal file
|
|
@ -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;
|
||||
|
||||
22
lib/WebGUI/Template/Proxy/Asset.pm
Normal file
22
lib/WebGUI/Template/Proxy/Asset.pm
Normal file
|
|
@ -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;
|
||||
|
||||
|
|
@ -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;
|
||||
|
||||
31
t/Template/Proxy.t
Normal file
31
t/Template/Proxy.t
Normal file
|
|
@ -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';
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue