oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
Conflicts:
	docs/gotcha.txt
	docs/previousVersion.sql
	lib/WebGUI/Asset/Wobject/GalleryAlbum.pm
	lib/WebGUI/Asset/Wobject/Navigation.pm
	lib/WebGUI/AssetLineage.pm
	lib/WebGUI/Config.pm
	lib/WebGUI/Form/Template.pm
	lib/WebGUI/Group.pm
	lib/WebGUI/VersionTag.pm
	lib/WebGUI/Workflow/Activity/TrashExpiredEvents.pm
	t/AdSpace.t
	t/Asset/AssetExportHtml.t
	t/Asset/AssetLineage.t
	t/Asset/Story.t
	t/Asset/Template/HTMLTemplateExpr.t
	t/Asset/Wobject/Gallery/00base.t
	t/Asset/Wobject/GalleryAlbum/00base.t
	t/Asset/Wobject/GalleryAlbum/ajax.t
	t/Asset/Wobject/InOutBoard.t
	t/Asset/Wobject/StoryArchive.t
	t/Asset/Wobject/Survey/ExpressionEngine.t
	t/Asset/Wobject/Survey/Reports.t
	t/AssetAspect/RssFeed.t
	t/Auth/mech.t
	t/Group.t
	t/Mail/Send.t
	t/Operation/AdSpace.t
	t/Session/ErrorHandler.t
	t/Session/Scratch.t
	t/Session/Url.t
	t/Shop/Cart.t
	t/Shop/Pay.t
	t/Shop/Ship.t
	t/Shop/ShipDriver.t
	t/Shop/TaxDriver/Generic.t
	t/Shop/Vendor.t
	t/VersionTag.t
	t/lib/WebGUI/Test.pm
This commit is contained in:
Doug Bell 2010-07-14 18:20:00 -05:00
commit 708b47d73c
165 changed files with 3199 additions and 5718 deletions
Download patch file Download diff file Expand all files Collapse all files

4
lib/WebGUI/Account/Inbox.pm
View file

@ -850,7 +850,7 @@ sub www_inviteUser {
$var->{'submit_button' } = WebGUI::Form::submit($session,{});
$var->{'form_footer' } = WebGUI::Form::formFooter($session, {});
$var->{'back_url' } = $session->env->get("HTTP_REFERER") || $var->{'view_inbox_url'};
$var->{'back_url' } = $session->request->referer || $var->{'view_inbox_url'};
#Add common template variable for displaying the inbox
$self->appendCommonVars($var);
@ -1099,7 +1099,7 @@ sub www_sendMessage {
my $messageId = $form->get("messageId");
my $userId = $form->get("userId");
my $pageUrl = $session->url->page;
my $backUrl = $session->env->get("HTTP_REFERER") || $var->{'view_inbox_url'};
my $backUrl = $session->request->referer || $var->{'view_inbox_url'};
my $errorMsg = "";
if($messageId) {

4
lib/WebGUI/AdSpace.pm
View file

@ -52,7 +52,7 @@ sub countClick {
my $session = shift;
my $id = shift;
my ($url) = $session->db->quickArray("select url from advertisement where adId=?",[$id]);
return $url if $session->env->requestNotViewed();
return $url if $session->request->requestNotViewed();
$session->db->write("update advertisement set clicks=clicks+1 where adId=?",[$id]);
return $url;
}
@ -119,7 +119,7 @@ A boolean that tells the ad system not to count this impression if true.
sub displayImpression {
my $self = shift;
my $dontCount = shift;
return '' if $self->session->env->requestNotViewed();
return '' if $self->session->request->requestNotViewed();
my ($id, $ad, $priority, $clicks, $clicksBought, $impressions, $impressionsBought) = $self->session->db->quickArray("select adId, renderedAd, priority, clicks, clicksBought, impressions, impressionsBought from advertisement where adSpaceId=? and isActive=1 order by nextInPriority asc limit 1",[$self->getId]);
unless ($dontCount) {
my $isActive = 1;

6
lib/WebGUI/Asset.pm
View file

@ -588,8 +588,8 @@ to SSL.
sub checkView {
my $self = shift;
return $self->session->privilege->noAccess() unless $self->canView;
my ($conf, $env, $var, $http) = $self->session->quick(qw(config env var http));
if ($conf->get("sslEnabled") && $self->get("encryptPage") && ! $env->sslRequest) {
my ($conf, $var, $http) = $self->session->quick(qw(config var http));
if ($conf->get("sslEnabled") && $self->get("encryptPage") && ! $self->session->request->secure) {
# getUrl already changes url to https if 'encryptPage'
$http->setRedirect($self->getUrl);
$http->sendHeader;
@ -1726,7 +1726,7 @@ sub getWwwCacheKey {
my $session = $self->session;
my $method = shift;
my $cacheKey = join '_', @_, $self->getId;
if ($session->env->sslRequest) {
if ($session->request->secure) {
$cacheKey .= '_ssl';
}
return $cacheKey;

2
lib/WebGUI/Asset/File/GalleryFile.pm
View file

@ -697,7 +697,7 @@ sub processCommentEditForm {
;
my $visitorIp = $session->user->isVisitor
? $session->env->get("REMOTE_ADDR")
? $session->request->remote_host
: undef
;

6
lib/WebGUI/Asset/MatrixListing.pm
View file

@ -350,7 +350,7 @@ sub hasRated {
my $hasRated = $self->session->db->quickScalar("select count(*) from MatrixListing_rating where
((userId=? and userId<>'1') or (userId='1' and ipAddress=?)) and listingId=?",
[$session->user->userId,$session->env->get("HTTP_X_FORWARDED_FOR"),$self->getId]);
[$session->user->userId,$session->request->env->{"HTTP_X_FORWARDED_FOR"}, $self->getId]);
return $hasRated;
}
@ -372,7 +372,7 @@ sub incrementCounter {
my $db = $self->session->db;
my $counter = shift;
my $currentIp = $self->session->env->get("HTTP_X_FORWARDED_FOR");
my $currentIp = $self->session->request->env->{"HTTP_X_FORWARDED_FOR"};
unless ($self->get($counter."LastIp") && ($self->get($counter."LastIp") eq $currentIp)) {
$self->update({
@ -528,7 +528,7 @@ sub setRatings {
$db->write("insert into MatrixListing_rating
(userId, category, rating, timeStamp, listingId, ipAddress, assetId) values (?,?,?,?,?,?,?)",
[$session->user->userId,$category,$ratings->{$category},time(),$self->getId,
$session->env->get("HTTP_X_FORWARDED_FOR"),$matrixId]);
$session->request->env->{"HTTP_X_FORWARDED_FOR"}, $matrixId]);
}
my $sql = "from MatrixListing_rating where listingId=? and category=?";
my $sum = $db->quickScalar("select sum(rating) $sql", [$self->getId,$category]);

17
lib/WebGUI/Asset/Post.pm
View file

@ -120,8 +120,8 @@ sub _fixReplyCount {
orderByClause => 'assetData.revisionDate desc',
limit => 1,
} )->[0];
if (my $lastPost = WebGUI::Asset->newById( $self->session, $lastPostId ) ) {
my $lastPost = eval { WebGUI::Asset->newById( $self->session, $lastPostId ); };
if ( ! Exception::Class->caught() ) {
$asset->incrementReplies( $lastPost->revisionDate, $lastPost->getId );
}
else {
@ -293,23 +293,30 @@ the parent thread.
=cut
override cut => sub {
warn "post's cut";
my $self = shift;
# Fetch the Thread and CS before cutting the asset.
my $thread = $self->getThread;
warn "got thread";
my $cs = $thread->getParent;
warn "got cs";
# Cut the asset
my $result = super();
warn "called super";
# If a post is being cut update the thread reply count first
if ($thread->getId ne $self->getId) {
warn "calling _fixReplyCount on thread";
$self->_fixReplyCount( $thread );
}
# Update the CS reply count. This step is also necessary when a Post is cut since the Thread's incrementReplies
# also calls the CS's incrementReplies, possibly with the wrong last post Id.
warn "calling _fixReplyCount on cs";
$self->_fixReplyCount( $cs );
warn "all should be well...?";
return $result;
};
@ -823,7 +830,7 @@ sub hasRated {
return 1 if $self->isPoster;
my $flag = 0;
if ($self->session->user->isVisitor) {
($flag) = $self->session->db->quickArray("select count(*) from Post_rating where assetId=? and ipAddress=?",[$self->getId, $self->session->env->getIp]);
($flag) = $self->session->db->quickArray("select count(*) from Post_rating where assetId=? and ipAddress=?",[$self->getId, $self->session->request->address]);
} else {
($flag) = $self->session->db->quickArray("select count(*) from Post_rating where assetId=? and userId=?",[$self->getId, $self->session->user->userId]);
}
@ -888,7 +895,7 @@ sub insertUserPostRating {
$self->session->db->write("insert into Post_rating (assetId,userId,ipAddress,dateOfRating,rating) values (?,?,?,?,?)",
[$self->getId,
$self->session->user->userId,
$self->session->env->getIp,
$self->session->request->address,
time(),
$rating,]
);
@ -1367,7 +1374,7 @@ Updates the last post information in the parent Thread and CS if applicable.
sub setStatusUnarchived {
my ($self) = @_;
$self->update({status=>'approved'}) if ($self->get("status") eq "archived");
$self->update({status=>'approved'}) if ($self->status eq "archived");
$self->qualifyAsLastPost;
}

5
lib/WebGUI/Asset/Wobject/GalleryAlbum.pm
View file

@ -211,8 +211,9 @@ sub appendTemplateVarsFileLoop {
my $assetIds = shift;
my $session = $self->session;
for my $assetId (@$assetIds) {
my $asset = WebGUI::Asset->newById($session, $assetId);
ASSET: for my $assetId (@$assetIds) {
my $asset = eval { WebGUI::Asset->newById($session, $assetId); };
next ASSET if Exception::Class->caught();
# Set the parent
$asset->{_parent} = $self;
push @{$var->{file_loop}}, $asset->getTemplateVars;

4
lib/WebGUI/Asset/Wobject/HttpProxy.pm
View file

@ -310,7 +310,7 @@ sub view {
return $self->processTemplate({},$self->templateId)
unless ($proxiedUrl ne "");
my $requestMethod = $self->session->env->get("REQUEST_METHOD") || "GET";
my $requestMethod = $self->session->request->method || "GET";
### Do we have cached content to get?
my $cache = $self->session->cache;
@ -328,7 +328,7 @@ sub view {
REDIRECT: for my $redirect (0..4) { # We follow max 5 redirects to prevent bouncing/flapping
my $userAgent = new LWP::UserAgent;
$userAgent->agent($self->session->env->get("HTTP_USER_AGENT"));
$userAgent->agent($self->session->request->user_agent);
$userAgent->timeout($self->timeout);
$userAgent->env_proxy;

4
lib/WebGUI/Asset/Wobject/Poll.pm
View file

@ -203,7 +203,7 @@ sub _hasVoted {
my $self = shift;
my ($hasVoted) = $self->session->db->quickArray("select count(*) from Poll_answer
where assetId=".$self->session->db->quote($self->getId)." and ((userId=".$self->session->db->quote($self->session->user->userId)."
and userId<>'1') or (userId=".$self->session->db->quote($self->session->user->userId)." and ipAddress='".$self->session->env->getIp."'))");
and userId<>'1') or (userId=".$self->session->db->quote($self->session->user->userId)." and ipAddress='".$self->session->request->address."'))");
return $hasVoted;
}
@ -545,7 +545,7 @@ sub www_vote {
my $self = shift;
my $u;
if ($self->session->form->process("answer") ne "" && $self->session->user->isInGroup($self->get("voteGroup")) && !($self->_hasVoted())) {
$self->setVote($self->session->form->process("answer"),$self->session->user->userId,$self->session->env->getIp);
$self->setVote($self->session->form->process("answer"),$self->session->user->userId,$self->session->request->address);
if ($self->session->setting->get("useKarma")) {
$self->session->user->karma($self->get("karmaPerVote"),"Poll (".$self->getId.")","Voted on this poll.");
}

2
lib/WebGUI/Asset/Wobject/ProjectManager.pm
View file

@ -1044,7 +1044,7 @@ sub www_drawGanttChart {
}
#Adjust top for MSIE
my $isMSIE = ($session->env->get("HTTP_USER_AGENT") =~ /msie/i);
my $isMSIE = ($session->env->request->user_agent =~ /msie/i);
my $divTop = $isMSIE ? 45 : 45;
#Start at 45 px and add 20px as the start of the new task
#Set the propert mutiplier

4
lib/WebGUI/Asset/Wobject/Survey.pm
View file

@ -2045,7 +2045,7 @@ sub responseId {
my $ignoreRevisionDate = $opts{ignoreRevisionDate};
my $user = WebGUI::User->new( $self->session, $userId );
my $ip = $self->session->env->getIp;
my $ip = $self->session->request->address;
my $responseId = $self->{responseId};
return $responseId if $responseId;
@ -2178,7 +2178,7 @@ sub canTakeSurvey {
}
my $maxResponsesPerUser = $self->maxResponsesPerUser;
my $ip = $self->session->env->getIp;
my $ip = $self->session->request->address;
my $userId = $self->session->user->userId();
my $takenCount = 0;

2
lib/WebGUI/Asset/Wobject/Thingy.pm
View file

@ -565,7 +565,7 @@ sub editThingDataSave {
if ($thingDataId eq "new"){
$thingData{dateCreated} = time();
$thingData{createdById} = $session->user->userId;
$thingData{ipAddress} = $session->env->getIp;
$thingData{ipAddress} = $session->request->address;
}
else {
%thingData = $session->db->quickHash("select * from ".$session->db->dbh->quote_identifier("Thingy_".$thingId)

2
lib/WebGUI/AssetCollateral/DataForm/Entry.pm
View file

@ -301,7 +301,7 @@ sub new {
}
else {
$self->user($session->user);
$self->ipAddress($session->env->getIp);
$self->ipAddress($session->request->address);
$self->submissionDate(WebGUI::DateTime->new($session, time));
$entryData{id $self} = {};
}

8
lib/WebGUI/AssetPackage.pm
View file

@ -161,6 +161,7 @@ sub importAssetData {
WebGUI::Asset->loadModule( $class );
my %properties = %{ $data->{properties} };
delete $properties{tagId};
if ($options->{inheritPermissions}) {
delete $properties{ownerUserId};
delete $properties{groupIdView};
@ -173,6 +174,13 @@ sub importAssetData {
$properties{isDefault} = 1;
}
if ($options->{clearPackageFlag}) {
$properties{isPackage} = 0;
}
if ($options->{setDefaultTemplate}) {
$properties{isDefault} = 1;
}
my $asset = eval { $class->new($session, $id, $version); };
if (! Exception::Class->caught()) { # update an existing revision

6
lib/WebGUI/Auth.pm
View file

@ -100,8 +100,8 @@ sub _logLogin {
$_[0],
$_[1],
time(),
$self->session->env->getIp,
$self->session->env->get("HTTP_USER_AGENT"),
$self->session->request->address,
$self->session->request->user_agent,
$self->session->getId,
time(),
]
@ -539,7 +539,7 @@ sub displayLogin {
) {
my $returnUrl
= $self->session->form->get('returnUrl')
|| $self->session->url->page( $self->session->env->get('QUERY_STRING') )
|| $self->session->url->page( $self->session->request->env->{'QUERY_STRING'} )
;
$self->session->scratch->set("redirectAfterLogin", $returnUrl);
}

2
lib/WebGUI/Auth/Twitter.pm
View file

@ -151,7 +151,7 @@ Get the template to choose a username
sub getTemplateChooseUsername {
my ( $self ) = @_;
my $templateId = $self->session->setting->get('twitterTemplateIdChooseUsername');
return WebGUI::Asset::Template->new( $self->session, $templateId );
return WebGUI::Asset->newById( $self->session, $templateId );
}
#----------------------------------------------------------------------------

66
lib/WebGUI/Config.pm
View file

@ -35,8 +35,6 @@ This package parses the WebGUI config file.
use WebGUI::Config;
WebGUI::Config->loadAllConfigs($webguiRoot);
my $configs = WebGUI::Config->readAllConfigs;
my $config = WebGUI::Config->new($configFileName);
@ -65,24 +63,6 @@ These subroutines are available from this package:
#-------------------------------------------------------------------
=head2 clearCache ( )
Clear the cache of in-memory configuration files. This is required by the upgrade script, which
forks to run each upgrade. When the child is reaped, the original is untouched, so that the
next script in the line recieves an old, in-memory config, essentially undoing any config
changes in the first upgrade script.
This is a class method.
=cut
sub clearCache {
my $class = shift;
%config = ();
}
#-------------------------------------------------------------------
=head2 getCookieName ( )
Returns the cookie name defined in the config file. Returns "wgSession" if one isn't defined.
@ -112,62 +92,22 @@ sub getCookieTTL {
#-------------------------------------------------------------------
=head2 loadAllConfigs ( webguiRoot )
Reads all the config file data for all defined sites into an in-memory cache. This is a class method.
=head3 webguiRoot
The path to the WebGUI installation.
=cut
sub loadAllConfigs {
my $class = shift;
my $configs = $class->readAllConfigs;
foreach my $filename (keys %{$configs}) {
unless ($filename =~ /^demo\d/) {
print "\tLoading ".$filename."\n";
$config{$filename} = $configs->{$filename};
}
}
}
#-------------------------------------------------------------------
=head2 new ( webguiRoot , configFile [ , noCache ] )
=head2 new ( configFile )
Returns a hash reference containing the configuration data. It tries to get the data out of the memory cache first, but reads the config file directly if necessary.
=head3 webguiRoot
The path to the WebGUI installation.
=head3 configFile
The filename of the config file to read.
=head3 noCache
A boolean value that when set to true tells the config system not to store the config in an in memory cache, in case it's loaded again later. This is mostly used when loading utility configs, like spectre.conf.
=cut
around new => sub {
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
my $filename = shift;
my $noCache = shift;
$filename = Cwd::realpath(File::Spec->rel2abs($filename, WebGUI::Paths->configBase));
if (exists $config{$filename}) {
return $config{$filename};
}
else {
my $self = $class->$orig($filename);
$config{$filename} = $self unless $noCache;
return $self;
}
return $class->$orig($filename);
};
#-------------------------------------------------------------------

2
lib/WebGUI/Content/Prefetch.pm
View file

@ -46,7 +46,7 @@ The content handler for this package.
sub handler {
my ($session) = @_;
if ($session->env->get("HTTP_X_MOZ") eq "prefetch") { # browser prefetch is a bad thing
if ($session->request->env->{"HTTP_X_MOZ"} eq "prefetch") { # browser prefetch is a bad thing
$session->http->setStatus(403);
}
return undef;

13
lib/WebGUI/Exception.pm
View file

@ -286,13 +286,12 @@ use Exception::Class (
},
);
{
package WebGUI::Error;
use overload '~~' => sub {
return $_[0]->isa($_[1]);
};
}
1;

5
lib/WebGUI/Form/Captcha.pm
View file

@ -111,7 +111,7 @@ sub getValue {
my $ua = LWP::UserAgent->new;
my $res = $ua->post('http://api-verify.recaptcha.net/verify', {
privatekey => $privKey,
remoteip => $self->session->env->getIp,
remoteip => $self->session->request->env->{REMOTE_ADDR},
challenge => $challenge,
response => $response,
});
@ -158,10 +158,9 @@ sub toHtml {
my $self = shift;
if ($self->session->setting->get('useRecaptcha')) {
my $env = $self->session->env;
my $pubKey = $self->session->setting->get('recaptchaPublicKey');
my $server = "http://api.recaptcha.net";
if ($env->sslRequest) {
if ($self->session->request->secure) {
$server = "https://api-secure.recaptcha.net";
}
return

6
lib/WebGUI/Form/Template.pm
View file

@ -173,9 +173,9 @@ sub setOptions {
#Remove entries from template list that the user does not have permission to view.
for my $assetId ( keys %{$templateList} ) {
my $asset = WebGUI::Asset::Template->newById($self->session, $assetId);
if (!$asset->canView($self->session->user->userId)) {
delete $templateList->{$assetId};
my $asset = eval { WebGUI::Asset->newById($session, $assetId); };
if (!Exception::Class->caught() && !$asset->canView($self->session->user->userId)) {
delete $templateList->{$assetId};
}
}

42
lib/WebGUI/Friends.pm
View file

@ -15,7 +15,20 @@ package WebGUI::Friends;
=cut
use strict;
use Class::InsideOut qw(id register public readonly);
use Moose;
has 'session' => (
is => 'ro',
required => 1,
weak_ref => 1,
);
has 'user' => (
is => 'ro',
required => 1,
);
use WebGUI::DateTime;
use WebGUI::HTML;
use WebGUI::Inbox;
@ -23,9 +36,6 @@ use WebGUI::International;
use WebGUI::User;
use WebGUI::Utility;
readonly session => my %session;
readonly user => my %user;
=head1 NAME
WebGUI::Friends
@ -45,6 +55,20 @@ A user relationship management system.
=cut
around BUILDARGS => sub {
my $orig = shift;
my $className = shift;
##Original arguments start here.
my $protoSession = $_[0];
if (blessed $protoSession && $protoSession->isa('WebGUI::Session')) {
my $protoUser = defined $_[1] ? $_[1] : $protoSession->user;
return $className->$orig(session => $protoSession, user => $protoUser,);
}
return $className->$orig(@_);
};
#-------------------------------------------------------------------
@ -276,16 +300,6 @@ attached to the session.
=cut
sub new {
my $class = shift;
my $session = shift;
my $user = shift || $session->user;
my $self = register($class);
$session{id $self} = $session;
$user{id $self} = $user;
return $self;
}
#-------------------------------------------------------------------
=head2 rejectAddRequest ( inviteId[,sendNotification] )

2
lib/WebGUI/Group.pm
View file

@ -283,7 +283,7 @@ sub clearCaches {
$stow->delete("groupObj");
$stow->delete("isInGroup");
$stow->delete("gotGroupsInGroup");
$session->stow->delete("gotGroupsForUser");
$stow->delete("gotGroupsForUser");
}
#-------------------------------------------------------------------

2
lib/WebGUI/Image/Font.pm
View file

@ -73,7 +73,7 @@ sub getFile {
if ($self->getStorageId) {
return WebGUI::Storage->get($self->session, $self->getStorageId)->getPath($self->getFilename);
} else {
return WebGUI::Paths->var . '/default.ttf';
return WebGUI::Paths->share . '/default.ttf';
}
}

31
lib/WebGUI/Keyword.pm
View file

@ -15,7 +15,13 @@ package WebGUI::Keyword;
=cut
use strict;
use Class::InsideOut qw(public register id);
use Moose;
has session => (
is => 'ro',
required => 1,
);
use HTML::TagCloud;
use WebGUI::Paginator;
@ -40,6 +46,17 @@ These methods are available from this class:
=cut
around BUILDARGS => sub {
my $orig = shift;
my $className = shift;
##Original arguments start here.
my $protoSession = $_[0];
if (blessed $protoSession && $protoSession->isa('WebGUI::Session')) {
return $className->$orig(session => $protoSession);
}
return $className->$orig(@_);
};
#-------------------------------------------------------------------
@ -49,9 +66,6 @@ Returns a reference to the current session.
=cut
public session => my %session;
#-------------------------------------------------------------------
=head2 deleteKeywordsForAsset ( $asset )
@ -473,15 +487,6 @@ A reference to the current session.
=cut
sub new {
my $class = shift;
my $session = shift;
my $self = bless \do {my $s}, $class;
register($self);
$session{id $self} = $session;
return $self;
}
#-------------------------------------------------------------------
=head2 replaceKeyword ( { currentKeyword => $keyword1, newKeyword => $keyword2 } )

3
lib/WebGUI/Macro/Env.pm
View file

@ -32,7 +32,8 @@ then undef will be returned.
#-------------------------------------------------------------------
sub process {
my $session = shift;
return $session->env->get(shift);
my $key = shift;
return $session->request->env->{$key};
}
1;

6
lib/WebGUI/Macro/L_loginBox.pm
View file

@ -79,18 +79,18 @@ sub process {
# A hidden field with the current URL
my $returnUrl = $session->url->page;
if ( !$session->form->get("op") eq "auth" ) {
$returnUrl .= '?' . $session->env->get( "QUERY_STRING" );
$returnUrl .= '?' . $session->request->env->{ "QUERY_STRING" };
}
$var{'form.returnUrl'}
= WebGUI::Form::hidden( $session, {
name => 'returnUrl',
value => $session->url->page($session->env->get("QUERY_STRING")),
value => $session->url->page($session->request->env->{"QUERY_STRING"}),
});
# Fix box size
my $boxSize = $param[0];
$boxSize = 12 unless ($boxSize);
if (index(lc($session->env->get("HTTP_USER_AGENT")),"msie") < 0) {
if (index(lc($session->request->user_agent),"msie") < 0) {
$boxSize = int($boxSize=$boxSize*2/3);
}

2
lib/WebGUI/Macro/r_printable.pm
View file

@ -54,7 +54,7 @@ sub process {
my $append = 'op=makePrintable';
$temp = $session->url->page($append);
$temp =~ s/\/\//\//;
$temp = $session->url->append($temp,$session->env->get("QUERY_STRING"));
$temp = $session->url->append($temp,$session->request->env->{"QUERY_STRING"});
if ($param[1] ne "") {
$temp = $session->url->append($temp,'styleId='.$param[1]);
}

64
lib/WebGUI/Middleware/Maintenance.pm Normal file
View file

@ -0,0 +1,64 @@
package WebGUI::Middleware::Maintenance;
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=cut
use strict;
use parent qw(Plack::Middleware);
=head1 NAME
Package WebGUI::Content::Maintenance;
=head1 DESCRIPTION
A content handler that displays a maintenance page while upgrading.
=head1 SYNOPSIS
enable '+WebGUI::Middleware::Maintenance';
=head1 SUBROUTINES
These subroutines are available from this package:
=cut
#-------------------------------------------------------------------
=head2 handler ( session )
The content handler for this package.
=cut
sub call {
my $self = shift;
my $env = shift;
my $session = $env->{'webgui.session'};
my $upgradeState = $session->setting->get('upgradeState');
if ($upgradeState) {
if ($upgradeState eq WebGUI->VERSION) {
$session->setting->remove('upgradeState');
}
else {
return [ 503, ['Content-Type' => 'text/plain'], [ 'Service Unavailable' ] ];
}
}
return $self->app->($env);
}
1;

2
lib/WebGUI/Operation/Cron.pm
View file

@ -271,7 +271,7 @@ sub www_runCronJob {
my $session = shift;
$session->http->setMimeType("text/plain");
$session->http->setCacheControl("none");
unless (isInSubnet($session->env->getIp, $session->config->get("spectreSubnets")) || canView($session)) {
unless (isInSubnet($session->request->address, $session->config->get("spectreSubnets")) || canView($session)) {
$session->errorHandler->security("make a Spectre cron job runner request, but we're only allowed to accept requests from ".join(",",@{$session->config->get("spectreSubnets")}).".");
return "error";
}

4
lib/WebGUI/Operation/Spectre.pm
View file

@ -59,7 +59,7 @@ sub www_spectreGetSiteData {
if (!defined $subnets) {
$subnets = [];
}
if (!isInSubnet($session->env->getIp, $subnets)) {
if (!isInSubnet($session->request->address, $subnets)) {
$session->errorHandler->security("Tried to make a Spectre workflow data load request, but we're only allowed to accept requests from "
.join(",",@{$subnets}).".");
}
@ -181,7 +181,7 @@ sub www_spectreTest {
$subnets = [];
}
my $sessionIp = $session->env->getIp;
my $sessionIp = $session->request->address;
unless (isInSubnet($sessionIp, $subnets)) {
$session->errorHandler->security(
sprintf "Tried to make a Spectre workflow runner request from %s, but we're only allowed to accept requests from %s",

2
lib/WebGUI/Operation/User.pm
View file

@ -141,7 +141,7 @@ sub canUseService {
my ( $session ) = @_;
my $subnets = $session->config->get('serviceSubnets');
return 1 if !$subnets || !@{$subnets};
return 1 if WebGUI::Utility::isInSubnet( $session->env->getIp, $subnets );
return 1 if WebGUI::Utility::isInSubnet( $session->request->address, $subnets );
return 0; # Don't go away mad, just go away
}

2
lib/WebGUI/Operation/Workflow.pm
View file

@ -482,7 +482,7 @@ sub www_runWorkflow {
my $session = shift;
$session->http->setMimeType("text/plain");
$session->http->setCacheControl("none");
unless (isInSubnet($session->env->getIp, $session->config->get("spectreSubnets")) || canRunWorkflow($session)) {
unless (isInSubnet($session->request->address, $session->config->get("spectreSubnets")) || canRunWorkflow($session)) {
$session->errorHandler->security("make a Spectre workflow runner request, but we're only allowed to accept requests from ".join(",",@{$session->config->get("spectreSubnets")}).".");
return "error";
}

11
lib/WebGUI/Paths.pm
View file

@ -85,7 +85,7 @@ Returns the base directory of the default site uploads content.
Returns the file path of the default site create.sql script.
=head2 var
=head2 share
Returns the base directory for WebGUI auxiliary files.
@ -102,12 +102,12 @@ BEGIN {
spectreConfig => catfile($root, 'etc', 'spectre.conf'),
preloadCustom => catfile($root, 'etc', 'preload.custom'),
preloadExclusions => catfile($root, 'etc', 'preload.exclude'),
upgrades => catdir($root, 'var', 'upgrades'),
upgrades => catdir($root, 'share', 'upgrades'),
extras => catdir($root, 'www', 'extras'),
defaultUploads => catdir($root, 'www', 'uploads'),
defaultCreateSQL => catdir($root, 'docs', 'create.sql'),
var => catdir($root, 'var'),
defaultPSGI => catdir($root, 'var', 'site.psgi'),
defaultCreateSQL => catdir($root, 'share', 'create.sql'),
share => catdir($root, 'share'),
defaultPSGI => catdir($root, 'share', 'site.psgi'),
);
my $meta = Class::MOP::Class->initialize(__PACKAGE__);
for my $sub (keys %paths) {
@ -203,6 +203,7 @@ Returns the list of modules to exclude from preloading as an array.
sub preloadExclude {
my $class = shift;
my @excludes = _readTextLines($class->preloadExclusions);
push @excludes, 'WebGUI::Upgrade', 'WebGUI::Upgrade::*';
return @excludes;
}

51
lib/WebGUI/Session.pm
View file

@ -20,11 +20,12 @@ use 5.010;
use CHI;
use File::Temp qw( tempdir );
use Scalar::Util qw( weaken );
use HTTP::Message::PSGI;
use HTTP::Request::Common;
use WebGUI::Config;
use WebGUI::SQL;
use WebGUI::User;
use WebGUI::Session::DateTime;
use WebGUI::Session::Env;
use WebGUI::Session::ErrorHandler;
use WebGUI::Session::Form;
use WebGUI::Session::Http;
@ -64,7 +65,6 @@ B<NOTE:> It is important to distinguish the difference between a WebGUI session
$session->datetime
$session->db
$session->dbSlave
$session->env
$session->log
$session->form
$session->http
@ -169,9 +169,15 @@ sub close {
# Kill circular references. The literal list is so that the order
# can be explicitly shuffled as necessary.
foreach my $key (qw/_asset _datetime _icon _slave _db _env _form _http _id _output _privilege _scratch _setting _stow _style _url _user _var _cache _errorHandler _response _request/) {
foreach my $key (qw/_asset _datetime _icon _slave _db _form _http _id _output _privilege _scratch _setting _stow _style _url _user _var _cache _errorHandler _response _request/) {
delete $self->{$key};
}
$self->{closed} = 1;
}
sub closed {
my $self = shift;
return $self->{closed};
}
#-------------------------------------------------------------------
@ -306,23 +312,6 @@ sub duplicate {
}
#-------------------------------------------------------------------
=head2 env ( )
Returns a WebGUI::Session::Env object.
=cut
sub env {
my $self = shift;
unless (exists $self->{_env}) {
$self->{_env} = WebGUI::Session::Env->new($self);
}
return $self->{_env};
}
#-------------------------------------------------------------------
=head2 errorHandler ( )
@ -480,15 +469,21 @@ sub open {
my $self = { _config => $config };
bless $self, $class;
if ($env) {
my $request = WebGUI::Session::Request->new($env);
$self->{_request} = $request;
$self->{_response} = $request->new_response( 200 );
# Use the WebGUI::Session::Request object to look up the sessionId from cookies, if it
# wasn't given explicitly
$sessionId ||= $request->cookies->{$config->getCookieName};
##No env was passed, so construct one
if (! $env) {
my $url = 'http://' . $config->get('sitename')->[0];
my $request = HTTP::Request::Common::GET($url);
$request->headers->user_agent('WebGUI');
$env = $request->to_psgi;
}
my $request = WebGUI::Session::Request->new($env);
$self->{_request} = $request;
$self->{_response} = $request->new_response( 200 );
# Use the WebGUI::Session::Request object to look up the sessionId from cookies, if it
# wasn't given explicitly
$sessionId ||= $request->cookies->{$config->getCookieName};
# If the sessionId is still unset or is invalid, generate a new one
if (!$sessionId || !$self->id->valid($sessionId)) {

193
lib/WebGUI/Session/Env.pm
View file

@ -1,193 +0,0 @@
package WebGUI::Session::Env;
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=cut
use strict;
=head1 NAME
Package WebGUI::Session::Env
=head1 DESCRIPTION
This package allows you to reference environment variables.
=head1 SYNOPSIS
$env = WebGUI::Session::Env->new;
$value = $env->get('REMOTE_ADDR');
return 'not gonna see it' if $env->requestNotViewed() ;
=head1 METHODS
These methods are available from this package:
=cut
#-------------------------------------------------------------------
=head2 callerIsSearchSite ( )
Returns true if the remote address matches a site which is a known indexer or spider.
=cut
sub callerIsSearchSite {
my $self = shift;
my $remoteAddress = $self->getIp;
return 1 if $remoteAddress =~ /203\.87\.123\.1../ # Blaiz Enterprise Rawgrunt search
|| $remoteAddress =~ /123\.113\.184\.2../ # Unknown Yahoo Robot
|| $remoteAddress == '';
return 0;
}
#-------------------------------------------------------------------
=head2 clientIsSpider ( )
Returns true is the client/agent is a spider/indexer or some other non-human interface, determined
by checking the user agent against a list of known spiders.
=cut
sub clientIsSpider {
my $self = shift;
my $userAgent = $self->get('HTTP_USER_AGENT');
return 1 if $userAgent eq ''
|| $userAgent =~ m<(^wre\/| # the WRE wget's http://localhost/ every 2-3 minutes 24 hours a day...
^morpheus|
libwww|
s[pb]ider|
bot|
robo|
sco[ou]t|
crawl|
miner|
reaper|
finder|
search|
engine|
download|
fetch|
scan|
slurp)>ix;
return 0;
}
#-------------------------------------------------------------------
=head2 get( varName )
Retrieves the current value of an environment variable.
=head3 varName
The name of the variable.
=cut
sub get {
my $self = shift;
my $var = shift;
return $$self->{$var};
}
#-------------------------------------------------------------------
=head2 getIp ( )
Returns the user's IP address.
=cut
sub getIp {
my $self = shift;
return $self->get('REMOTE_ADDR');
}
#-------------------------------------------------------------------
=head2 new ( )
Constructor. Returns an env object.
=cut
sub new {
my $class = shift;
my $session = shift;
my $env;
if ($session->request) {
$env = $session->request->env;
}
else {
$env = {};
}
return bless \$env, $class;
}
#-------------------------------------------------------------------
=head2 requestNotViewed ( )
Returns true is the client/agent is a spider/indexer or some other non-human interface
=cut
sub requestNotViewed {
my $self = shift;
return $self->clientIsSpider();
# || $self->callerIsSearchSite(); # this part is currently left out because
# it has minimal effect and does not manage
# IPv6 addresses. it may be useful in the
# future though
}
#-------------------------------------------------------------------
=head2 sslRequest ( )
Returns true if a https request was made.
HTTP_SSLPROXY is set by mod_proxy in the WRE so that WebGUI knows that the original request
was made via SSL.
=cut
sub sslRequest {
my $self = shift;
return $self->get('psgi.url_scheme') eq 'https';
}
1;

2
lib/WebGUI/Session/ErrorHandler.pm
View file

@ -253,7 +253,7 @@ sub security {
my $self = shift;
my $message = shift;
@_ = ($self, $self->session->user->username." (".$self->session->user->userId.") connecting from "
.$self->session->env->getIp." attempted to ".$message);
.$self->session->request->address." attempted to ".$message);
goto $self->can('warn');
}

84
lib/WebGUI/Session/Request.pm
View file

@ -17,6 +17,68 @@ is created.
=head1 METHODS
=cut
#-------------------------------------------------------------------
=head2 clientIsSpider ( )
Returns true is the client/agent is a spider/indexer or some other non-human interface, determined
by checking the user agent against a list of known spiders.
=cut
sub clientIsSpider {
my $self = shift;
my $userAgent = $self->user_agent;
return 1 if $userAgent eq ''
|| $userAgent =~ m<(^wre\/| # the WRE wget's http://localhost/ every 2-3 minutes 24 hours a day...
^morpheus|
libwww|
s[pb]ider|
bot|
robo|
sco[ou]t|
crawl|
miner|
reaper|
finder|
search|
engine|
download|
fetch|
scan|
slurp)>ix;
return 0;
}
#-------------------------------------------------------------------
=head2 callerIsSearchSite ( )
Returns true if the remote address matches a site which is a known indexer or spider.
=cut
sub callerIsSearchSite {
my $self = shift;
my $remoteAddress = $self->address;
return 1 if $remoteAddress =~ /203\.87\.123\.1../ # Blaiz Enterprise Rawgrunt search
|| $remoteAddress =~ /123\.113\.184\.2../ # Unknown Yahoo Robot
|| $remoteAddress == '';
return 0;
}
#-------------------------------------------------------------------
=head2 new_response ()
Creates a new L<WebGUI::Session::Response> object.
@ -32,9 +94,29 @@ sub new_response {
return WebGUI::Session::Response->new(@_);
}
#-------------------------------------------------------------------
=head2 requestNotViewed ( )
Returns true is the client/agent is a spider/indexer or some other non-human interface
=cut
sub requestNotViewed {
my $self = shift;
return $self->clientIsSpider();
# || $self->callerIsSearchSite(); # this part is currently left out because
# it has minimal effect and does not manage
# IPv6 addresses. it may be useful in the
# future though
}
# This is only temporary
sub TRACE {
shift->env->{'psgi.errors'}->print(join '', @_, "\n");
}
1;
1;

2
lib/WebGUI/Session/Style.pm
View file

@ -131,7 +131,7 @@ sub useMobileStyle {
if (! $session->setting->get('useMobileStyle')) {
return $self->{_useMobileStyle} = 0;
}
my $ua = $session->env->get('HTTP_USER_AGENT');
my $ua = $session->request->user_agent;
for my $mobileUA (@{ $self->session->config->get('mobileUserAgents') }) {
if ($ua =~ m/$mobileUA/) {
return $self->{_useMobileStyle} = 1;

20
lib/WebGUI/Session/Url.pm
View file

@ -136,7 +136,7 @@ sub extras {
my $cdnCfg = $self->session->config->get('cdn');
if ( $cdnCfg and $cdnCfg->{'enabled'} and $cdnCfg->{'extrasCdn'} ) {
unless ( $path and grep $path =~ m/$_/, @{ $cdnCfg->{'extrasExclude'} } ) {
if ($cdnCfg->{'extrasSsl'} && $self->session->env->sslRequest) {
if ($cdnCfg->{'extrasSsl'} && $self->session->request->secure) {
$url = $cdnCfg->{'extrasSsl'};
}
else {
@ -258,7 +258,7 @@ Returns the URL of the page this request was refered from (no gateway, no query
sub getRefererUrl {
my $self = shift;
my $referer = $self->session->env->get("HTTP_REFERER");
my $referer = $self->session->request->referer;
return undef unless ($referer);
my $url = $referer;
my $gateway = $self->session->config->get("gateway");
@ -289,20 +289,20 @@ is not passed in, it will attempt to get one from the L<page> method, or finally
sub forceSecureConnection {
my $self = shift;
my $url = shift;
my ($conf, $env, $http) = $self->session->quick(qw(config env http));
my ($conf, $http) = $self->session->quick(qw(config http));
if ($conf->get("sslEnabled") && !$env->sslRequest){
if ($conf->get("sslEnabled") && ! $self->session->request->secure){
$url = $self->session->url->page if(! $url);
$url = $env->get('QUERY_STRING') if(! $url);
my $query_string = $self->session->request->env->{'QUERY_STRING'};
$url = $url || $self->page || $query_string;
my $siteURL = $self->getSiteURL();
if($url !~ /^$siteURL/i){
$url = $siteURL . $url;
}
if($env->get('QUERY_STRING')){
$url .= "?". $env->get('QUERY_STRING');
if($query_string){
$url .= "?". $query_string;
}
if($url =~ /^http/i) {
$url =~ s/^https?/https/i;
@ -347,14 +347,14 @@ sub getSiteURL {
unless ($self->{_siteUrl}) {
my $site = "";
my $sitenames = $self->session->config->get("sitename");
my ($http_host,$currentPort) = split(':', $self->session->env->get("HTTP_HOST"));
my ($http_host,$currentPort) = split(':', $self->session->request->env->{"HTTP_HOST"});
if ($self->session->setting->get("hostToUse") eq "HTTP_HOST" and isIn($http_host,@{$sitenames})) {
$site = $http_host;
} else {
$site = $sitenames->[0];
}
my $proto = "http://";
if ($self->session->env->sslRequest) {
if ($self->session->request->secure) {
$proto = "https://";
}
my $port = "";

4
lib/WebGUI/Session/Var.pm
View file

@ -182,7 +182,7 @@ sub new {
my $time = time();
my $timeout = $session->setting->get("sessionTimeout");
$self->{_var}{lastPageView} = $time;
$self->{_var}{lastIP} = $session->env->getIp;
$self->{_var}{lastIP} = $session->request->address;
$self->{_var}{expires} = $time + $timeout;
if ($self->{_var}{nextCacheFlush} > 0 && $self->{_var}{nextCacheFlush} < $time) {
delete $self->{_var}{nextCacheFlush};
@ -247,7 +247,7 @@ sub start {
$self->{_var} = {
expires => $time + $timeout,
lastPageView => $time,
lastIP => $session->env->getIp,
lastIP => $session->request->address,
adminOn => 0,
userId => $userId
};

404
lib/WebGUI/Shop/Address.pm
View file

@ -15,7 +15,85 @@ package WebGUI::Shop::Address;
=cut
use strict;
use Class::InsideOut qw{ :std };
use Moose;
use WebGUI::Definition;
property label => (
noFormPost => 1,
default => '',
);
property firstName => (
noFormPost => 1,
default => '',
);
property lastName => (
noFormPost => 1,
default => '',
);
property address1 => (
noFormPost => 1,
default => '',
);
property address2 => (
noFormPost => 1,
default => '',
);
property address3 => (
noFormPost => 1,
default => '',
);
property city => (
noFormPost => 1,
default => '',
);
property state => (
noFormPost => 1,
default => '',
);
property code => (
noFormPost => 1,
default => '',
);
property country => (
noFormPost => 1,
default => '',
);
property phoneNumber => (
noFormPost => 1,
default => '',
);
property email => (
noFormPost => 1,
default => '',
);
property organization => (
noFormPost => 1,
default => '',
);
property "addressBookId" => (
noFormPost => 1,
required => 1,
);
has [ qw/addressId addressBook/] => (
is => 'ro',
required => 1,
);
use Scalar::Util qw/blessed/;
use WebGUI::Exception::Shop;
=head1 NAME
@ -39,166 +117,30 @@ These subroutines are available from this package:
=cut
readonly addressBook => my %addressBook;
private properties => my %properties;
#-------------------------------------------------------------------
=head2 addressBook ( )
=head2 new ( $book, $addressId )
Returns a reference to the Address Book.
Constructor. Instanciates an address based upon an addressId.
=cut
=head2 new ( $book, $properties )
#-------------------------------------------------------------------
Constructor. Builds a new, default address.
=head2 create ( addressBook, address)
=head2 new ( $properties )
Constructor. Adds an address to an address book. Returns a reference to the address.
Constructor. Builds a new, default address book object in Moose style with default properties set by $properties. This does not
persist them to the database automatically. This needs to be done via $self->write.
=head3 addressBook
=head3 $addressBook
A reference to a WebGUI::Shop::AddressBook object.
A reference to an addressBook object
=head3 address
=head3 $addressId
A hash reference containing the properties to set in the address.
The unique id of an address to instanciate.
=cut
sub create {
my ($class, $book, $addressData) = @_;
unless (defined $book && $book->isa("WebGUI::Shop::AddressBook")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Shop::AddressBook", got=>(ref $book), error=>"Need an address book.", param=>$book);
}
unless (defined $addressData && ref $addressData eq "HASH") {
WebGUI::Error::InvalidParam->throw(param=>$addressData, error=>"Need a hash reference.");
}
my $id = $book->session->db->setRow("address","addressId", {addressId=>"new", addressBookId=>$book->getId});
my $address = $class->new($book, $id);
$address->update($addressData);
return $address;
}
#-------------------------------------------------------------------
=head2 delete ( )
Removes this address from the book.
=cut
sub delete {
my $self = shift;
$self->addressBook->session->db->deleteRow("address","addressId",$self->getId);
return undef;
}
#-------------------------------------------------------------------
=head2 get ( [ property ] )
Returns a duplicated hash reference of this object’s data.
=head3 property
Any field − returns the value of a field rather than the hash reference.
=cut
sub get {
my ($self, $name) = @_;
if (defined $name) {
return $properties{id $self}{$name};
}
my %copyOfHashRef = %{$properties{id $self}};
return \%copyOfHashRef;
}
#-------------------------------------------------------------------
=head2 getHtmlFormatted ()
Returns an HTML formatted address for display.
=cut
sub getHtmlFormatted {
my $self = shift;
my $address = $self->get("firstName"). " " .$self->get("lastName") . "<br />";
$address .= $self->get("organization") . "<br />" if ($self->get("organization") ne "");
$address .= $self->get("address1") . "<br />";
$address .= $self->get("address2") . "<br />" if ($self->get("address2") ne "");
$address .= $self->get("address3") . "<br />" if ($self->get("address3") ne "");
$address .= $self->get("city") . ", ";
$address .= $self->get("state") . " " if ($self->get("state") ne "");
$address .= $self->get("code") if ($self->get("code") ne "");
$address .= '<br />' . $self->get("country");
$address .= '<br />'.$self->get("phoneNumber") if ($self->get("phoneNumber") ne "");
$address .= '<br /><a href="mailto:'.$self->get("email").'">'.$self->get("email").'</a>' if ($self->get("email") ne "");
return $address;
}
#-------------------------------------------------------------------
=head2 getId ()
Returns the unique id of this item.
=cut
sub getId {
my $self = shift;
return $self->get("addressId");
}
#-------------------------------------------------------------------
=head2 new ( addressBook, addressId )
Constructor. Instanciates an existing address from the database based upon addressId.
=head3 addressBook
A reference to a WebGUI::Shop::AdressBook object.
=head3 addressId
The unique id of the address to instanciate.
=cut
sub new {
my ($class, $book, $addressId) = @_;
unless (defined $book && $book->isa("WebGUI::Shop::AddressBook")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Shop::AddressBook", got=>(ref $book), error=>"Need an address book.");
}
unless (defined $addressId) {
WebGUI::Error::InvalidParam->throw(error=>"Need an addressId.", param=>$addressId);
}
my $address = $book->session->db->quickHashRef('select * from address where addressId=?', [$addressId]);
if ($address->{addressId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"Address not found.", id=>$addressId);
}
if ($address->{addressBookId} ne $book->getId) {
WebGUI::Error::ObjectNotFound->throw(error=>"Address not in this address book.", id=>$addressId);
}
my $self = register $class;
my $id = id $self;
$addressBook{ $id } = $book;
$properties{ $id } = $address;
return $self;
}
#-------------------------------------------------------------------
=head2 update ( properties )
Sets properties of the address.
=head3 properties
=head3 $properties
A hash reference that contains one or more of the following:
@ -254,19 +196,165 @@ An email address for this user.
The organization or company that this user is a part of.
=head4 addressBookId
=cut
The address book that this address belongs to.
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
if (ref $_[0] eq 'HASH') {
my $properties = $_[0];
my $book = $properties->{addressBook};
if (! (blessed $book && $book->isa('WebGUI::Shop::AddressBook')) ) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Shop::AddressBook", got=>(ref $book), error=>"Need an address book.", param=>$book);
}
my ($addressId) = $class->_init($book);
$properties->{addressId} = $addressId;
$properties->{addressBookId} = $book->addressBookId;
$properties->{addressBook} = $book;
return $class->$orig($properties);
}
my $book = shift;
if (! (blessed $book && $book->isa('WebGUI::Shop::AddressBook')) ) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Shop::AddressBook", got=>(ref $book), error=>"Need an address book.", param=>$book);
}
my $argument2 = shift;
if (!defined $argument2) {
my ($addressId) = $class->_init($book);
my $properties = {};
$properties->{addressId} = $addressId;
$properties->{addressBookId} = $book->addressBookId;
$properties->{addressBook} = $book;
return $class->$orig($properties);
}
elsif (ref $argument2 eq 'HASH') {
my $properties = $argument2;
my ($addressId) = $class->_init($book);
$properties->{addressId} = $addressId;
$properties->{addressBookId} = $book->addressBookId;
$properties->{addressBook} = $book;
return $class->$orig($properties);
}
##Look up one in the db
my $address = $book->session->db->quickHashRef("select * from address where addressId=?", [$argument2]);
if ($address->{addressId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"Address not found.", id=>$argument2);
}
if ($address->{addressBookId} ne $book->getId) {
WebGUI::Error::ObjectNotFound->throw(error=>"Address not in this address book.", id=>$argument2);
}
$address->{addressBook} = $book;
return $class->$orig($address);
};
#-------------------------------------------------------------------
=head2 _init ( session )
Builds a stub of object information in the database, and returns the newly created
addressId, and the creationDate fields so the object can be initialized correctly.
=cut
sub update {
my ($self, $newProperties) = @_;
my $id = id $self;
foreach my $field (qw(addressBookId email organization address1 address2 address3 state code city label firstName lastName country phoneNumber)) {
$properties{$id}{$field} = (exists $newProperties->{$field}) ? $newProperties->{$field} : $properties{$id}{$field};
}
$self->addressBook->session->db->setRow("address","addressId",$properties{$id});
sub _init {
my $class = shift;
my $book = shift;
my $session = $book->session;
my $addressId = $session->id->generate;
$session->db->write('insert into address (addressId, addressBookId) values (?,?)', [$addressId, $book->getId]);
return ($addressId);
}
#-------------------------------------------------------------------
=head2 addressBook ( )
Returns a reference to the Address Book.
=cut
#-------------------------------------------------------------------
=head2 create ( book )
Deprecated, left as a stub for existing code. Use L<new> instead.
=head3 book
A reference to an address book.
=cut
sub create {
my ($class, $book) = @_;
return $class->new($book);
}
#-------------------------------------------------------------------
=head2 delete ( )
Removes this address from the book.
=cut
sub delete {
my $self = shift;
$self->addressBook->session->db->deleteRow("address","addressId",$self->getId);
return undef;
}
#-------------------------------------------------------------------
=head2 getHtmlFormatted ()
Returns an HTML formatted address for display.
=cut
sub getHtmlFormatted {
my $self = shift;
my $address = $self->firstName. " " .$self->lastName . "<br />";
$address .= $self->organization . "<br />" if ($self->organization ne "");
$address .= $self->address1 . "<br />";
$address .= $self->address2 . "<br />" if ($self->address2 ne "");
$address .= $self->address3 . "<br />" if ($self->address3 ne "");
$address .= $self->city . ", ";
$address .= $self->state . " " if ($self->state ne "");
$address .= $self->code if ($self->code ne "");
$address .= '<br />' . $self->country;
$address .= '<br />'.$self->phoneNumber if ($self->phoneNumber ne "");
$address .= '<br /><a href="mailto:'.$self->email.'">'.$self->email.'</a>' if ($self->email ne "");
return $address;
}
#-------------------------------------------------------------------
=head2 getId ()
Returns the unique id of this item.
=cut
sub getId {
my $self = shift;
return $self->get("addressId");
}
#-------------------------------------------------------------------
=head2 write ( )
Store the object's properties to the db.
=cut
sub write {
my ($self) = @_;
my $properties = $self->get();
my $book = delete $properties->{addressBook};
$book->session->db->setRow("address","addressId",$properties);
}

236
lib/WebGUI/Shop/AddressBook.pm
View file

@ -2,7 +2,25 @@ package WebGUI::Shop::AddressBook;
use strict;
use Class::InsideOut qw{ :std };
use Moose;
use WebGUI::Definition;
property 'userId' => (
noFormPost => 1,
default => '',
);
property 'defaultAddressId' => (
noFormPost => 1,
default => '',
);
has [ qw/addressBookId session/] => (
is => 'ro',
required => 1,
);
use JSON;
require WebGUI::Asset::Template;
use WebGUI::Exception::Shop;
@ -31,9 +49,103 @@ These subroutines are available from this package:
=cut
readonly session => my %session;
private properties => my %properties;
private addressCache => my %addressCache;
#-------------------------------------------------------------------
=head2 new ( $session, $addressBookId )
Constructor. Instanciates an address book based upon an addressBookId.
=head2 new ( $session )
Constructor. Builds a new, default address book object.
=head2 new ( $properties )
Constructor. Builds a new, default address book object in Moose style with default properties set by $properties. This does not
persist them to the database automatically. This needs to be done via $self->write.
=head3 $session
A reference to the current session.
=head3 $addressBookId
The unique id of a cart to instanciate.
=head3 $properties
A hash reference that contains one or more of the following:
=head4 defaultAddressId
The unique id for a address attached to this cart.
=head4 userId
The unique id for the user who owns this cart.
=cut
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
if (ref $_[0] eq 'HASH') {
my $properties = $_[0];
my $session = $properties->{session};
if (! (blessed $session && $session->isa('WebGUI::Session')) ) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
if ($session->user->isVisitor) {
WebGUI::Error::InvalidParam->throw(error=>"Visitor cannot have an address book.");
}
my ($addressBookId) = $class->_init($session);
$properties->{addressBookId} = $addressBookId;
$properties->{userId} = $session->user->userId;
return $class->$orig($properties);
}
my $session = shift;
if (! (blessed $session && $session->isa('WebGUI::Session'))) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
if ($session->user->isVisitor) {
WebGUI::Error::InvalidParam->throw(error=>"Visitor cannot have an address book.");
}
my $argument2 = shift;
if (!defined $argument2) {
my ($addressBookId) = $class->_init($session);
my $properties = {};
$properties->{session} = $session;
$properties->{addressBookId} = $addressBookId;
$properties->{userId} = $session->user->userId;
return $class->$orig($properties);
}
##Look up one in the db
my $book = $session->db->quickHashRef("select * from addressBook where addressBookId=?", [$argument2]);
if ($book->{addressBookId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"No such address book.", id=>$argument2);
}
$book->{session} = $session;
return $class->$orig($book);
};
#-------------------------------------------------------------------
=head2 _init ( session )
Builds a stub of object information in the database, and returns the newly created
addressBookId, and the creationDate fields so the object can be initialized correctly.
=cut
sub _init {
my $class = shift;
my $session = shift;
my $addressBookId = $session->id->generate;
$session->db->write('insert into addressBook (addressBookId, userId) values (?,?)', [$addressBookId, $session->user->userId]);
return ($addressBookId);
}
#-------------------------------------------------------------------
@ -51,7 +163,8 @@ A hash reference containing address information.
sub addAddress {
my ($self, $address) = @_;
my $addressObj = WebGUI::Shop::Address->create( $self, $address);
my $addressObj = WebGUI::Shop::Address->create($self);
$addressObj->update($address);
return $addressObj;
}
@ -114,32 +227,19 @@ sub appendAddressFormVars {
#-------------------------------------------------------------------
=head2 create ( session, userId )
=head2 create ( session )
Constructor. Creates a new address book for this user.
Deprecated, left as a stub for existing code. Use L<new> instead.
=head3 session
A reference to the current session.
=head3 userId
The userId for the user. Throws an exception if it is Visitor. Defaults to the session
user if omitted.
=cut
sub create {
my ($class, $session, $userId) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
$userId ||= $session->user->userId;
if ($userId eq '1') {
WebGUI::Error::InvalidParam->throw(error=>"Visitor cannot have an address book.");
}
my $id = $session->db->setRow("addressBook", "addressBookId", {addressBookId=>"new", userId=>$userId});
return $class->new($session, $id);
my ($class, $session) = @_;
return $class->new($session);
}
#-------------------------------------------------------------------
@ -152,9 +252,7 @@ Deletes this address book and all addresses contained in it.
sub delete {
my ($self) = @_;
my $myId = id $self;
foreach my $address (@{$self->getAddresses}) {
delete $addressCache{$myId}{$address->getId};
$address->delete;
}
$self->session->db->write("delete from addressBook where addressBookId=?",[$self->getId]);
@ -181,28 +279,6 @@ sub formatCallbackForm {
#-------------------------------------------------------------------
=head2 get ( [ property ] )
Returns a duplicated hash reference of this object’s data.
=head3 property
Any field − returns the value of a field rather than the hash reference. See the
C<update> method.
=cut
sub get {
my ($self, $name) = @_;
if (defined $name) {
return $properties{id $self}{$name};
}
my %copyOfHashRef = %{$properties{id $self}};
return \%copyOfHashRef;
}
#-------------------------------------------------------------------
=head2 getAddress ( id )
Returns an address object.
@ -215,11 +291,10 @@ An address object's unique id.
sub getAddress {
my ($self, $addressId) = @_;
my $id = id $self;
unless (exists $addressCache{$id}{$addressId}) {
$addressCache{$id}{$addressId} = WebGUI::Shop::Address->new($self, $addressId);
unless (exists $self->{_addressCache}->{$addressId}) {
$self->{_addressCache}->{$addressId} = WebGUI::Shop::Address->new($self, $addressId);
}
return $addressCache{$id}{$addressId};
return $self->{_addressCache}->{$addressId};
}
#-------------------------------------------------------------------
@ -337,41 +412,6 @@ sub missingFields {
#-------------------------------------------------------------------
=head2 new ( session, addressBookId )
Constructor. Instanciates an addressBook based upon a addressBookId.
=head3 session
A reference to the current session.
=head3 addressBookId
The unique id of an address book to instanciate.
=cut
sub new {
my ($class, $session, $addressBookId) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
unless (defined $addressBookId) {
WebGUI::Error::InvalidParam->throw(error=>"Need an addressBookId.");
}
my $addressBook = $session->db->quickHashRef('select * from addressBook where addressBookId=?', [$addressBookId]);
if ($addressBook->{addressBookId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"No such address book.", id=>$addressBookId);
}
my $self = register $class;
my $id = id $self;
$session{ $id } = $session;
$properties{ $id } = $addressBook;
return $self;
}
#-------------------------------------------------------------------
=head2 newByUserId ( session, userId )
Constructor. Creates a new address book for this user if they don't have one. In any case returns a reference to the address book.
@ -418,7 +458,7 @@ sub newByUserId {
}
else {
# nope create one for the user
return $class->create($session);
return $class->new($session);
}
}
@ -465,31 +505,15 @@ sub processAddressForm {
#-------------------------------------------------------------------
=head2 update ( properties )
=head2 write ( )
Sets properties in the addressBook
=head3 properties
A hash reference that contains one of the following:
=head4 userId
Assign the user that owns this address book.
=head4 defaultAddressId
The id of the address to be made the default for this address book.
Writes the object properties to the database.
=cut
sub update {
sub write {
my ($self, $newProperties) = @_;
my $id = id $self;
foreach my $field (qw(userId defaultAddressId)) {
$properties{$id}{$field} = (exists $newProperties->{$field}) ? $newProperties->{$field} : $properties{$id}{$field};
}
$self->session->db->setRow("addressBook","addressBookId",$properties{$id});
$self->session->db->setRow("addressBook","addressBookId",$self->get());
}
#-------------------------------------------------------------------

35
lib/WebGUI/Shop/Admin.pm
View file

@ -1,7 +1,27 @@
package WebGUI::Shop::Admin;
use strict;
use Class::InsideOut qw{ :std };
use Moose;
has session => (
is => 'ro',
required => 1,
);
around BUILDARGS => sub {
my $orig = shift;
my $className = shift;
##Original arguments start here.
my $protoSession = $_[0];
if (blessed $protoSession && $protoSession->isa('WebGUI::Session')) {
return $className->$orig(session => $protoSession);
}
return $className->$orig(@_);
};
use WebGUI::AdminConsole;
use WebGUI::Exception::Shop;
use WebGUI::HTMLForm;
@ -28,8 +48,6 @@ These subroutines are available from this package:
=cut
readonly session => my %session;
#-------------------------------------------------------------------
=head2 canManage ( [ $user ] )
@ -103,17 +121,6 @@ A reference to the current session.
=cut
sub new {
my ($class, $session) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my $self = register $class;
my $id = id $self;
$session{ $id } = $session;
return $self;
}
#-------------------------------------------------------------------
=head2 session ()

337
lib/WebGUI/Shop/Cart.pm
View file

@ -2,7 +2,58 @@ package WebGUI::Shop::Cart;
use strict;
use Class::InsideOut qw{ :std };
use Scalar::Util qw/blessed/;
use Moose;
use WebGUI::Definition;
property 'shippingAddressId' => (
noFormPost => 1,
default => '',
);
property 'billingAddressId' => (
noFormPost => 1,
default => '',
);
property 'shipperId' => (
noFormPost => 1,
default => '',
);
property 'gatewayId' => (
noFormPost => 1,
default => '',
);
property 'posUserId' => (
noFormPost => 1,
default => '',
);
property creationDate => (
required => 1,
noFormPost => 1,
default => '',
);
has [ qw/cartId session/] => (
is => 'ro',
required => 1,
);
has sessionId => (
is => 'ro',
lazy => 1,
builder => '_default_sessionId',
);
sub _default_sessionId {
my $self = shift;
return $self->session->getId;
}
has error => (
is => 'rw',
);
use JSON;
use WebGUI::Asset::Template;
use WebGUI::Exception::Shop;
@ -38,10 +89,110 @@ These subroutines are available from this package:
=cut
readonly session => my %session;
private properties => my %properties;
public error => my %error;
private addressBookCache => my %addressBookCache;
#-------------------------------------------------------------------
=head2 new ( $session, $cartId )
Constructor. Instanciates a cart based upon a cartId.
=head2 new ( $session )
Constructor. Builds a new, default cart object.
=head2 new ( $properties )
Constructor. Builds a new, default cart object in Moose style with default properties set by $properties. This does not
persist them to the database automatically. This needs to be done via $self->write.
=head3 $session
A reference to the current session.
=head3 $cartId
The unique id of a cart to instanciate.
=head3 $properties
A hash reference that contains one or more of the following:
=head4 shippingAddressId
The unique id for a shipping address attached to this cart.
=head4 billingAddressId
The unique id for a billing address attached to this cart.
=head4 shipperId
The unique id of the configured shipping driver that will be used to ship these goods.
=head4 posUserId
The ID of a user being checked out, if they're being checked out by a cashier.
=head4 creationDate
The date the cart was created.
=cut
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
if (ref $_[0] eq 'HASH') {
my $properties = $_[0];
my $session = $properties->{session};
if (! (blessed $session && $session->isa('WebGUI::Session')) ) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my ($cartId, $creationDate) = $class->_init($session);
$properties->{cartId} = $cartId;
$properties->{creationDate} = $creationDate;
return $class->$orig($properties);
}
my $session = shift;
if (! (blessed $session && $session->isa('WebGUI::Session'))) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my $argument2 = shift;
if (!defined $argument2) {
my ($cartId, $creationDate) = $class->_init($session);
my $properties = {};
$properties->{session} = $session;
$properties->{cartId} = $cartId;
$properties->{creationDate} = $creationDate;
return $class->$orig($properties);
}
##Look up one in the db
my $cart = $session->db->quickHashRef("select * from cart where cartId=?", [$argument2]);
if ($cart->{cartId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"No such cart.", id=>$argument2);
}
$cart->{session} = $session;
return $class->$orig($cart);
};
#-------------------------------------------------------------------
=head2 _init ( session )
Builds a stub of object information in the database, and returns the newly created
cartId, and the creationDate fields so the object can be initialized correctly.
=cut
sub _init {
my $class = shift;
my $session = shift;
my $creationDate = WebGUI::DateTime->new($session)->epoch;
my $cartId = $session->id->generate;
$session->db->write('insert into cart (cartId, sessionId, creationDate) values (?,?,?)', [$cartId, $session->getId, $creationDate]);
return ($cartId, $creationDate);
}
#-------------------------------------------------------------------
@ -83,7 +234,7 @@ sub calculateShopCreditDeduction {
}
# cannot use in-shop credit on recurring items
return $self->formatCurrency(0) if $self->requiresRecurringPayment;
return $self->formatCurrency(WebGUI::Shop::Credit->new($self->session, $self->get('posUserId'))->calculateDeduction($total));
return $self->formatCurrency(WebGUI::Shop::Credit->new($self->session, $self->posUserId)->calculateDeduction($total));
}
#-------------------------------------------------------------------
@ -160,7 +311,7 @@ sub calculateTotal {
=head2 create ( session )
Constructor. Creates a new cart object if there’s not one already attached to the current session object. Otherwise just instanciates the existing one. Returns a reference to the object.
Deprecated, left as a stub for existing code. Use L<new> instead.
=head3 session
@ -170,12 +321,7 @@ A reference to the current session.
sub create {
my ($class, $session) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my $cartId = $session->id->generate;
$session->db->write('insert into cart (cartId, sessionId, creationDate) values (?,?,UNIX_TIMESTAMP())', [$cartId, $session->getId]);
return $class->new($session, $cartId);
return $class->new($session);
}
#-------------------------------------------------------------------
@ -230,27 +376,6 @@ sub formatCurrency {
#-------------------------------------------------------------------
=head2 get ( [ property ] )
Returns a duplicated hash reference of this object’s data.
=head3 property
Any field − returns the value of a field rather than the hash reference.
=cut
sub get {
my ($self, $name) = @_;
if (defined $name) {
return $properties{id $self}{$name};
}
my %copyOfHashRef = %{$properties{id $self}};
return \%copyOfHashRef;
}
#-------------------------------------------------------------------
=head2 getAddressBook ()
Returns a reference to the address book for the user who's cart this is.
@ -259,11 +384,10 @@ Returns a reference to the address book for the user who's cart this is.
sub getAddressBook {
my $self = shift;
my $id = id $self;
unless (exists $addressBookCache{$id}) {
$addressBookCache{$id} = WebGUI::Shop::AddressBook->newByUserId($self->session);
unless (exists $self->{_addressBook}) {
$self->{_addressBook} = WebGUI::Shop::AddressBook->newByUserId($self->session);
}
return $addressBookCache{$id};
return $self->{_addressBook};
}
#-------------------------------------------------------------------
@ -277,7 +401,7 @@ Returns the WebGUI::Shop::Address object that is attached to this cart for billi
sub getBillingAddress {
my $self = shift;
my $book = $self->getAddressBook;
if (my $addressId = $self->get("billingAddressId")) {
if (my $addressId = $self->billingAddressId) {
return $book->getAddress($addressId);
}
my $address = $book->getDefaultAddress;
@ -332,7 +456,7 @@ Returns the unique id for this cart.
sub getId {
my ($self) = @_;
return $self->get("cartId");
return $self->cartId;
}
#-------------------------------------------------------------------
@ -409,7 +533,7 @@ Returns the WebGUI::Shop::PayDriver object that is attached to this cart for pay
sub getPaymentGateway {
my $self = shift;
return WebGUI::Shop::Pay->new($self->session)->getPaymentGateway($self->get("gatewayId"));
return WebGUI::Shop::Pay->new($self->session)->getPaymentGateway($self->gatewayId);
}
#-------------------------------------------------------------------
@ -422,7 +546,7 @@ Returns the userId of the user making a purchase. If there is a cashier and the
sub getPosUser {
my $self = shift;
if ($self->get('posUserId') ne "") {
if ($self->posUserId ne "") {
return WebGUI::User->new($self->session, $self->get('posUserId'));
}
return $self->session->user;
@ -438,7 +562,7 @@ Returns the WebGUI::Shop::ShipDriver object that is attached to this cart for sh
sub getShipper {
my $self = shift;
return WebGUI::Shop::Ship->new(session => $self->session)->getShipper($self->get("shipperId"));
return WebGUI::Shop::Ship->new(session => $self->session)->getShipper($self->shipperId);
}
#-------------------------------------------------------------------
@ -452,8 +576,8 @@ Returns the WebGUI::Shop::Address object that is attached to this cart for shipp
sub getShippingAddress {
my $self = shift;
my $book = $self->getAddressBook;
if ($self->get("shippingAddressId")) {
return $book->getAddress($self->get("shippingAddressId"));
if ($self->shippingAddressId) {
return $book->getAddress($self->shippingAddressId);
}
my $address = $book->getDefaultAddress;
$self->update({shippingAddressId=>$address->getId});
@ -487,41 +611,6 @@ sub hasMixedItems {
#-------------------------------------------------------------------
=head2 new ( session, cartId )
Constructor. Instanciates a cart based upon a cartId.
=head3 session
A reference to the current session.
=head3 cartId
The unique id of a cart to instanciate.
=cut
sub new {
my ($class, $session, $cartId) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
unless (defined $cartId && $cartId =~ m/^[A-Za-z0-9_-]{22}$/) {
WebGUI::Error::InvalidParam->throw(error=>"Need a cartId.");
}
my $cart = $session->db->quickHashRef('select * from cart where cartId=?', [$cartId]);
if ($cart->{cartId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"No such cart.", id=>$cartId);
}
my $self = register $class;
my $id = id $self;
$session{ $id } = $session;
$properties{ $id } = $cart;
return $self;
}
#-------------------------------------------------------------------
=head2 newBySession ( session )
Class method that figures out if the user has a cart in their session. If they do it returns it. If they don't it creates it and returns it.
@ -538,8 +627,7 @@ sub newBySession {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my $cartId = $session->db->quickScalar("select cartId from cart where sessionId=?",[$session->getId]);
return $class->new($session, $cartId) if (defined $cartId and $cartId ne '');
return $class->create($session);
return $class->new($session, $cartId); ##Falls back to creating a new cart if there's no 2nd argument
}
#-------------------------------------------------------------------
@ -597,12 +685,12 @@ sub readyForCheckout {
if ($self->requiresShipping) {
##Must have a configured shipping id.
if (! $self->get('shipperId')) {
if (! $self->shipperId) {
$self->error('no shipping method set');
return 0;
}
my $shipper = eval { WebGUI::Shop::ShipDriver->new($session, $self->get('shipperId'))};
my $shipper = eval { WebGUI::Shop::ShipDriver->new($session, $self->shipperId)};
if (my $e = WebGUI::Error->caught) {
$self->error($e->error);
return 0;
@ -628,19 +716,19 @@ sub readyForCheckout {
}
##Must have a configured payment method.
if (! $self->get('gatewayId')) {
if (! $self->gatewayId) {
$self->error('no payment gateway set');
return 0;
}
my $gateway = eval { WebGUI::Shop::PayDriver->new($session, $self->get('gatewayId'))};
my $gateway = eval { WebGUI::Shop::PayDriver->new($session, $self->gatewayId)};
if (my $e = WebGUI::Error->caught) {
$self->error($e->error);
return 0;
}
##Check for any other logged errors
return 0 if $error{ id $self };
return 0 if $self->error;
# All checks passed so return true
return 1;
@ -688,46 +776,17 @@ sub requiresShipping {
#-------------------------------------------------------------------
=head2 update ( properties )
=head2 write ( )
Sets properties in the cart.
=head3 properties
A hash reference that contains one of the following:
=head4 shippingAddressId
The unique id for a shipping address attached to this cart.
=head4 billingAddressId
The unique id for a billing address attached to this cart.
=head4 shipperId
The unique id of the configured shipping driver that will be used to ship these goods.
=head4 posUserId
The ID of a user being checked out, if they're being checked out by a cashier.
=head4 creationDate
The date the cart was created.
Serialize the current set of cart properties to the database.
=cut
sub update {
my ($self, $newProperties) = @_;
unless (defined $newProperties && ref $newProperties eq 'HASH') {
WebGUI::Error::InvalidParam->throw(error=>"Need a properties hash ref.");
}
my $id = id $self;
foreach my $field (qw(billingAddressId shippingAddressId posUserId gatewayId shipperId creationDate)) {
$properties{$id}{$field} = (exists $newProperties->{$field}) ? $newProperties->{$field} : $properties{$id}{$field};
}
$self->session->db->setRow("cart","cartId",$properties{$id});
sub write {
my ($self) = @_;
my $properties = $self->get();
delete $properties->{error};
$self->session->db->setRow("cart", "cartId", $properties);
}
#-------------------------------------------------------------------
@ -747,10 +806,10 @@ sub updateFromForm {
eval { $item->setQuantity($form->get("quantity-".$item->getId)) };
if (WebGUI::Error->caught("WebGUI::Error::Shop::MaxOfItemInCartReached")) {
my $i18n = WebGUI::International->new($self->session, "Shop");
$error{id $self} = sprintf($i18n->get("too many of this item"), $item->get("configuredTitle"));
$self->error(sprintf($i18n->get("too many of this item"), $item->get("configuredTitle")));
}
elsif (my $e = WebGUI::Error->caught) {
$error{id $self} = "An unknown error has occured: ".$e->message;
$self->error("An unknown error has occured: ".$e->message);
}
}
if (my $itemAddressId = $form->get("itemAddress_".$item->getId)) {
@ -759,7 +818,7 @@ sub updateFromForm {
}
if ($self->hasMixedItems) {
my $i18n = WebGUI::International->new($self->session, "Shop");
$error{id $self} = $i18n->get('mixed items warning');
$self->error($i18n->get('mixed items warning'));
}
my @cartItemIds = $form->process('remove_item', 'checkList');
@ -782,7 +841,7 @@ sub updateFromForm {
my $newAddress = $book->addAddress(\%billingData);
$cartProperties->{billingAddressId} = $newAddress->get('addressId');
}
elsif ($billingAddressId eq 'update_address' && $self->get('billingAddressId') && ! @missingBillingFields) {
elsif ($billingAddressId eq 'update_address' && $self->billingAddressId && ! @missingBillingFields) {
##User updated the current address
my $address = $self->getBillingAddress();
$address->update(\%billingData);
@ -802,7 +861,7 @@ sub updateFromForm {
if ($self->requiresShipping) {
if ($form->process('sameShippingAsBilling', 'yesNo')) {
$cartProperties->{shippingAddressId} = $self->get('billingAddressId');
$cartProperties->{shippingAddressId} = $self->billingAddressId;
}
else {
my %shippingData = $book->processAddressForm('shipping_');
@ -817,7 +876,7 @@ sub updateFromForm {
my $newAddress = $book->addAddress(\%shippingData);
$cartProperties->{shippingAddressId} = $newAddress->get('addressId');
}
elsif ($shippingAddressId eq 'update_address' && $self->get('shippingAddressId') && ! @missingShippingFields) {
elsif ($shippingAddressId eq 'update_address' && $self->shippingAddressId && ! @missingShippingFields) {
##User changed the address selector
my $address = $self->getBillingAddress();
$address->update(\%shippingData);
@ -918,8 +977,8 @@ sub www_checkout {
my $self = shift;
my $session = $self->session;
##Setting a shipping address greatly simplifies the Transaction
if (! $self->requiresShipping && ! $self->get('shippingAddressId')) {
$self->update({shippingAddressId => $self->get('billingAddressId')});
if (! $self->requiresShipping && ! $self->shippingAddressId) {
$self->update({shippingAddressId => $self->billingAddressId});
}
if ($self->readyForCheckout()) {
my $total = $self->calculateTotal;
@ -1049,7 +1108,7 @@ sub www_view {
# get the shipping address
my $address = eval { $self->getShippingAddress };
if (my $e = WebGUI::Error->caught("WebGUI::Error::ObjectNotFound") && $self->get('shippingAddressId')) {
if (my $e = WebGUI::Error->caught("WebGUI::Error::ObjectNotFound") && $self->shippingAddressId) {
# choose another address cuz we've got a problem
$self->update({shippingAddressId=>''});
}
@ -1125,7 +1184,7 @@ sub www_view {
$formOptions{$optionId} .= ' ('.$self->formatCurrency($options->{$optionId}{price}).')';
}
}
my $shipperId = $self->get('shipperId');
my $shipperId = $self->shipperId;
if (!$shipperId && $numberOfOptions == 1) {
my ($option) = keys %{ $options };
$self->update({shipperId => $option});
@ -1172,7 +1231,7 @@ sub www_view {
tie my %billingAddressOptions, 'Tie::IxHash';
$billingAddressOptions{'new_address'} = $i18n->get('Add new address');
my $billingAddressId = $self->get('billingAddressId');
my $billingAddressId = $self->billingAddressId;
if ($billingAddressId) {
$billingAddressOptions{'update_address'} = sprintf $i18n->get('Update %s'), $self->getBillingAddress->get('label');
}
@ -1188,7 +1247,7 @@ sub www_view {
tie my %shippingAddressOptions, 'Tie::IxHash';
$shippingAddressOptions{'new_address'} = $i18n->get('Add new address');
my $shippingAddressId = $self->get('shippingAddressId');
my $shippingAddressId = $self->shippingAddressId;
if ($shippingAddressId) {
$shippingAddressOptions{'update_address'} = sprintf $i18n->get('Update %s'), $self->getShippingAddress->get('label');
}
@ -1200,15 +1259,15 @@ sub www_view {
value => $shippingAddressId ? $shippingAddressId : 'new_address',
});
my $shippingAddressData = $self->get('shippingAddressId') ? $self->getShippingAddress->get() : {};
my $billingAddressData = $self->get('billingAddressId') ? $self->getBillingAddress->get() : {};
my $shippingAddressData = $self->shippingAddressId ? $self->getShippingAddress->get() : {};
my $billingAddressData = $self->billingAddressId ? $self->getBillingAddress->get() : {};
my $addressBook = $self->getAddressBook;
$addressBook->appendAddressFormVars(\%var, 'shipping_', $shippingAddressData);
$addressBook->appendAddressFormVars(\%var, 'billing_', $billingAddressData);
$var{sameShippingAsBilling} = WebGUI::Form::yesNo($session, {
name => 'sameShippingAsBilling',
value => $self->get('billingAddressId') && $self->get('billingAddressId') eq $self->get('shippingAddressId'),
value => $self->billingAddressId && $self->billingAddressId eq $self->shippingAddressId,
});
}
@ -1223,7 +1282,7 @@ sub www_view {
$var{paymentOptions} = WebGUI::Form::selectBox($session, {
name => 'gatewayId',
options => \%paymentOptions,
value => $self->get('gatewayId') || $form->get('gatewayId') || '',
value => $self->gatewayId || $form->get('gatewayId') || '',
});
# POS variables

39
lib/WebGUI/Shop/Credit.pm
View file

@ -1,7 +1,15 @@
package WebGUI::Shop::Credit;
use strict;
use Class::InsideOut qw{ :std };
use Moose;
use Scalar::Util qw/blessed/;
has [ qw/session userId/ ] => (
is => 'ro',
required => 1,
);
use WebGUI::Shop::Admin;
use WebGUI::Exception::Shop;
use WebGUI::International;
@ -28,8 +36,18 @@ These subroutines are available from this package:
=cut
readonly session => my %session;
readonly userId => my %userId;
around BUILDARGS => sub {
my $orig = shift;
my $className = shift;
##Original arguments start here.
my $protoSession = $_[0];
if (blessed $protoSession && $protoSession->isa('WebGUI::Session')) {
return $className->$orig(session => $protoSession, userId => $_[1], );
}
return $className->$orig(@_);
};
#-------------------------------------------------------------------
@ -137,21 +155,6 @@ A unique id for a user that you want to adjust the credit of. Defaults to the cu
=cut
sub new {
my ($class, $session, $userId) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
unless (defined $userId) {
$userId = $session->user->userId;
}
my $self = register $class;
my $id = id $self;
$session{ $id } = $session;
$userId{ $id } = $userId;
return $self;
}
#-------------------------------------------------------------------
=head2 session ()

1
lib/WebGUI/Shop/Pay.pm
View file

@ -16,7 +16,6 @@ package WebGUI::Shop::Pay;
use strict;
#use Class::InsideOut qw{ :std };
use Moose;
use WebGUI::Exception;
use WebGUI::International;

284
lib/WebGUI/Shop/Vendor.pm
View file

@ -1,7 +1,93 @@
package WebGUI::Shop::Vendor;
use strict;
use Class::InsideOut qw{ :std };
use Scalar::Util qw/blessed/;
use Moose;
use WebGUI::Definition;
property 'name' => (
is => 'rw',
noFormPost => 1,
default => '',
);
property 'userId' => (
is => 'rw',
noFormPost => 1,
default => '',
);
property 'url' => (
is => 'rw',
noFormPost => 1,
default => '',
);
property 'paymentInformation' => (
is => 'rw',
noFormPost => 1,
default => '',
);
property 'preferredPaymentType' => (
is => 'rw',
noFormPost => 1,
default => '',
);
has 'dateCreated' => (
is => 'ro',
);
has [ qw/session vendorId/ ] => (
is => 'ro',
required => 1,
);
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
if (ref $_[0] eq 'HASH') {
##Need same db code as below here.
##Session check goes here?
##Build a new one
my $properties = $_[0];
my $session = $properties->{session};
if (! (blessed $session && $session->isa('WebGUI::Session')) ) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my ($vendorId, $dateCreated) = $class->_init($session);
$properties->{vendorId} = $vendorId;
$properties->{dateCreated} = $dateCreated;
return $class->$orig($properties);
}
my $session = shift;
if (! (blessed $session && $session->isa('WebGUI::Session'))) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my $argument2 = shift;
if (!defined $argument2) {
WebGUI::Error::InvalidParam->throw( param=>$argument2, error=>"Need a vendorId.");
}
if (ref $argument2 eq 'HASH') {
##Build a new one
my ($vendorId, $dateCreated) = $class->_init($session);
my $properties = $argument2;
$properties->{session} = $session;
$properties->{vendorId} = $vendorId;
$properties->{dateCreated} = $dateCreated;
return $class->$orig($properties);
}
else {
##Look up one in the db
my $vendor = $session->db->quickHashRef("select * from vendor where vendorId=?", [$argument2]);
if ($vendor->{vendorId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"Vendor not found.", id=>$argument2);
}
$vendor->{session} = $session;
return $class->$orig($vendor);
}
};
use WebGUI::Shop::Admin;
use WebGUI::Exception::Shop;
use WebGUI::International;
@ -21,7 +107,7 @@ Keeps track of vendors that sell merchandise in the store.
use WebGUI::Shop::Vendor;
my $vendor = WebGUI::Shop::Vendor->new($session, $vendord);
my $vendor = WebGUI::Shop::Vendor->new($session, $vendorId);
=head1 METHODS
@ -29,35 +115,35 @@ These subroutines are available from this package:
=cut
readonly session => my %session;
readonly properties => my %properties;
#-------------------------------------------------------------------
=head2 _init ( session )
Builds a stub of object information in the database, and returns the newly created
vendorId, and the dateCreated fields so the object can be initialized correctly.
=cut
sub _init {
my $class = shift;
my $session = shift;
my $vendorId = $session->id->generate;
my $dateCreated = WebGUI::DateTime->new($session)->toDatabase;
$session->db->write("insert into vendor (vendorId, dateCreated) values (?, ?)",[$vendorId, $dateCreated]);
return ($vendorId, $dateCreated);
}
#-------------------------------------------------------------------
=head2 create ( session, properties )
Constructor. Creates a new vendor.
=head3 session
A reference to the current session.
=head3 properties
A hash reference containing the properties for this vendor. See update() for details.
Constructor. Creates a new vendor. Really an alias for WebGUI::Shop::Vendor->new($session, $properties)
=cut
sub create {
my ($class, $session, $properties) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
my $id = $session->id->generate;
$session->db->write("insert into vendor (vendorId, dateCreated) values (?, now())",[$id]);
my $self = $class->new($session, $id);
$self->update($properties);
return $self;
return $class->new($session, $properties);
}
#-------------------------------------------------------------------
@ -70,51 +156,20 @@ Deletes this vendor.
sub delete {
my ($self) = @_;
$self->session->db->deleteRow("vendor","vendorId",$self->getId);
}
#-------------------------------------------------------------------
=head2 get ( [ property ] )
Returns a duplicated hash reference of this objectÕs data. See update() for details.
=head3 property
Any field returns the value of a field rather than the hash reference.
=head3 Additional properties
=head4 dateCreated
The date this vendor was created in the system.
=head4 vendorId
The id of this vendor from the database. Use getId() instead.
=cut
sub get {
my ($self, $name) = @_;
if (defined $name) {
return $properties{id $self}{$name};
}
my %copyOfHashRef = %{$properties{id $self}};
return \%copyOfHashRef;
$self->session->db->deleteRow("vendor", "vendorId", $self->vendorId);
}
#-------------------------------------------------------------------
=head2 getId ()
Returns the unique id of this item.
Returns the unique id of this item. You should use $self->vendorId instead.
=cut
sub getId {
my $self = shift;
return $self->get("vendorId");
return $self->vendorId;
}
#-------------------------------------------------------------------
@ -147,7 +202,7 @@ sub getPayoutTotals {
my %totals = $self->session->db->buildHash(
'select vendorPayoutStatus, sum(vendorPayoutAmount) as amount from transactionItem as t1, transaction as t2 '
.'where t1.transactionId = t2.transactionId and t2.isSuccessful <> 0 and vendorId=? group by vendorPayoutStatus ',
[ $self->getId ]
[ $self->vendorId ]
);
# Format the payout categories and calc the total those.
@ -204,10 +259,10 @@ sub isVendorInfoComplete {
my $self = shift;
my $complete =
defined $self->get( 'name' )
&& defined $self->get( 'userId' )
&& defined $self->get( 'preferredPaymentType' )
&& defined $self->get( 'paymentInformation' );
defined $self->name
&& defined $self->userId
&& defined $self->preferredPaymentType
&& defined $self->paymentInformation;
return $complete
}
@ -216,7 +271,12 @@ sub isVendorInfoComplete {
=head2 new ( session, vendorId )
Constructor. Returns a WebGUI::Shop::Vendor object.
=head2 new ( session, properties )
=head2 new ( hashref )
Constructor. Returns a WebGUI::Shop::Vendor object, either by fetching information from the database,
or using passed in properties.
=head3 session
@ -229,26 +289,44 @@ A unique id for a vendor that already exists in the database. If the vendorId i
in, then a WebGUI::Error::InvalidParam Exception will be thrown. If the requested Id cannot
be found in the database, then a WebGUI::Error::ObjectNotFound exception will be thrown.
=head3 properties
A hashref of properties to assign to the object when it is created.
=head3 hashref
A classic Moose-style hashref of options. It must include a WebGUI::Session object.
=head3 Attributes
=head4 name
The name of the vendor.
=head4 userId
The unique GUID of the vendor.
=head4 url
The vendor's url.
=head4 vendorId
A unique identifier for this vendor. This option may be included in the properties for the new object, but it will
be ignored.
=head4 dateCreated
The date this vendor was created, in database format. This option may be included in the properties for the new object,
but it will be ignored.
=head4 paymentInformation
=head4 preferredPaymentType
=cut
sub new {
my ($class, $session, $vendorId) = @_;
unless (defined $session && $session->isa("WebGUI::Session")) {
WebGUI::Error::InvalidObject->throw(expected=>"WebGUI::Session", got=>(ref $session), error=>"Need a session.");
}
unless (defined $vendorId) {
WebGUI::Error::InvalidParam->throw( param=>$vendorId, error=>"Need a vendorId.");
}
my $vendor = $session->db->quickHashRef("select * from vendor where vendorId=?",[$vendorId]);
if ($vendor->{vendorId} eq "") {
WebGUI::Error::ObjectNotFound->throw(error=>"Vendor not found.", id=>$vendorId);
}
my $self = register $class;
my $id = id $self;
$session{ $id } = $session;
$properties{ $id } = $vendor;
return $self;
}
#-------------------------------------------------------------------
@ -262,7 +340,7 @@ A reference to the current session.
=head3 userId
A unique userId. Will pull from the session if not specified.
A unique userId. Will pull from the session if not specified.
=cut
@ -289,44 +367,16 @@ Returns a reference to the current session.
#-------------------------------------------------------------------
=head2 update ( properties )
=head2 write ( )
Sets properties of the vendor
=head3 properties
A hash reference that contains one of the following:
=head4 name
The name of the vendor.
=head4 userId
The unique GUID of the vendor.
=head4 url
The vendor's url.
=head4 paymentInformation
????
=head4 preferredPaymentType
????
Serializes the object's properties to the database
=cut
sub update {
my ($self, $newProperties) = @_;
my $id = id $self;
my @fields = (qw(name userId url paymentInformation preferredPaymentType));
foreach my $field (@fields) {
$properties{$id}{$field} = (exists $newProperties->{$field}) ? $newProperties->{$field} : $properties{$id}{$field};
}
$self->session->db->setRow("vendor","vendorId",$properties{$id});
sub write {
my ($self) = @_;
my $properties = $self->get();
$self->session->db->setRow("vendor", "vendorId", $properties);
}
#-------------------------------------------------------------------
@ -447,7 +497,7 @@ sub www_manage {
.WebGUI::Form::formHeader($session, {extras=>'style="float: left;"' })
.WebGUI::Form::hidden($session, { name => "shop", value => "vendor" })
.WebGUI::Form::hidden($session, { name => "method", value => "delete" })
.WebGUI::Form::hidden($session, { name => "vendorId", value => $vendor->getId })
.WebGUI::Form::hidden($session, { name => "vendorId", value => $vendor->vendorId })
.WebGUI::Form::submit($session, { value => $i18n->get("delete"), extras => 'class="backwardButton"' })
.WebGUI::Form::formFooter($session)
@ -455,12 +505,12 @@ sub www_manage {
.WebGUI::Form::formHeader($session, {extras=>'style="float: left;"' })
.WebGUI::Form::hidden($session, { name => "shop", value => "vendor" })
.WebGUI::Form::hidden($session, { name => "method", value => "edit" })
.WebGUI::Form::hidden($session, { name => "vendorId", value => $vendor->getId })
.WebGUI::Form::hidden($session, { name => "vendorId", value => $vendor->vendorId })
.WebGUI::Form::submit($session, { value => $i18n->get("edit"), extras => 'class="normalButton"' })
.WebGUI::Form::formFooter($session)
# Append name
.' '. $vendor->get("name")
.' '. $vendor->name
.'</div>';
}

4
lib/WebGUI/Storage.pm
View file

@ -259,7 +259,7 @@ sub addFileFromCaptcha {
$self->session->errorHandler->warn("Error adding noise: $error");
}
# AddNoise generates a different average color depending on library. This is ugly, but the best I can see for now
$error = $image->Annotate(font=>WebGUI::Paths->var.'/default.ttf', pointsize=>40, skewY=>0, skewX=>0, gravity=>'center', fill=>'#ffffff', antialias=>'true', text=>$challenge);
$error = $image->Annotate(font=>WebGUI::Paths->share.'/default.ttf', pointsize=>40, skewY=>0, skewX=>0, gravity=>'center', fill=>'#ffffff', antialias=>'true', text=>$challenge);
if($error) {
$self->session->errorHandler->warn("Error Annotating image: $error");
}
@ -1284,7 +1284,7 @@ sub getUrl {
and -e $self->getPath . '/.cdn' )
{
my $sep = '/'; # separator, if not already present trailing
if ($cdnCfg->{'sslAlt'} && $self->session->env->sslRequest) {
if ($cdnCfg->{'sslAlt'} && $self->session->request->secure) {
if ( $cdnCfg->{'sslUrl'} ) {
substr( $cdnCfg->{'sslUrl'}, -1 ) eq '/' and $sep = '';
$url = $cdnCfg->{'sslUrl'} . $sep . $self->getDirectoryId;

2
lib/WebGUI/TabForm.pm
View file

@ -206,7 +206,7 @@ sub new {
}
my $i18n = WebGUI::International->new($session);
my $cancelJS = 'history.go(-1);';
if (my $cancelURL = $session->env->get('HTTP_REFERER')) {
if (my $cancelURL = $session->request->referer) {
$cancelJS = sprintf q{window.location.href='%s';}, $cancelURL;
}
my $cancel = WebGUI::Form::button($session,{

559
lib/WebGUI/Upgrade.pm Normal file
View file

@ -0,0 +1,559 @@
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade - Perform upgrades on WebGUI sites
=head1 SYNOPSIS
use WebGUI::Upgrade;
my $upgrade = WebGUI::Upgrade->new;
$upgrade->upgradeSites;
=head1 DESCRIPTION
This package calculates upgrade paths and performs upgrades for WebGUI sites.
=head1 Differences from WebGUI 7's upgrade system
In WebGUI 7 and prior, a single upgrade for each version was created
as F<docs/upgrades/upgrade_X.X.X-X.X.X.pl>. This script would be
run with a command line parameter of --configFile=F<site.conf>.
This script contained all of the code to set up a session and do
any other work that was needed.
To cut down on the amount of boilerplate code and allow for more
flexible upgrades, this has been changed. Multiple upgrade files
are placed in the directory F<var/upgrades/X.X.X-X.X.X/>, and are
processed in alphabetical order, with the file extension determining
how to process the file.
=head1 Supported File Types
The file extension determines the class that will be used to process them. The class is determined by appending it to C<WebGUI::Upgrade::File::>.
=head2 Perl Scripts - F<.pl>
Perl scripts are processed by L<WebGUI::Upgrade::File::pl>, which
runs them after setting the environment variables C<WEBGUI_CONFIG>
and C<WEBGUI_UPGRADE_VERSION>. Usually, these scripts should use
the module L<WebGUI::Upgrade::Script> to load a number of subs to
greatly simplify how they are written.
=head2 SQL Scripts - F<.sql>
SQL scripts are processed by L<WebGUI::Upgrade::File::sql>, which
runs them with the F<mysql> command line client.
=head2 WebGUI Packages - F<.wgpkg>
WebGUI packages are processed by L<WebGUI::Upgrade::File::wgpkg>,
which imports them into the WebGUI site.
=head2 Text and POD Documents - F<.txt>/F<.pod>
Text and POD documents are processed by L<WebGUI::Upgrade::File::txt>
and L<WebGUI::Upgrade::File::pod> respectively. The files will be
shown to the user running the upgrade, and will wait for user
confirmation before continuing. This will only be done once per
upgrade process.
=cut
package WebGUI::Upgrade;
use 5.010;
use Moose;
use WebGUI::Paths;
use WebGUI::Pluggable;
use WebGUI::Config;
use WebGUI::SQL;
use Try::Tiny;
use File::Spec;
use File::Path qw(make_path);
use POSIX qw(strftime);
use Cwd ();
use namespace::autoclean;
=head1 ATTRIBUTES
These attributes can be set when creating a WebGUI::Upgrade instance:
=cut
=head2 quiet
Whether information about the upgrade progress will be output. Defaults to false.
=cut
has quiet => (
is => 'rw',
default => undef,
);
=head2 mysql
The path to the mysql command line client. Defaults to 'mysql'.
=cut
has mysql => (
is => 'rw',
default => 'mysql',
);
=head2 mysqldump
The path to the mysqldump command line client. Defaults to 'mysqldump'.
=cut
has mysqldump => (
is => 'rw',
default => 'mysqldump',
);
=head2 clearCache
If true, the cache will be cleared for each site before running
any upgrade scripts. Defaults to true.
=cut
has clearCache => (
is => 'rw',
default => 1,
);
=head2 backupPath
The path where backups will be stored. Defaults to 'backups' inside the temp directory.
=cut
has backupPath => (
is => 'rw',
default => File::Spec->catdir(File::Spec->tmpdir, 'backups'),
);
=head2 createBackups
If true, backups will be created before each version upgrade for
each site. The backup files will be named
C<{config file}_{version}_{timestamp}.sql>.
=cut
has createBackups => (
is => 'rw',
default => 1,
);
=head2 useMaintenanceMode
If set, sites will be put into maintenance mode before any upgrades
are run on them. Defaults to true.
=cut
has useMaintenanceMode => (
is => 'rw',
default => 1,
);
# this is used to store if a given upgrade file has been run yet.
# Some upgrade files should only be processed once per upgrade.
has _files_run => (
is => 'rw',
default => sub { { } },
);
=head1 METHODS
=head2 upgradeSites
Upgrades all available sites to match the current WebGUI codebase.
=cut
sub upgradeSites {
my $self = shift;
require Carp;
my @configs = WebGUI::Paths->siteConfigs;
my $i = 0;
for my $configFile (@configs) {
$i++;
my $bareFilename = $configFile;
$bareFilename =~ s{.*/}{};
print "Upgrading $bareFilename (site $i/@{[ scalar @configs ]}):\n";
try {
$self->upgradeSite($configFile);
}
catch {
print "Error upgrading $bareFilename: $_\n";
};
}
return 1;
}
=head2 getCodeVersion
Returns the current version of the codebase.
=cut
sub getCodeVersion {
require WebGUI;
return WebGUI->VERSION;
}
=head2 upgradeSite ( $config )
Upgrades the given config file to the current codebase.
=head3 $config
The path to a WebGUI config file or a WebGUI::Config instance
=cut
sub upgradeSite {
my $self = shift;
my ($configFile) = @_;
my $fromVersion = $self->getCurrentVersion($configFile);
my $toVersion = $self->getCodeVersion;
my @steps = $self->calcUpgradePath($fromVersion, $toVersion);
if ( $self->useMaintenanceMode ) {
my $dbh = $self->dbhForConfig( $configFile );
$dbh->do('REPLACE INTO settings (name, value) VALUES (?, ?)', {}, 'upgradeState', 'started');
}
if (! @steps) {
print "No upgrades needed.\n";
}
my $i = 0;
for my $step ( @steps ) {
$i++;
print "Running upgrades for $step (step $i/@{[ scalar @steps ]}):\n";
$self->createBackup($configFile);
$self->runUpgradeStep($configFile, $step);
}
}
=head1 calcUpgradePath ( $fromVerson , $toVersion )
Class method to calculate the upgrade path between two versions.
Tries to find the best path between the versions by looking in
F<var/upgrades/> for directories that make a path between the versions.
Returns either a list of directories to use, or throws an error if
no path can be found.
=cut
sub calcUpgradePath {
my $class = shift;
my ($fromVersionStr, $toVersionStr) = @_;
my $fromVersion = $class->_numericVersion($fromVersionStr);
my $toVersion = $class->_numericVersion($toVersionStr);
my %upgrades;
opendir my $dh, WebGUI::Paths->upgrades
or die "Upgrades directory doesn't exist.\n";
while ( my $dir = readdir $dh ) {
next
if $dir =~ /^\./;
next
unless -d File::Spec->catdir(WebGUI::Paths->upgrades, $dir);
if ($dir =~ /^((\d+\.\d+\.\d+)-(\d+\.\d+\.\d+))$/) {
$upgrades{ $class->_numericVersion($2) }{ $class->_numericVersion($3) } = $1;
}
}
closedir $dh;
my @steps;
while ( 1 ) {
my $atVersion = @steps ? $steps[-1][0] : $fromVersion;
last
if $atVersion eq $toVersion;
# find the available steps for the version we are at
my $stepsAvail = $upgrades{ $atVersion };
if ( $stepsAvail && %{ $stepsAvail } ) {
# take the lowest destination version, and remove it so it isn't considered again
my ($nextStep) = sort { $a <=> $b } keys %{ $stepsAvail };
my $dir = delete $stepsAvail->{$nextStep};
# add a step for that
push @steps, [$nextStep, $dir];
}
# if we don't have any steps available, the last step we tried won't work so remove it
elsif ( @steps ) {
pop @steps;
}
# if there is no way forward and we can't backtrack, bail out
else {
die "Can't find upgrade path from $fromVersionStr to $toVersionStr.\n";
}
}
return map { $_->[1] } @steps;
}
=head2 runUpgradeStep ( $config , $step )
Runs the given upgrade step against the WebGUI config file.
=cut
sub runUpgradeStep {
my $self = shift;
my ($configFile, $step) = @_;
my ($version) = $step =~ /-(\d+\.\d+\.\d+)$/;
my $upgradesDir = File::Spec->catdir(WebGUI::Paths->upgrades, $step);
opendir my($dh), $upgradesDir or die "Can't get upgrades for $step: $!\n";
while ( my $upgradeFile = readdir $dh ) {
next
if $upgradeFile =~ /^\./;
my $filename = File::Spec->catfile($upgradesDir, $upgradeFile);
next
unless -f $filename;
$self->runUpgradeFile($configFile, $version, $filename);
}
closedir $dh;
$self->markVersionUpgrade($configFile, $version);
}
=head2 runUpgradeFile ( $config , $version , $filename )
Runs the given upgrade file against a WebGUI config file.
=head3 $version
The destination version for the step this upgrade file is part of.
=cut
sub runUpgradeFile {
my $self = shift;
my ($configFile, $version, $filename) = @_;
my $has_run = $self->_files_run->{ Cwd::realpath($filename) } ++;
return try {
my $upgrade_class = $self->classForFile($filename);
my $upgrade_file = $upgrade_class->new(
version => $version,
file => $filename,
upgrade => $self,
);
if ($has_run && $upgrade_file->once) {
return;
}
$upgrade_file->run($configFile);
}
catch {
when (/^No upgrade package/) {
warn $_;
return;
}
default {
die $_;
}
};
}
=head2 classForFile ( $file )
Class method to find the class to use to run the upgrade file.
Given a filename, it will either load and return a class name to
use, or throw an error if no appropriate class is available.
=cut
sub classForFile {
my $class = shift;
my $file = shift;
my ($extension) = $file =~ /\.([^.]+)$/;
if ($extension) {
my $package = 'WebGUI::Upgrade::File::' . $extension;
WebGUI::Pluggable::load($package);
return $package
if $package->DOES('WebGUI::Upgrade::File');
}
no warnings 'uninitialized';
die "No upgrade package for extension: $extension";
}
=head2 markVersionUpgrade ( $config , $version )
Marks that a given version upgrade has been completed for a config file.
=cut
sub markVersionUpgrade {
my $self = shift;
my $configFile = shift;
my $version = shift;
my $dbh = $self->dbhForConfig($configFile);
$dbh->do(
'INSERT INTO webguiVersion (webguiVersion, versionType, dateApplied) VALUES (?,?,?)', {},
$version, 'upgrade', time,
);
if ( $self->useMaintenanceMode ) {
$dbh->do('REPLACE INTO settings (name, value) VALUES (?, ?)', {}, 'upgradeState', $version);
}
}
=head2 createBackup ( $config )
Creates a database backup file for a given config file.
=cut
sub createBackup {
my $self = shift;
my $config = shift;
if (! ref $config) {
$config = WebGUI::Config->new($config);
}
make_path($self->backupPath);
my $configFile = ( File::Spec->splitpath($config->pathToFile) )[2];
my $resultFile = File::Spec->catfile(
$self->backupPath,
$configFile . '_' . $self->getCurrentVersion($config) . '_' . time . '.sql',
);
print "Backing up to $resultFile\n";
my @command_line = (
$self->mysqldump,
$self->mysqlCommandLine($config),
'--add-drop-table',
'--result-file=' . $resultFile,
);
system { $command_line[0] } @command_line
and die "$!";
}
=head2 reportHistory ( $config )
Class method to return the upgrade history for a given config file.
=cut
sub reportHistory {
my $class = shift;
my $config = shift;
my $dbh = $class->dbhForConfig($config);
my $sth = $dbh->prepare('SELECT webguiVersion, dateApplied, versionType FROM webguiVersion ORDER BY dateApplied ASC, webguiVersion ASC');
$sth->execute;
while ( my @data = $sth->fetchrow_array ) {
printf "\t%-8s %-15s %-15s\n", $data[0], strftime('%D %T', localtime $data[1]), $data[2];
}
$sth->finish;
}
=head2 getCurrentVersion ( $config )
Class method that returns the current version of a WebGUI database.
=cut
sub getCurrentVersion {
my $class = shift;
my $configFile = shift;
my $dbh = $class->dbhForConfig($configFile);
my $sth = $dbh->prepare('SELECT webguiVersion FROM webguiVersion');
$sth->execute;
my ($version) = map { $_->[0] }
sort { $b->[1] <=> $a->[1] }
map { [ $_->[0], $class->_numericVersion($_->[0]) ] }
@{ $sth->fetchall_arrayref( [0] ) };
$sth->finish;
return $version;
}
=head2 dbhForConfig ( $config )
Class method that creates a new WebGUI::SQL object given a config file.
=cut
sub dbhForConfig {
my $class = shift;
my $config = shift;
if (! ref $config) {
$config = WebGUI::Config->new($config);
}
return WebGUI::SQL->connect($config);
}
=head2 mysqlCommandLine ( $config )
Class method to return a list of options to pass to the mysql or
mysqldump command line client to connect to the given config file's
database.
=cut
sub mysqlCommandLine {
my $class = shift;
my $config = shift;
if (! ref $config) {
$config = WebGUI::Config->new($config);
}
my $dsn = $config->get('dsn');
my $username = $config->get('dbuser');
my $password = $config->get('dbpass');
my $database = ( split /[:;]/msx, $dsn )[2];
my $hostname = 'localhost';
my $port = '3306';
while ( $dsn =~ /([^=;:]+)=([^;:]+)/msxg ) {
if ( $1 eq 'host' || $1 eq 'hostname' ) {
$hostname = $2;
}
elsif ( $1 eq 'db' || $1 eq 'database' || $1 eq 'dbname' ) {
$database = $2;
}
elsif ( $1 eq 'port' ) {
$port = $2;
}
}
my @command_line = (
'-h' . $hostname,
'-P' . $port,
$database,
'-u' . $username,
( $password ? '-p' . $password : () ),
'--default-character-set=utf8',
);
return @command_line;
}
# converts a period separated version number into a form that can
# be compared numerically.
sub _numericVersion {
my $class = shift;
my $version = shift;
my @parts = split /\./, $version;
my $decVersion = 0;
for my $i (0..$#parts) {
$decVersion += $parts[$i] / (1000**$i);
}
return $decVersion;
}
__PACKAGE__->meta->make_immutable;
1;

101
lib/WebGUI/Upgrade/File.pm Normal file
View file

@ -0,0 +1,101 @@
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade::File - Role for upgrade file classes
=head1 SYNOPSIS
package WebGUI::Upgrade::File::ext;
with 'WebGUI::Upgrade::File';
sub run {
my $self = shift;
print "Running " . $self->file . "\n";
}
=head1 DESCRIPTION
To be consumed by classes for running upgrade scripts.
=cut
package WebGUI::Upgrade::File;
use 5.010;
use Moose::Role;
=head1 REQUIRED METHODS
Classes consuming this role must implement the following methods:
=head2 run
This method much be implemented and should run the actual upgrade file on the config file.
=cut
requires 'run';
=head1 ATTRIBUTES
This role includes the following attributes.
=cut
=head2 file
The upgrade file to run.
=cut
has file => (
is => 'ro',
required => 1,
);
=head2 version
The version the upgrade is for.
=cut
has version => (
is => 'ro',
required => 1,
);
=head2 upgrade
The WebGUI::Upgrade object to use for this upgrade.
=cut
has upgrade => (
is => 'ro',
required => 1,
handles => [ 'quiet' ],
);
=head1 METHODS
=head2 once
A method to be overridden that controls if the upgrade file should
be run more than once per server.
=cut
sub once { 0 }
1;

79
lib/WebGUI/Upgrade/File/pl.pm Normal file
View file

@ -0,0 +1,79 @@
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade::File::pl - Upgrade class for Perl scripts
=cut
package WebGUI::Upgrade::File::pl;
use Moose;
use Class::MOP::Class;
use File::Spec::Functions qw(devnull);
use Scope::Guard;
use namespace::autoclean -also => qr/^_/;
with 'WebGUI::Upgrade::File';
sub run {
my $self = shift;
my $configFile = shift;
local $ENV{WEBGUI_CONFIG} = $configFile;
local $ENV{WEBGUI_UPGRADE_VERSION} = $self->version;
my $io_guard;
if ($self->quiet) {
open my $stdout_old, '>&=', \*STDOUT;
open \*STDOUT, '>', devnull;
$io_guard = Scope::Guard->new(sub {
close STDOUT;
open STDOUT, '>&=', $stdout_old;
});
}
return _runScript($self->file);
}
sub _runScript {
my $file = shift;
my @res;
my $err;
{
local $@;
local *_;
# use an anonymous package for this code. the namespace will
# automatically be deleted when this goes out of scope.
my $anon_class = Class::MOP::Class->create_anon_class;
my $wanted = wantarray;
eval sprintf(<<'END_CODE', $anon_class->name);
package %s;
# maintain context
if ($wanted) {
@res = do $file;
}
elsif (defined $wanted) {
$res[0] = do $file;
}
else {
do $file;
}
# save error as soon as possible, before local removes it
$err = $@;
END_CODE
}
die $err
if $err;
return (wantarray ? @res : $res[0]);
}
__PACKAGE__->meta->make_immutable;
1;

45
lib/WebGUI/Upgrade/File/pod.pm Normal file
View file

@ -0,0 +1,45 @@
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade::File::pod - Upgrade class for POD documents
=cut
package WebGUI::Upgrade::File::pod;
use Moose;
use POSIX qw(_exit);
with 'WebGUI::Upgrade::File';
sub once { 1 }
sub run {
my $self = shift;
my $configFile = shift;
if ( ! $self->quiet ) {
my $pid = fork;
if (! $pid) {
require Pod::Perldoc;
@ARGV = ($self->file);
Pod::Perldoc->run;
_exit;
}
waitpid $pid, 0;
}
return 1;
}
__PACKAGE__->meta->make_immutable;
1;

41
lib/WebGUI/Upgrade/File/sql.pm Normal file
View file

@ -0,0 +1,41 @@
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade::File::sql - Upgrade class for SQL scripts
=cut
package WebGUI::Upgrade::File::sql;
use Moose;
with 'WebGUI::Upgrade::File';
sub run {
my $self = shift;
my $configFile = shift;
my @command_line = (
$self->upgrade->mysql,
$self->upgrade->mysqlCommandLine($configFile),
'--batch',
'--execute=source ' . $self->file,
);
system { $command_line[0] } @command_line
and die "$!";
return 1;
}
__PACKAGE__->meta->make_immutable;
1;

45
lib/WebGUI/Upgrade/File/txt.pm Normal file
View file

@ -0,0 +1,45 @@
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade::File::txt - Upgrade class for text documents
=cut
package WebGUI::Upgrade::File::txt;
use Moose;
with 'WebGUI::Upgrade::File';
sub once { 1 }
sub run {
my $self = shift;
my $configFile = shift;
if ( ! $self->quiet ) {
open my $fh, '<', $self->file;
while ( my $line = <$fh> ) {
print $line;
}
close $fh;
if (-t) {
print "\nPress ENTER to continue... ";
my $nothing = <>;
}
}
return 1;
}
__PACKAGE__->meta->make_immutable;
1;

88
lib/WebGUI/Upgrade/File/wgpkg.pm Normal file
View file

@ -0,0 +1,88 @@
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade::File::wgpkg - Upgrade class for WebGUI packages
=cut
package WebGUI::Upgrade::File::wgpkg;
use Moose;
with 'WebGUI::Upgrade::File';
use WebGUI::Asset;
use WebGUI::Session;
use WebGUI::Storage;
use WebGUI::VersionTag;
use File::Spec;
use Try::Tiny;
use namespace::clean;
sub run {
my $self = shift;
my $configFile = shift;
my $session = WebGUI::Session->open($configFile);
$session->user({userId => 3});
my $versionTag = WebGUI::VersionTag->getWorking($session);
(undef, undef, my $shortname) = File::Spec->splitpath($self->file);
$shortname =~ s/\.[^.]*$//;
$versionTag->set({name => "Upgrade to @{[$self->version]} - $shortname"});
my $package = $self->import_package($session, $self->file);
if (! $self->quiet) {
printf "\tImported '%s'\n", $package->title;
}
$versionTag->commit;
$session->var->end;
$session->close;
return $package;
}
sub import_package {
my $class = shift;
my ($session, $file) = @_;
# Make a storage location for the package
my $storage = WebGUI::Storage->createTemp( $session );
$storage->addFileFromFilesystem( $file );
# Import the package into the import node
my $package = try {
my $node = WebGUI::Asset->getImportNode($session);
$node->importPackage( $storage, {
overwriteLatest => 1,
clearPackageFlag => 1,
setDefaultTemplate => 1,
} );
}
catch {
$storage->delete;
die "Error during package import on $file: $_";
};
$storage->delete;
if ($package eq 'corrupt') {
die "Corrupt package found in $file.\n";
}
return $package;
}
__PACKAGE__->meta->make_immutable;
1;

344
lib/WebGUI/Upgrade/Script.pm Normal file
View file

@ -0,0 +1,344 @@
package WebGUI::Upgrade::Script;
use 5.010;
use strict;
use warnings;
use feature ();
use Sub::Exporter;
use Sub::Name;
use WebGUI::Upgrade ();
use Scope::Guard;
use Scalar::Util qw(weaken);
my $exporter = Sub::Exporter::build_exporter({
groups => {
default => \&_build_exports,
},
});
my $caller_upgrade_file;
sub import {
my ($class, @args) = @_;
my $extra = shift @args if ref $args[0] eq 'HASH';
$extra ||= {};
if ( !$extra->{into} ) {
$extra->{into_level} ||= 0;
$extra->{into_level}++;
}
# save this in a lexical so _build_exports can pull it out
$caller_upgrade_file = File::Spec->rel2abs( (caller 0)[1] );
feature->import(':5.10');
strict->import;
warnings->import;
warnings->unimport('uninitialized');
$class->$exporter( $extra, @args );
}
my @cleanups;
sub _build_exports {
my $configFile = $ENV{WEBGUI_CONFIG}
or die 'WEBGUI_CONFIG environment variable must be specified';
my $version = $ENV{WEBGUI_UPGRADE_VERSION}
or die 'WEBGUI_UPGRADE_VERSION must be set';
my $upgrade_file = $caller_upgrade_file;
(my $vol, my $dir, my $shortname) = File::Spec->splitpath( $upgrade_file );
$shortname =~ s/\.[^.]*$//;
# need to be able to reference these directly in the cleanup code
my $session;
my $versionTag;
# these subs are kept separate so the others can call them
my $config_sub = sub () {
state $config = do {
require WebGUI::Config;
WebGUI::Config->new($configFile);
};
return $config;
};
my $session_sub = sub () {
return $session
if $session && ! $session->closed;
require WebGUI::Session;
$session = WebGUI::Session->open($config_sub->());
$session->user({userId => 3});
return $session;
};
my $version_tag_sub = sub (;$) {
my $name = shift;
require WebGUI::VersionTag;
if ($versionTag) {
if ($name) {
$versionTag->commit;
}
elsif ( ! $versionTag->get('isCommitted') ) {
return $versionTag;
}
}
$name ||= $shortname;
$versionTag = WebGUI::VersionTag->getWorking($session_sub->());
$versionTag->set({name => "Upgrade to $version - $name"});
return $versionTag;
};
my $dbh_sub = sub () {
state $dbh = do {
WebGUI::Upgrade->dbhForConfig($config_sub->());
};
return $dbh;
};
my $collateral_sub = sub () {
state $collateral = do {
my $path = File::Spec->catpath($vol, File::Spec->catdir($dir, $shortname), '');
Path::Class::Dir->new($path);
};
return $collateral;
};
my $cleanup = sub {
state $has_run = 0;
return
if $has_run++;
if ($session) {
require WebGUI::VersionTag;
if (WebGUI::VersionTag->getWorking($session, 'nocreate')) {
$version_tag_sub->()->commit;
}
$session->var->end;
$session->close;
}
undef $session;
undef $versionTag;
};
my $cleanup_guard = Scope::Guard->new( $cleanup );
# we keep a weakened copy around. this prevents us from keeping a
# copy if the guard gets freed, but otherwise allows us to call it
# manually in END.
push @cleanups, $cleanup;
weaken $cleanups[-1];
my $indent = 0;
my $just_started;
my $subs = {
# this closes over the guard, keeping it alive until the sub is either
# run or deleted. WebGUI::Upgrade::File::pl will end up deleting
# the sub when it cleans up the temporary namespace it uses.
_cleanup => sub {
undef $cleanup_guard;
},
config => $config_sub,
session => $session_sub,
version_tag => $version_tag_sub,
dbh => $dbh_sub,
collateral => $collateral_sub,
start_step => sub (@) {
print "\n"
if $just_started;
print "\t" x $indent, @_, '... ';
$just_started = 1;
$indent++;
},
report => sub (@) {
print "\n"
if $just_started;
print "\t" x $indent, @_, "\n";
$just_started = 0;
},
done => sub () {
$indent--;
print "\t" x $indent
unless $just_started;
print "Done.\n";
$just_started = 0;
},
sql => sub (@) {
my $sql = shift;
my $dbh = $dbh_sub->();
my $sth = $dbh->prepare($sql);
$sth->execute(@_);
},
rm_lib => sub (@) {
my @modules = @_;
for my $module (@modules) {
$module =~ s{::}{/}g;
$module .= '.pm';
for my $inc (@INC) {
my $fullPath = File::Spec->catfile($inc, $module);
unlink $fullPath;
}
}
},
import_package => sub (@) {
my $fullPath = $collateral_sub->()->file(@_);
require WebGUI::Upgrade::File::wgpkg;
WebGUI::Upgrade::File::wgpkg->import_package($session_sub->(), $fullPath);
},
root_asset => sub () {
require WebGUI::Asset;
return WebGUI::Asset->getRoot($session_sub->());
},
import_node => sub () {
require WebGUI::Asset;
return WebGUI::Asset->getImportNode($session_sub->());
},
asset => sub ($) {
require WebGUI::Asset;
my $session = $session_sub->();
my $assetId = shift;
my $asset;
if ($session->id->valid($assetId)) {
try {
$asset = WebGUI::Asset->newById($session, $assetId);
};
}
if ( ! $asset ) {
$asset = WebGUI::Asset->newByUrl($session, $assetId);
}
return $asset;
},
clear_cache => sub () {
my $session = $session_sub->();
my $cache = $session->cache;
$cache->clear;
},
};
# give the subs some names to help with diagnostics
my $sub_package = $shortname;
$sub_package =~ s/\W//g;
for my $sub_name ( keys %$subs ) {
subname join('::', __PACKAGE__, $sub_package, $sub_name) => $subs->{$sub_name};
}
return $subs;
}
END {
for my $cleanup (@cleanups) {
# could be a weakened ref that went away
next
unless $cleanup;
$cleanup->();
}
}
1;
__END__
=head1 LEGAL
-------------------------------------------------------------------
WebGUI is Copyright 2001-2009 Plain Black Corporation.
-------------------------------------------------------------------
Please read the legal notices (docs/legal.txt) and the license
(docs/license.txt) that came with this distribution before using
this software.
-------------------------------------------------------------------
http://www.plainblack.com info@plainblack.com
-------------------------------------------------------------------
=head1 NAME
WebGUI::Upgrade::Script - Utility package for WebGUI upgrade scripts
=head1 SYNOPSIS
use WebGUI::Upgrade::Script;
print "Adding new snippet.\n";
import_node->addChild({ className => 'WebGUI::Asset::Snippet', title => 'New Snippet'});
config->set('config/item', 'new value');
done;
=head1 DESCRIPTION
This is a package to be used in upgrade scripts to provide a number
of functions and automatic cleanup to make writing upgrade scripts
faster and simpler.
C<use>ing this module will also enable strictures, warnings, and
all of Perl 5.10's syntax enhancements in the caller.
=head1 ENVIRONMENT
This package will use the following environment variables to determine
its operation. These variables are automatically set by
L<WebGUI::Upgrade::File::pl> if run through the main upgrade system.
=head2 WEBGUI_CONFIG
The WebGUI config file to operate against.
=head2 WEBGUI_UPGRADE_VERSION
The version being upgraded to.
=head1 EXPORTED SUBROUTINES
These subroutines are all exported by default using L<Sub::Exporter>.
They cannot be called directly.
=head2 report ( $message )
Outputs $message.
=head2 done
Reports that the current step has been completed.
=head2 config
Returns the WebGUI::Config object for the site.
=head2 session
Returns a session for the site.
=head2 dbh
Returns a database handle for the site's database.
=head2 version_tag ( [ $name ] )
If $name is specified, creates a new version tag with that name,
sets it as the active version tag, and returns it
If $name is not specified, returns the current working version tag,
creating it if needed.
The actual name of the version tag will automatically include a
note specifying that it is an upgrade version tag.
=head2 rm_lib ( $module )
Deletes the specified Perl module. The module should be specified
as a colon separated name, and it will be removed from all include
paths.
=head2 collateral
Returns a L<Path::Class::Dir> object for the upgrade script's collateral
path. The collateral path is the same as the name of the upgrade
script with the extension stripped off.
=head2 import_package ( $package_file )
Imports the specified package from the upgrade script's collateral path.
=head2 root_asset
Returns the site's root asset.
=head2 import_node
Returns the site's import node.
=head2 asset ( $assetId_or_URL )
Returns an asset based on an asset ID or URL.
=cut

2
lib/WebGUI/User.pm
View file

@ -299,7 +299,7 @@ sub canUseAdminMode {
my $pass = 1;
my $subnets = $self->session->config->get("adminModeSubnets") || [];
if (scalar(@$subnets)) {
$pass = WebGUI::Utility::isInSubnet($self->session->env->getIp, $subnets);
$pass = WebGUI::Utility::isInSubnet($self->session->request->address, $subnets);
}
return $pass && $self->isInGroup(12)

4
lib/WebGUI/Workflow/Activity/TrashExpiredEvents.pm
View file

@ -81,8 +81,8 @@ sub execute {
my $date = WebGUI::DateTime->new($session, time() - $self->get("trashAfter") );
my $sth = $session->db->read( "select Event.assetId, revisionDate from Event join assetData using (assetId, revisionDate) where endDate < ? and revisionDate = (select max(revisionDate) from assetData where assetData.assetId=Event.assetId);", [ $date->toDatabaseDate ]);
EVENT: while ( my ($id) = $sth->array ) {
my $asset = eval { WebGUI::Asset::Event->newById($self->session, $id); };
if (! Exception::Class->caught() ) {
my $asset = eval { WebGUI::Asset->newById($session, $id); };
if (! Exception::Class->caught()) {
$asset->trash;
}
last EVENT if time() > $finishTime;