Adding Ben Simpson's new persistence layer.
This commit is contained in:
JT Smith
parent
af4efc0333
commit
d48579b177
16 changed files with 2127 additions and 56 deletions
|
|
@ -176,11 +176,64 @@ sub new {
|
|||
} elsif ($collateralId > 0) {
|
||||
$properties = WebGUI::SQL->quickHashRef("select * from collateral where collateralId=".$collateralId);
|
||||
}
|
||||
my $self = WebGUI::Attachment->new($properties->{filename},"images",$properties->{collateralId});
|
||||
$self->{_properties} = $properties;
|
||||
bless $self, $class;
|
||||
return $class->_new($properties);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
# Reuse this code for multiNew
|
||||
sub _new {
|
||||
my ($class,$properties) = @_;
|
||||
return undef unless $properties;
|
||||
my $self = WebGUI::Attachment->new($properties->{filename},"images",$properties->{collateralId});
|
||||
$self->{_properties} = $properties;
|
||||
bless $self, $class;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 multiDelete ( @collateraIds )
|
||||
|
||||
Deletes the nodes and database entries for a list of collateral items.
|
||||
|
||||
=cut
|
||||
|
||||
sub multiDelete {
|
||||
my ($class,@ids) = @_;
|
||||
return undef unless @ids;
|
||||
|
||||
my @collateral = $class->multiNew(@ids);
|
||||
foreach my $obj (@collateral) {
|
||||
$obj->deleteNode();
|
||||
}
|
||||
|
||||
my $clause = "collateralId in (".join(',',@ids).")";
|
||||
WebGUI::SQL->write("delete from collateral where $clause");
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 multiNew ( @collateralIds )
|
||||
|
||||
Returns a list of WebGUI::Collateral objects.
|
||||
|
||||
=cut
|
||||
|
||||
sub multiNew {
|
||||
my ($class,@collateralIds) = @_;
|
||||
return () unless @collaterlIds;
|
||||
|
||||
my (@objs);
|
||||
|
||||
my $clause = "collateralId in (".join(',',@collateralIds).")";
|
||||
my $sth = WebGUI::SQL->read("select * from collateral where $clause");
|
||||
|
||||
while (my $hash = $sth->hashRef()) {
|
||||
push @objs,$class->_new($hash);
|
||||
}
|
||||
|
||||
return @objs;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
78
lib/WebGUI/CollateralFolder.pm
Normal file
78
lib/WebGUI/CollateralFolder.pm
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
package WebGUI::CollateralFolder;
|
||||
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
|
||||
use WebGUI::Collateral;
|
||||
use WebGUI::Persistent::Tree;
|
||||
use WebGUI::SQL;
|
||||
|
||||
our @ISA = qw(WebGUI::Persistent::Tree);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::CollateralFolder
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a management package for the collateral folder system.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
For inherited methods see L<WebGUI::Persistent::Tree>.
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub classSettings {
|
||||
return {
|
||||
properties => {
|
||||
name => { quote => 1 },
|
||||
parentId => { defaultValue => 0 },
|
||||
collateralFolderId => { key => 1 },
|
||||
description => { quote => 1 }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 recursiveDelete ()
|
||||
|
||||
Recursively delete a folder, sub folders and contents
|
||||
|
||||
=cut
|
||||
|
||||
sub recursiveDelete {
|
||||
my ($self) = @_;
|
||||
my @ids = $self->SUPER::recursiveDelete();
|
||||
return unless @ids;
|
||||
|
||||
# If WebGUI::Collateral inherited from WebGUI::Persistent then we would only
|
||||
# need the following line:
|
||||
# WebGUI::Collateral->multiDelete(collateralFolderId => \@ids);
|
||||
|
||||
my @collateralIds = WebGUI::SQL->buildArray("select collateralId from collateral where collateralType='image' and collateralFolderId in (".join(',',@ids).")");
|
||||
WebGUI::Collateral->multiDelete(@collateralIds);
|
||||
}
|
||||
|
||||
sub table { 'collateralFolder' }
|
||||
|
||||
1;
|
||||
|
|
@ -21,7 +21,7 @@ use WebGUI::URL;
|
|||
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(&helpIcon &becomeIcon &cutIcon ©Icon &deleteIcon &editIcon &moveUpIcon &moveDownIcon
|
||||
&wobjectIcon &pageIcon &moveTopIcon &moveBottomIcon &viewIcon);
|
||||
&moveRightIcon &moveLeftIcon &wobjectIcon &pageIcon &moveTopIcon &moveBottomIcon &viewIcon);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -41,6 +41,8 @@ A package for generating user interface buttons. The subroutines found herein do
|
|||
$html = helpIcon(1,"MyNamespace");
|
||||
$html = moveBottomIcon('op=something');
|
||||
$html = moveDownIcon('op=something');
|
||||
$html = moveLeftIcon('op=something');
|
||||
$html = moveRightIcon('op=something');
|
||||
$html = moveTopIcon('op=something');
|
||||
$html = moveUpIcon('op=something');
|
||||
$html = pageIcon();
|
||||
|
|
@ -251,6 +253,62 @@ sub moveDownIcon {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveLeftIcon ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a left arrow printed on it.
|
||||
|
||||
=over
|
||||
|
||||
=item urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=item pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub moveLeftIcon {
|
||||
my ($output, $pageURL);
|
||||
$pageURL = $_[1] || $session{page}{urlizedTitle};
|
||||
$output = '<a href="'.WebGUI::URL::gateway($pageURL,$_[0]).'">';
|
||||
$output .= '<img src="'.$session{config}{extrasURL}.'/toolbar/'.$session{language}{toolbar}.'/moveLeft.gif" align="middle" border="0" alt="Move Left" title="Move Left" /></a>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveRightIcon ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a right arrow printed on it.
|
||||
|
||||
=over
|
||||
|
||||
=item urlParameters
|
||||
|
||||
Any URL parameters that need to be tacked on to the current URL to accomplish whatever function this button represents.
|
||||
|
||||
=item pageURL
|
||||
|
||||
The URL to any page. Defaults to the current page.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub moveRightIcon {
|
||||
my ($output, $pageURL);
|
||||
$pageURL = $_[1] || $session{page}{urlizedTitle};
|
||||
$output = '<a href="'.WebGUI::URL::gateway($pageURL,$_[0]).'">';
|
||||
$output .= '<img src="'.$session{config}{extrasURL}.'/toolbar/'.$session{language}{toolbar}.'/moveRight.gif" align="middle" border="0" alt="Move Right" title="Move Right" /></a>';
|
||||
return $output;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveTopIcon ( urlParameters [, pageURL ] )
|
||||
|
||||
Generates a button with a double up arrow printed on it.
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ eval " use Image::Magick; "; $hasImageMagick=0 if $@;
|
|||
use Exporter;
|
||||
use strict;
|
||||
use WebGUI::Collateral;
|
||||
use WebGUI::CollateralFolder;
|
||||
use WebGUI::DateTime;
|
||||
use WebGUI::HTMLForm;
|
||||
use WebGUI::Icon;
|
||||
|
|
@ -96,12 +97,12 @@ sub www_deleteCollateralFolder {
|
|||
sub www_deleteCollateralFolderConfirm {
|
||||
return WebGUI::Privilege::insufficient unless (WebGUI::Privilege::isInGroup(4));
|
||||
return WebGUI::Privilege::vitalComponent() unless ($session{scratch}{collateralFolderId} > 999);
|
||||
my ($parent) = WebGUI::SQL->quickArray("select parentId from collateralFolder
|
||||
where collateralFolderId=".$session{scratch}{collateralFolderId});
|
||||
WebGUI::SQL->write("update collateral set collateralFolderId=$parent
|
||||
where collateralFolderId=$session{scratch}{collateralFolderId}");
|
||||
WebGUI::SQL->write("delete from collateralFolder where collateralFolderId=".$session{scratch}{collateralFolderId});
|
||||
WebGUI::Session::setScratch("collateralFolderId",$parent);
|
||||
my $folders = WebGUI::CollateralFolder->getTree({-minimumFields => 1});
|
||||
if (my $deadFolder = $folders->{$session{scratch}{collateralFolderId}}) {
|
||||
my $parentId = $deadFolder->get("parentId");
|
||||
$deadFolder->recursiveDelete();
|
||||
WebGUI::Session::setScratch("collateralFolderId",$parentId);
|
||||
}
|
||||
return www_listCollateral();
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -29,41 +29,7 @@ our @ISA = qw(Exporter);
|
|||
our @EXPORT = qw(&www_viewPageTree &www_movePageUp &www_movePageDown
|
||||
&www_cutPage &www_deletePage &www_deletePageConfirm &www_editPage
|
||||
&www_editPageSave &www_pastePage &www_moveTreePageUp
|
||||
&www_moveTreePageDown);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub _movePageDown {
|
||||
my ($pageId,$parentId) = @_;
|
||||
my (@data, $thisSeq);
|
||||
if (WebGUI::Privilege::canEditPage()) {
|
||||
($thisSeq) = WebGUI::SQL->quickArray("select sequenceNumber from page where pageId=$pageId");
|
||||
@data = WebGUI::SQL->quickArray("select pageId from page where parentId=$parentId and sequenceNumber=$thisSeq+1");
|
||||
if ($data[0] ne "") {
|
||||
WebGUI::SQL->write("update page set sequenceNumber=sequenceNumber+1 where pageId=$pageId");
|
||||
WebGUI::SQL->write("update page set sequenceNumber=sequenceNumber-1 where pageId=$data[0]");
|
||||
}
|
||||
return "";
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub _movePageUp {
|
||||
my ($pageId,$parentId) = @_;
|
||||
my (@data, $thisSeq);
|
||||
if (WebGUI::Privilege::canEditPage()) {
|
||||
($thisSeq) = WebGUI::SQL->quickArray("select sequenceNumber from page where pageId=$pageId");
|
||||
@data = WebGUI::SQL->quickArray("select pageId from page where parentId=$parentId and sequenceNumber=$thisSeq-1");
|
||||
if ($data[0] ne "") {
|
||||
WebGUI::SQL->write("update page set sequenceNumber=sequenceNumber-1 where pageId=$pageId");
|
||||
WebGUI::SQL->write("update page set sequenceNumber=sequenceNumber+1 where pageId=$data[0]");
|
||||
}
|
||||
return "";
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
&www_moveTreePageDown &www_moveTreePageLeft &www_moveTreePageRight);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub _recursivelyChangePrivileges {
|
||||
|
|
@ -180,8 +146,10 @@ sub _traversePageTree {
|
|||
$output .= $depth
|
||||
.pageIcon()
|
||||
.deleteIcon('op=deletePage',$page{urlizedTitle})
|
||||
.moveUpIcon(sprintf('op=moveTreePageUp&pageId=%s&parentId=%s',$page{pageId},$_[0]),$page{urlizedTitle})
|
||||
.moveDownIcon(sprintf('op=moveTreePageDown&pageId=%s&parentId=%s',$page{pageId},$_[0]),$page{urlizedTitle})
|
||||
.moveLeftIcon(sprintf('op=moveTreePageLeft&pageId=%s',$page{pageId}),$page{urlizedTitle})
|
||||
.moveUpIcon(sprintf('op=moveTreePageUp&pageId=%s',$page{pageId}),$page{urlizedTitle})
|
||||
.moveDownIcon(sprintf('op=moveTreePageDown&pageId=%s',$page{pageId}),$page{urlizedTitle})
|
||||
.moveRightIcon(sprintf('op=moveTreePageRight&pageId=%s',$page{pageId}),$page{urlizedTitle})
|
||||
.editIcon('op=editPage',$page{urlizedTitle})
|
||||
.' <a href="'.WebGUI::URL::gateway($page{urlizedTitle}).'">'.$page{title}.'</a><br>';
|
||||
$b = WebGUI::SQL->read("select * from wobject where pageId=$page{pageId}");
|
||||
|
|
@ -310,6 +278,12 @@ sub www_editPage {
|
|||
-label=>WebGUI::International::get(886),
|
||||
-uiLevel=>6
|
||||
);
|
||||
$f->getTab("properties")->yesNo(
|
||||
-name=>"newWindow",
|
||||
-value=>$page{newWindow},
|
||||
-label=>WebGUI::International::get(940),
|
||||
-uiLevel=>6
|
||||
);
|
||||
$f->getTab("properties")->text(
|
||||
-name=>"urlizedTitle",
|
||||
-label=>WebGUI::International::get(104),
|
||||
|
|
@ -482,6 +456,7 @@ sub www_editPageSave {
|
|||
ownerId=$session{form}{ownerId},
|
||||
groupIdView=$session{form}{groupIdView},
|
||||
groupIdEdit=$session{form}{groupIdEdit},
|
||||
newWindow=$session{form}{newWindow},
|
||||
hideFromNavigation=$session{form}{hideFromNavigation},
|
||||
startDate=$session{form}{startDate},
|
||||
endDate=$session{form}{endDate},
|
||||
|
|
@ -508,24 +483,62 @@ sub www_editPageSave {
|
|||
|
||||
#-------------------------------------------------------------------
|
||||
sub www_movePageDown {
|
||||
return _movePageDown($session{page}{pageId},$session{page}{parentId});
|
||||
if (WebGUI::Privilege::canEditPage($session{page}{pageId})) {
|
||||
WebGUI::Page->moveDown($session{page}{pageId});
|
||||
return "";
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub www_movePageUp {
|
||||
return _movePageUp($session{page}{pageId},$session{page}{parentId});
|
||||
if (WebGUI::Privilege::canEditPage($session{page}{pageId})) {
|
||||
WebGUI::Page->moveUp($session{page}{pageId});
|
||||
return "";
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub www_moveTreePageUp {
|
||||
my $output = _movePageUp($session{form}{pageId},$session{form}{parentId});
|
||||
return $output ? $output : www_viewPageTree();
|
||||
if (WebGUI::Privilege::canEditPage($session{page}{pageId})) {
|
||||
WebGUI::Page->moveUp($session{page}{pageId});
|
||||
return www_viewPageTree();
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub www_moveTreePageDown {
|
||||
my $output = _movePageDown($session{form}{pageId},$session{form}{parentId});
|
||||
return $output ? $output : www_viewPageTree();
|
||||
if (WebGUI::Privilege::canEditPage($session{page}{pageId})) {
|
||||
WebGUI::Page->moveDown($session{page}{pageId});
|
||||
return www_viewPageTree();
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub www_moveTreePageLeft {
|
||||
if (WebGUI::Privilege::canEditPage($session{page}{pageId})) {
|
||||
WebGUI::Page->moveLeft($session{page}{pageId});
|
||||
return www_viewPageTree();
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
sub www_moveTreePageRight {
|
||||
if (WebGUI::Privilege::canEditPage($session{page}{pageId})) {
|
||||
WebGUI::Page->moveRight($session{page}{pageId});
|
||||
return www_viewPageTree();
|
||||
} else {
|
||||
return WebGUI::Privilege::insufficient();
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -23,8 +23,9 @@ use WebGUI::HTMLForm;
|
|||
use WebGUI::Session;
|
||||
use WebGUI::SQL;
|
||||
use WebGUI::Template;
|
||||
use WebGUI::Persistent::Tree;
|
||||
|
||||
|
||||
our @ISA = qw(WebGUI::Persistent::Tree);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
|
|
@ -50,14 +51,48 @@ These functions are available from this package:
|
|||
|
||||
=cut
|
||||
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub _newPositionFormat {
|
||||
return "<tmpl_var page.position".($_[0]+1).">";
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub classSettings {
|
||||
return {
|
||||
properties => {
|
||||
pageId => { key => 1 },
|
||||
parentId => { defaultValue => 0 },
|
||||
title => { quote => 1 },
|
||||
styleId => { defaultValue => 0 },
|
||||
ownerId => { defaultValue => 0 },
|
||||
sequenceNumber => { defaultValue => 1 },
|
||||
metaTags => { quote => 1 },
|
||||
urlizedTitle => { quote => 1 },
|
||||
defaultMetaTags => { defaultValue => 0 },
|
||||
menuTitle => { quote => 1 },
|
||||
synopsis => { quote => 1 },
|
||||
templateId => { defaultValue => 1 },
|
||||
startDate => { defaultValue => 946710000 },
|
||||
endDate => { defaultValue => 2082783600 },
|
||||
redirectURL => { quote => 1 },
|
||||
userDefined1 => { quote => 1 },
|
||||
userDefined2 => { quote => 1 },
|
||||
userDefined3 => { quote => 1 },
|
||||
userDefined4 => { quote => 1 },
|
||||
userDefined5 => { quote => 1 },
|
||||
languageId => { defaultValue => 1 },
|
||||
groupIdView => { defaultValue => 3 },
|
||||
groupIdEdit => { defaultValue => 3 },
|
||||
hideFromNavigation => { defaultValue => 0 },
|
||||
},
|
||||
useDummyRoot => 1
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 countTemplatePositions ( templateId )
|
||||
|
||||
Returns the number of template positions in the specified page template.
|
||||
|
|
@ -201,6 +236,9 @@ sub makeUnique {
|
|||
return $url;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub table { 'page' }
|
||||
|
||||
1;
|
||||
|
||||
|
|
|
|||
469
lib/WebGUI/Persistent.pm
Normal file
469
lib/WebGUI/Persistent.pm
Normal file
|
|
@ -0,0 +1,469 @@
|
|||
package WebGUI::Persistent;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
use WebGUI::SQL;
|
||||
use WebGUI::Persistent::Query::Select;
|
||||
use WebGUI::Persistent::Query::Delete;
|
||||
use WebGUI::Persistent::Query::Update;
|
||||
use WebGUI::Persistent::Query::Insert;
|
||||
use WebGUI::ErrorHandler;
|
||||
|
||||
our %classData = ();
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Persistent
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
An abstract base class for objects stored in the database.
|
||||
|
||||
This class provides simple get() and set() methods that interact with the
|
||||
database.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyClass;
|
||||
|
||||
use WebGUI::Persistent;
|
||||
our @ISA = qw(WebGUI::Persistent);
|
||||
|
||||
sub table { 'myTable' }
|
||||
|
||||
|
||||
sub classSettings {
|
||||
{
|
||||
properties => {
|
||||
A => { key => 1 },
|
||||
B => { defaultValue => 5},
|
||||
C => { quote => 1 , defaultValue => "hello world"},
|
||||
D => { }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
.
|
||||
.
|
||||
.
|
||||
|
||||
use MyClass;
|
||||
|
||||
# create a new instance
|
||||
my $obj = MyClass->new( -properties => {B => 3} );
|
||||
|
||||
# commit it to the database
|
||||
$obj->set();
|
||||
|
||||
# find out what id it has
|
||||
my $id = $obj->get('A');
|
||||
|
||||
This would leave a row in the table:
|
||||
|
||||
+---+---+-------------+------+
|
||||
| A | B | C | D |
|
||||
+---+---+-------------+------+
|
||||
| 1 | 3 | hello world | NULL |
|
||||
+---+---+-------------+------+
|
||||
|
||||
Rows can be retrieved from the database individually:
|
||||
|
||||
my $sameObj = MyClass->new(A => $id);
|
||||
|
||||
Or multiple rows can be fetched:
|
||||
|
||||
my @objs = MyClass->multiNew(-where => ["A > 5"], B => 3);
|
||||
|
||||
Rows can also be deleted from the database individually or many at once.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These methods are available from this class:
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
# Provides access to various stored classData.
|
||||
sub classData {
|
||||
my ($self) = @_;
|
||||
my $class = ref($self) || $self;
|
||||
return $classData{$class} ||= {};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 classSettings
|
||||
|
||||
This class method must be overridden to return a hash reference with one or
|
||||
more of the following keys.
|
||||
|
||||
=over
|
||||
|
||||
=item properties
|
||||
|
||||
This should be a hash reference keyed by the field names of the table that
|
||||
this class refers to (and should be able to be manipulated with this classes
|
||||
get() and set() methods). The values of the hash reference should be hash
|
||||
references containing settings for each field.
|
||||
|
||||
=over
|
||||
|
||||
=item * defaultValue
|
||||
|
||||
The default value for this field (optional).
|
||||
|
||||
=item * key
|
||||
|
||||
Should be true for the primary key column (one field must be set in this way).
|
||||
|
||||
=item * quote
|
||||
|
||||
Should be true for fields that need to be quoted in database queries.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub classSettings {
|
||||
WebGUI::ErrorHandler::fatalError("classSettings() must be overridden");
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 delete
|
||||
|
||||
An instance method to delete the currently instantiated row.
|
||||
|
||||
=cut
|
||||
|
||||
sub delete {
|
||||
my ($self) = @_;
|
||||
my $delete = WebGUI::Persistent::Query::Delete->new(
|
||||
table => $self->table(),
|
||||
where => { $self->keyColumn() => $self->get($self->keyColumn()) }
|
||||
);
|
||||
WebGUI::SQL->write($delete->buildQuery());
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 get( $propertyName )
|
||||
|
||||
Returns the value of a field.
|
||||
|
||||
=cut
|
||||
|
||||
sub get {
|
||||
my ($self,$propertyName) = @_;
|
||||
if ($propertyName) {
|
||||
if (exists($self->{_property}{$propertyName})) {
|
||||
return $self->{_property}{$propertyName};
|
||||
} elsif ($self->properties->{$propertyName}) {
|
||||
WebGUI::ErrorHandler::warn(
|
||||
ref($self)." $propertyName not retrieved from database"
|
||||
);
|
||||
}
|
||||
}
|
||||
return $self->{_property};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 keyColumn
|
||||
|
||||
Returns the name of the column that is the primary key for this table.
|
||||
|
||||
See classSettings() for details on how to set this value.
|
||||
|
||||
=cut
|
||||
|
||||
sub keyColumn {
|
||||
my ($class) = @_;
|
||||
unless ($class->classData->{keyColumn}) {
|
||||
my $properties = $class->properties();
|
||||
foreach my $key (keys %$properties) {
|
||||
next unless $properties->{$key}{key};
|
||||
$class->classData->{keyColumn} = $key;
|
||||
}
|
||||
}
|
||||
return $class->classData->{keyColumn};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub _mergeWhere {
|
||||
my ($class,$where,$p) = @_;
|
||||
$where ||= [];
|
||||
if (%$p) {
|
||||
push @$where,$p if ref($where) eq 'ARRAY';
|
||||
$where = [$where,$p] if ref($where) eq 'HASH';
|
||||
}
|
||||
return $where;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 minimumFields
|
||||
|
||||
Returns an array reference to the minimum subset of fields that maybe
|
||||
selected from the database. This list defaults to the keyColum().
|
||||
|
||||
=cut
|
||||
|
||||
sub minimumFields {
|
||||
my ($class) = @_;
|
||||
unless ($class->classData->{minimumFields}) {
|
||||
$class->classData->{minimumFields} = [$class->keyColumn()]
|
||||
}
|
||||
return $class->classData->{minimumFields};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 multiDelete( -where => @whereClauses, %p )
|
||||
|
||||
=item -where
|
||||
|
||||
See multiNew().
|
||||
|
||||
=cut
|
||||
|
||||
sub multiDelete {
|
||||
my $class = shift;
|
||||
my ($where,%p) = $class->_pluck([qw(-where)],@_);
|
||||
|
||||
my $delete = WebGUI::Persistent::Query::Delete->new(
|
||||
table => $class->table(),
|
||||
properties => $class->properties(),
|
||||
where => $class->_mergeWhere($where,\%p)
|
||||
);
|
||||
my $query = $delete->buildQuery();
|
||||
WebGUI::SQL->write($query);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 multiNew( %p )
|
||||
|
||||
Returns a list of objects matching the query arguments.
|
||||
|
||||
Unrecognised parameters are combined to form the where clause:
|
||||
|
||||
MyClass->multiNew(A => [1,2], B => 3);
|
||||
|
||||
Additional, more complicated parameters maybe passed using the -where option.
|
||||
|
||||
=item -where
|
||||
|
||||
If provided -where must be an array reference, which is evaluated to generate
|
||||
an Sql where clause using the properties in classSettings. Any left over named
|
||||
parameters to this method are built into the where clause.
|
||||
|
||||
For a class with settings as defined in the sysnopsis above the following
|
||||
argument to -where would be evaluated as:
|
||||
|
||||
-where => [{A => [1,2]},[{B => 3,C => 'hello'}],"D = (B * 3)"]
|
||||
|
||||
Evaluates to:
|
||||
|
||||
A in (1,2) AND (B = 3 OR C = 'hello') AND D = (B * 3)
|
||||
|
||||
=item -fields
|
||||
|
||||
This maybe an array reference of fields to be selected from the database,
|
||||
otherwise, all fields in properties are selected unless the -minimumFields
|
||||
option is true.
|
||||
|
||||
=item -minimumFields
|
||||
|
||||
If true the minimum fields are selected from the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub multiNew {
|
||||
my $class = shift;
|
||||
my ($where,$fields,$minimumFields,%p)
|
||||
= $class->_pluck([qw(-where -fields -minimumFields)],@_);
|
||||
$minimumFields = $class->minimumFields if $minimumFields;
|
||||
my (@objs);
|
||||
|
||||
my $select = WebGUI::Persistent::Query::Select->new(
|
||||
table => $class->table(),
|
||||
properties => $class->properties(),
|
||||
where => $class->_mergeWhere($where,\%p),
|
||||
fields => $minimumFields ? $minimumFields : $fields
|
||||
);
|
||||
my $query = $select->buildQuery();
|
||||
my $sth = WebGUI::SQL->read($query);
|
||||
while (my $hash = $sth->hashRef()) {
|
||||
push @objs, $class->new(-properties => $hash);
|
||||
}
|
||||
|
||||
return @objs;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new
|
||||
|
||||
=item -properties
|
||||
|
||||
If a hash reference of property names to values is provided to this method,
|
||||
then the database is not queried. This is mainly used for creating new rows
|
||||
by calling set afterwards (if not specified the value of the key column is
|
||||
set to 'new', so that when set() is called, and insert takes place).
|
||||
|
||||
=item -where
|
||||
|
||||
See multiNew().
|
||||
|
||||
=item -fields
|
||||
|
||||
See multiNew().
|
||||
|
||||
=item -minimumFields
|
||||
|
||||
See multiNew().
|
||||
|
||||
=item -noSet
|
||||
|
||||
If true this stops the set() method from doing writing to the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my ($properties,$where,$fields,$minimumFields,$noSet,%p)
|
||||
= $class->_pluck(
|
||||
[qw(-properties -where -fields -minimumFields -noSet)],@_
|
||||
);
|
||||
$minimumFields = $class->minimumFields if $minimumFields;
|
||||
|
||||
if ($properties) {
|
||||
my $classProperties = $class->properties();
|
||||
foreach my $propertyName (keys %$classProperties) {
|
||||
next if exists $properties->{$propertyName};
|
||||
$properties->{$propertyName}
|
||||
= $classProperties->{$propertyName}{defaultValue};
|
||||
}
|
||||
unless (defined($properties->{$class->keyColumn()})) {
|
||||
$properties->{$class->keyColumn()} = 'new';
|
||||
}
|
||||
return bless {_property => $properties,_noSet => $noSet}, $class;
|
||||
} else {
|
||||
$where = $class->_mergeWhere($where,\%p);
|
||||
my $select = WebGUI::Persistent::Query::Select->new(
|
||||
table => $class->table(),
|
||||
properties => $class->properties(),
|
||||
where => $where,
|
||||
fields => $minimumFields ? $minimumFields : $fields
|
||||
);
|
||||
my $query = $select->buildQuery();
|
||||
my $hash = WebGUI::SQL->quickHashRef($query);
|
||||
return undef unless %$hash;
|
||||
return bless {_property => $hash,_noSet => $noSet}, $class;
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub _pluck {
|
||||
my ($class,$p,%q) = @_;
|
||||
return ((map {delete($q{$_})} @$p),%q);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 properties
|
||||
|
||||
Returns a cached hash reference containing the "properties" defined in
|
||||
classSettings()
|
||||
|
||||
=cut
|
||||
|
||||
sub properties {
|
||||
my ($class) = @_;
|
||||
unless ($class->classData->{properties}) {
|
||||
$class->classData->{properties} = $class->classSettings->{properties};
|
||||
}
|
||||
return $class->classData->{properties}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 set( [ \%p ] )
|
||||
|
||||
This method optionally takes a hash reference of property to value and updates
|
||||
the object and database:
|
||||
|
||||
$obj->set({ B => 9, D => 60 });
|
||||
|
||||
If no arguments are provided then the object's current state is written to the
|
||||
database.
|
||||
|
||||
$obj->set();
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my ($self,$properties) = @_;
|
||||
$properties ||= {};
|
||||
|
||||
foreach my $propertyName (keys %$properties) {
|
||||
$self->{_property}{$propertyName} = $properties->{$propertyName};
|
||||
}
|
||||
|
||||
return if $self->{_noSet};
|
||||
|
||||
if ($self->get($self->keyColumn()) ne 'new') {
|
||||
my $update = WebGUI::Persistent::Query::Update->new(
|
||||
table => $self->table(),
|
||||
where => { $self->keyColumn => $self->get($self->keyColumn()) },
|
||||
data => $properties,
|
||||
properties => $self->properties()
|
||||
);
|
||||
WebGUI::SQL->write($update->buildQuery());
|
||||
} else {
|
||||
$self->{_property}{$self->keyColumn()} = getNextId($self->keyColumn());
|
||||
my $insert = WebGUI::Persistent::Query::Insert->new(
|
||||
table => $self->table(),
|
||||
data => $self->{_property},
|
||||
properties => $self->properties()
|
||||
);
|
||||
WebGUI::SQL->write($insert->buildQuery());
|
||||
}
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 table
|
||||
|
||||
This method must be overriden to return the name of the table modeled by this
|
||||
class.
|
||||
|
||||
=cut
|
||||
|
||||
sub table {
|
||||
WebGUI::ErrorHandler::fatalError("table() must be overridden");
|
||||
}
|
||||
|
||||
1;
|
||||
246
lib/WebGUI/Persistent/Query.pm
Normal file
246
lib/WebGUI/Persistent/Query.pm
Normal file
|
|
@ -0,0 +1,246 @@
|
|||
package WebGUI::Persistent::Query;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
use WebGUI::SQL ();
|
||||
use WebGUI::ErrorHandler;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Persistent::Query
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
An abstract base class for objects that build queries, providing funtionality
|
||||
for building the where clause. See WebGUI::Persistent::Query::Select for more
|
||||
details.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use WebGUI::Persistent::Query;
|
||||
our @ISA = qw(WebGUI::Persistent::Query);
|
||||
|
||||
sub buildQuery {
|
||||
# build the query...
|
||||
.
|
||||
.
|
||||
.
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildQuery
|
||||
|
||||
Build the query from the properties. This method must be overridden by
|
||||
subclasses
|
||||
|
||||
=cut
|
||||
|
||||
sub buildQuery {
|
||||
WebGUI::ErrorHandler::fatalError("buildQuery() must be overridden");
|
||||
}
|
||||
;
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildWhere
|
||||
|
||||
Build the where clause for this query.
|
||||
|
||||
=cut
|
||||
|
||||
sub buildWhere {
|
||||
my ($self) = @_;
|
||||
my @clauses;
|
||||
|
||||
if (my $where = $self->parseWhereArgs(@{$self->{_where}})) {
|
||||
return "WHERE $where";
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildWhereElement( $name, @values )
|
||||
|
||||
Builds an element of a where clause.
|
||||
|
||||
=cut
|
||||
|
||||
sub buildWhereElement {
|
||||
my ($self,$name,@vals) = @_;
|
||||
@vals = @{$vals[0]} if ref($vals[0]);
|
||||
return undef unless @vals;
|
||||
return "$name = ".$self->quote($name,@vals) if (@vals == 1);
|
||||
return "$name IN (".join(',',map {$self->quote($name,$_)} @vals).")";
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new( %p )
|
||||
|
||||
=over
|
||||
|
||||
=item properties
|
||||
|
||||
A hashref of field name to a hash reference of property settings.
|
||||
|
||||
Currently used settings are:
|
||||
|
||||
=over
|
||||
|
||||
=item * quote
|
||||
|
||||
If true values for this field are automatically quoted.
|
||||
|
||||
=back
|
||||
|
||||
=item table
|
||||
|
||||
The name of the table to query.
|
||||
|
||||
=item where
|
||||
|
||||
A hash reference or array reference of arguments to build a where clause from.
|
||||
See parseWhereArgs for details.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class,%p) = @_;
|
||||
$p{where} ||= [];
|
||||
$p{where} = [$p{where}] unless ref($p{where}) eq 'ARRAY';
|
||||
my $self = bless {
|
||||
_where => $p{where},
|
||||
_properties => $p{properties},
|
||||
_table => $p{table},
|
||||
}, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub _parsePart {
|
||||
my ($self,$part,$or,$no_bracket) = @_;
|
||||
|
||||
return $part unless ref($part);
|
||||
if (ref($part) eq 'ARRAY') {
|
||||
my @parts;
|
||||
foreach my $sub_part (@$part) {
|
||||
$sub_part = $self->_parsePart($sub_part,!$or);
|
||||
push @parts,$sub_part if $sub_part;
|
||||
}
|
||||
if (@parts) {
|
||||
my $ret_val = join(($or ? ' OR ' : ' AND '),@parts);
|
||||
return ($no_bracket ? $ret_val : "($ret_val)");
|
||||
}
|
||||
} elsif (ref($part) eq 'HASH') {
|
||||
my @parts;
|
||||
foreach my $key (keys %$part) {
|
||||
my $clause = $self->buildWhereElement($key,$part->{$key});
|
||||
push @parts,$clause if $clause;
|
||||
}
|
||||
return $self->_parsePart(\@parts,!$or,1);
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 parseWhereArgs( @argumentList)
|
||||
|
||||
Recursivley parses a list of where arguments joining them with "AND" or "OR". Arguments
|
||||
may take a number of forms:
|
||||
|
||||
=over
|
||||
|
||||
=item * scalar
|
||||
|
||||
("A = 1") is left unchanged.
|
||||
|
||||
=item * array reference
|
||||
|
||||
An array reference causes the joining argument to switch from 'AND' to 'OR'
|
||||
(or visa-versa) for its contents:
|
||||
|
||||
([ "A = 1","C = 2" ])
|
||||
|
||||
becomes:
|
||||
|
||||
"(A = 1 OR C = 2)"
|
||||
|
||||
=item * hash reference
|
||||
|
||||
These are a convienent way of being able to dynamically build up complex
|
||||
queries gradually.
|
||||
|
||||
({ A => 1 , C => 2 })
|
||||
|
||||
becomes:
|
||||
|
||||
"A = 1 AND C = 2"
|
||||
|
||||
=back
|
||||
|
||||
This routine is flexiable enough to be able to parse arguments of the form:
|
||||
|
||||
({A => [1,2]},[{B => 3,C => 4}],{D => 5})
|
||||
|
||||
becomes:
|
||||
|
||||
"A in (1,2) AND (B = 3 OR C = 4) AND D = 5"
|
||||
|
||||
=cut
|
||||
|
||||
sub parseWhereArgs {
|
||||
my ($self,@where_arg_list) = @_;
|
||||
my @where_parts;
|
||||
foreach my $where_part (@where_arg_list) {
|
||||
my $part = $self->_parsePart($where_part,1,0);
|
||||
push @where_parts,$part if $part;
|
||||
}
|
||||
return $self->_parsePart(\@where_parts,0,1);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 quote( $propertyName, $propertyVaule )
|
||||
|
||||
Returns a quoted value for inclusion in a query, by refering to the properties
|
||||
supplied to new().
|
||||
|
||||
=cut
|
||||
|
||||
sub quote {
|
||||
my ($self,$propertyName,$propertyValue) = @_;
|
||||
|
||||
return 'NULL' unless defined($propertyValue);
|
||||
|
||||
if ($self->{_properties}{$propertyName}{quote}) {
|
||||
return WebGUI::SQL::quote($propertyValue);
|
||||
}
|
||||
|
||||
return $propertyValue;
|
||||
}
|
||||
|
||||
1;
|
||||
101
lib/WebGUI/Persistent/Query/Delete.pm
Normal file
101
lib/WebGUI/Persistent/Query/Delete.pm
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
package WebGUI::Persistent::Query::Delete;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
use WebGUI::Persistent::Query;
|
||||
|
||||
our @ISA = qw(WebGUI::Persistent::Query);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Persistent::Query::Insert
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class allows reliable dynamic building of Sql delete queries.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $query = WebGUI::Persistent::Query::Insert->new(
|
||||
table => 'myTable',
|
||||
where => [A => [1,2],[{C => 'hello',B => 1}]],
|
||||
properties => {
|
||||
A => { },
|
||||
B => { },
|
||||
C => { quote => 1 },
|
||||
D => { quote => 1 },
|
||||
}
|
||||
);
|
||||
|
||||
$query->buildQuery();
|
||||
|
||||
Returns:
|
||||
|
||||
DELETE FROM myTable
|
||||
WHERE A IN (1,2) AND (C = 'hello' OR B = 1)
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildQuery
|
||||
|
||||
=cut
|
||||
|
||||
sub buildQuery {
|
||||
my ($self,%p) = @_;
|
||||
|
||||
my $query = 'DELETE FROM '.$self->{_table};
|
||||
if (my $where = $self->buildWhere()) {
|
||||
$query .= " $where";
|
||||
}
|
||||
|
||||
return $query;
|
||||
}
|
||||
|
||||
=head2 new( %p )
|
||||
|
||||
=over
|
||||
|
||||
=item properties
|
||||
|
||||
A hashref of field name to a hash reference of property settings.
|
||||
|
||||
Currently used settings are:
|
||||
|
||||
=over
|
||||
|
||||
=item * quote
|
||||
|
||||
If true values for this field are automatically quoted.
|
||||
|
||||
=back
|
||||
|
||||
=item table
|
||||
|
||||
The name of the table to query.
|
||||
|
||||
=item where
|
||||
|
||||
A hash reference or array reference of arguments to build a where clause from.
|
||||
See parseWhereArgs for details.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
115
lib/WebGUI/Persistent/Query/Insert.pm
Normal file
115
lib/WebGUI/Persistent/Query/Insert.pm
Normal file
|
|
@ -0,0 +1,115 @@
|
|||
package WebGUI::Persistent::Query::Insert;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
use WebGUI::Persistent::Query::Insert;
|
||||
|
||||
our @ISA = qw(WebGUI::Persistent::Query);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Persistent::Query::Insert
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class allows reliable dynamic building of Sql insert queries.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $query = WebGUI::Persistent::Query::Insert->new(
|
||||
table => 'myTable',
|
||||
data => {
|
||||
A => 1,
|
||||
B => 2,
|
||||
C => 'hello',
|
||||
D => 'world'
|
||||
},
|
||||
properties => {
|
||||
A => { },
|
||||
B => { },
|
||||
C => { quote => 1 },
|
||||
D => { quote => 1 },
|
||||
}
|
||||
);
|
||||
|
||||
$query->buildQuery();
|
||||
|
||||
Returns:
|
||||
|
||||
INSERT INTO myTable (A,B,C,D) VALUES (1,2,'hello','world');
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub buildFieldValues {
|
||||
my ($self) = @_;
|
||||
|
||||
my @fields = keys %{$self->{_data}};
|
||||
my @values = map { $self->quote($_,$self->{_data}{$_})} @fields;
|
||||
|
||||
return "(".join(', ',@fields).") VALUES (".join(', ',@values).")";
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildQuery
|
||||
|
||||
=cut
|
||||
|
||||
sub buildQuery {
|
||||
my ($self) = @_;
|
||||
return join(' ','INSERT INTO',$self->{_table},$self->buildFieldValues());
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new( %p )
|
||||
|
||||
=over
|
||||
|
||||
=item data
|
||||
|
||||
A hash reference of field name to value.
|
||||
|
||||
=item properties
|
||||
|
||||
=over
|
||||
|
||||
=item * quote
|
||||
|
||||
If true values for this field are automatically quoted.
|
||||
|
||||
=back
|
||||
|
||||
=item table
|
||||
|
||||
The name of the table to query.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class,%p) = @_;
|
||||
my $self = $class->SUPER::new(%p);
|
||||
$self->{_data} = $p{data} || {};
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
171
lib/WebGUI/Persistent/Query/Select.pm
Normal file
171
lib/WebGUI/Persistent/Query/Select.pm
Normal file
|
|
@ -0,0 +1,171 @@
|
|||
package WebGUI::Persistent::Query::Select;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
use WebGUI::Persistent::Query;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Persistent::Query::Select
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class allows reliable dynamic building of Sql select queries.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $query = WebGUI::Persistent::Query::Select->new(
|
||||
where => [A => [1,2],[{C => 'hello',B => 1}]],
|
||||
table => 'myTable',
|
||||
limit => 1,
|
||||
groupBy => 'D',
|
||||
properties => {
|
||||
A => { },
|
||||
B => { },
|
||||
C => { quote => 1 },
|
||||
D => { quote => 1 },
|
||||
}
|
||||
);
|
||||
|
||||
$query->buildQuery();
|
||||
|
||||
Returns:
|
||||
|
||||
SELECT A,B,C,D
|
||||
FROM myTable
|
||||
WHERE A IN (1,2) AND (C = 'hello' OR B = 1) LIMIT 1 GROUP BY D
|
||||
|
||||
=cut
|
||||
|
||||
our @ISA = qw(WebGUI::Persistent::Query);
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub buildFrom { "FROM ".$_[0]->{_table} }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub buildGroupBy {
|
||||
my ($self) = @_;
|
||||
return '' unless $self->{_groupBy} && @{$self->{_groupBy}};
|
||||
return 'GROUP BY '.join(',',@{$self->{_groupBy}});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub buildLimit { $_[0]->{_limit} ? "LIMIT ".$_[0]->{_limit} : '' }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub buildOrderBy {
|
||||
my ($self) = @_;
|
||||
return '' unless $self->{_orderBy} && @{$self->{_orderBy}};
|
||||
return 'ORDER BY '.join(',',@{$self->{_orderBy}});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildQuery
|
||||
|
||||
=cut
|
||||
|
||||
sub buildQuery {
|
||||
my ($self) = @_;
|
||||
|
||||
my @clauses = ('SELECT',
|
||||
$self->buildSelectFields(),
|
||||
$self->buildFrom());
|
||||
|
||||
if (my $where = $self->buildWhere()) {
|
||||
push @clauses,$where;
|
||||
}
|
||||
if (my $group_by = $self->buildGroupBy()) {
|
||||
push @clauses,$group_by;
|
||||
}
|
||||
if (my $order_by = $self->buildOrderBy()) {
|
||||
push @clauses,$order_by;
|
||||
}
|
||||
if (my $limit = $self->buildLimit()) {
|
||||
push @clauses,$limit;
|
||||
}
|
||||
return join(' ',@clauses);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
sub buildSelectFields {
|
||||
my ($self) = @_;
|
||||
return join(', ',@{$self->{_fields}}) if @{$self->{_fields}};
|
||||
return join(', ',keys %{$self->{_properties}}) if %{$self->{_properties}};
|
||||
return '*';
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 new( %p )
|
||||
|
||||
=over
|
||||
|
||||
=item fields
|
||||
|
||||
An array reference of field names (optional).
|
||||
|
||||
=item groupBy
|
||||
|
||||
An array reference of fields to group results by
|
||||
|
||||
=item limit
|
||||
|
||||
A scalar limit.
|
||||
|
||||
=item orderBy
|
||||
|
||||
An array reference of fields to order results by
|
||||
|
||||
=item properties
|
||||
|
||||
=over
|
||||
|
||||
=item * quote
|
||||
|
||||
If true values for this field are automatically quoted.
|
||||
|
||||
=back
|
||||
|
||||
=item table
|
||||
|
||||
The name of the table to query.
|
||||
|
||||
=item where
|
||||
|
||||
A hash reference or array reference of arguments to build a where clause from.
|
||||
See WebGUI::Persistent::Query::parseWhereArgs for details.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class,%p) = @_;
|
||||
my $self = $class->SUPER::new(%p);
|
||||
$self->{_fields} = $p{fields} || [];
|
||||
$self->{_limit} = $p{limit};
|
||||
$self->{_group_by} = $p{groupBy};
|
||||
$self->{_order_by} = $p{orderBy};
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
118
lib/WebGUI/Persistent/Query/Update.pm
Normal file
118
lib/WebGUI/Persistent/Query/Update.pm
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
package WebGUI::Persistent::Query::Update;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
use WebGUI::Persistent::Query;
|
||||
|
||||
our @ISA = qw(WebGUI::Persistent::Query);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Persistent::Query::Insert
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class allows reliable dynamic building of Sql insert queries.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $query = WebGUI::Persistent::Query::Insert->new(
|
||||
table => 'myTable',
|
||||
where => [A => [1,2],[{C => 'hello',B => 1}]],
|
||||
data => {
|
||||
A => 1,
|
||||
B => 2,
|
||||
C => 'hello',
|
||||
D => 'world'
|
||||
},
|
||||
properties => {
|
||||
A => { },
|
||||
B => { },
|
||||
C => { quote => 1 },
|
||||
D => { quote => 1 },
|
||||
}
|
||||
);
|
||||
|
||||
$query->buildQuery();
|
||||
|
||||
Returns:
|
||||
|
||||
UPDATE myTable SET A = 1, B = 2, C = 'hello' C = 'world'
|
||||
WHERE A IN (1,2) AND (C = 'hello' OR B = 1)
|
||||
|
||||
=cut
|
||||
|
||||
=head2 buildQuery
|
||||
|
||||
=cut
|
||||
|
||||
sub buildQuery {
|
||||
my ($self) = @_;
|
||||
|
||||
my @clauses = ('UPDATE',$self->{_table},$self->buildSet());
|
||||
if (my $where = $self->buildWhere()) {
|
||||
push @clauses,$where;
|
||||
}
|
||||
|
||||
return join(' ',@clauses);
|
||||
}
|
||||
|
||||
sub buildSet {
|
||||
my ($self) = @_;
|
||||
'SET '.join(', ',map {
|
||||
"$_ = ". $self->quote($_,$self->{_data}{$_})
|
||||
} keys %{$self->{_data}});
|
||||
}
|
||||
|
||||
=head2 new( %p )
|
||||
|
||||
=over
|
||||
|
||||
=item data
|
||||
|
||||
A hash reference of field name to value.
|
||||
|
||||
=item properties
|
||||
|
||||
=over
|
||||
|
||||
=item * quote
|
||||
|
||||
If true values for this field are automatically quoted.
|
||||
|
||||
=back
|
||||
|
||||
=item table
|
||||
|
||||
=item where
|
||||
|
||||
A hash reference or array reference of arguments to build a where clause from.
|
||||
See WebGUI::Persistent::Query::parseWhereArgs for details.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class,%p) = @_;
|
||||
my $self = $class->SUPER::new(%p);
|
||||
$self->{_data} = $p{data} || {};
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
601
lib/WebGUI/Persistent/Tree.pm
Normal file
601
lib/WebGUI/Persistent/Tree.pm
Normal file
|
|
@ -0,0 +1,601 @@
|
|||
package WebGUI::Persistent::Tree;
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
WebGUI is Copyright 2001-2003 Plain Black LLC.
|
||||
-------------------------------------------------------------------
|
||||
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 warnings;
|
||||
|
||||
use Tree::DAG_Node;
|
||||
use WebGUI::Persistent;
|
||||
use WebGUI::SQL ();
|
||||
use WebGUI::Persistent::Query::Update;
|
||||
|
||||
our @ISA = qw(WebGUI::Persistent Tree::DAG_Node);
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::Persistent
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
An abstract base class for objects stored in the database, that represent tree
|
||||
structures.
|
||||
|
||||
This class inherits from both WebGUI::Persistent (to provide get() and set()
|
||||
methods), and from Tree::DAG_Node (to provide tree manipulation methods).
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package MyTreeClass;
|
||||
|
||||
use WebGUI::Persistent::Tree;
|
||||
our @ISA = qw(WebGUI::Persistent::Tree);
|
||||
|
||||
sub table { 'myTreeTable' }
|
||||
|
||||
|
||||
sub classSettings {
|
||||
{
|
||||
properties => {
|
||||
A => { key => 1 },
|
||||
B => { defaultValue => 5},
|
||||
C => { quote => 1 , defaultValue => "hello world"},
|
||||
parentId => { defaultValue => 0 },
|
||||
sequenceNumber => { defaultValue => 1 }
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
.
|
||||
.
|
||||
.
|
||||
|
||||
use MyTreeClass;
|
||||
|
||||
my $nodes = $class->getTree({-minmumFields});
|
||||
print join("\n",@{$nodes->{0}->draw_ascii_tree()});
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 buildTree( \@objs, [ \%nodes ] )
|
||||
|
||||
Given an array reference of objects this method will attempt to build them
|
||||
into a tree.
|
||||
|
||||
=cut
|
||||
|
||||
sub buildTree {
|
||||
my ($class,$objs,$nodes) = @_;
|
||||
|
||||
$nodes ||= {};
|
||||
my %parentToChild = ();
|
||||
my $keyColumn = $class->keyColumn();
|
||||
foreach my $obj (grep {$_} @$objs) {
|
||||
$nodes->{$obj->get($keyColumn)} = $obj;
|
||||
$obj->{daughters} ||= [];
|
||||
next if ($obj->get('parentId') == $obj->get($keyColumn));
|
||||
push @{ $parentToChild{$obj->get('parentId')} }, $obj;
|
||||
}
|
||||
|
||||
foreach my $parentId (keys %parentToChild) {
|
||||
if (my $parent = $nodes->{$parentId}) {
|
||||
$parent->add_daughters($class->sortSiblings($parentToChild{$parentId}));
|
||||
}
|
||||
}
|
||||
|
||||
return $nodes;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canDown
|
||||
|
||||
Returns tree if this object can be moved down within the current tree.
|
||||
|
||||
=cut
|
||||
|
||||
sub canDown { $_[0]->right_sister }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canLeft
|
||||
|
||||
Returns tree if this object can be moved left within the current tree.
|
||||
|
||||
=cut
|
||||
|
||||
sub canLeft { $_[0]->mother ? 1 : 0 }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canRight
|
||||
|
||||
Returns tree if this object can be moved right within the current tree.
|
||||
|
||||
=cut
|
||||
|
||||
sub canRight { $_[0]->left_sister }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 canUp
|
||||
|
||||
Returns tree if this object can be moved up within the current tree.
|
||||
|
||||
=cut
|
||||
|
||||
sub canUp { $_[0]->left_sister }
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 classSettings
|
||||
|
||||
This class method must be overridden to return a hash reference with one or
|
||||
more of the following keys.
|
||||
|
||||
=over
|
||||
|
||||
=item useDummyRoot
|
||||
|
||||
This should be set to true for classes that don't store their root node in
|
||||
the database.
|
||||
|
||||
=item properties
|
||||
|
||||
This should be a hash reference keyed by the field names of the table that
|
||||
this class refers to (and should be able to be manipulated with this classes
|
||||
get() and set() methods). The values of the hash reference should be hash
|
||||
references containing settings for each field.
|
||||
|
||||
=over
|
||||
|
||||
=item * defaultValue
|
||||
|
||||
The default value for this field (optional).
|
||||
|
||||
=item * key
|
||||
|
||||
Should be true for the primary key column (one field must be set in this way).
|
||||
|
||||
=item * quote
|
||||
|
||||
Should be true for fields that need to be quoted in database queries.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 dummyRoot
|
||||
|
||||
This creates a dummy root object for classes that do not store their root in
|
||||
the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub dummyRoot {
|
||||
$_[0]->new(
|
||||
-properties => { pageId => 0 },
|
||||
-noSet => 1
|
||||
);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 getTree ( [ \%p, $maxDepth, \%nodes ] )
|
||||
|
||||
This method has varying behaviour depending on the context from which it is
|
||||
called.
|
||||
|
||||
In instance context rows from the table will be recursivley selected using the
|
||||
current object as the root, and then the tree will be built:
|
||||
|
||||
$self->getTree();
|
||||
|
||||
In class context, the all rows are selected from the table, and then the tree
|
||||
is built.
|
||||
|
||||
$class->getTree();
|
||||
|
||||
In all cases a hashref is returned.
|
||||
|
||||
{ keyColumnValue => WebGUI::Persistent::Tree object }
|
||||
|
||||
If defined $maxDepth maybe used to limit the depth of the recursion.
|
||||
|
||||
If %p is defined, the arguments are passed directly to the new or multiNew
|
||||
methods, this allows multiple trees to be easily stored in one table:
|
||||
|
||||
$class->getTree({treeId => 4});
|
||||
|
||||
$nodes can be a hash reference to objects that have already been obtained from
|
||||
the database.
|
||||
|
||||
=cut
|
||||
|
||||
sub getTree {
|
||||
my ($self,$p,$maxDepth,$nodes) = @_;
|
||||
my $class = ref($self) || $self;
|
||||
$nodes ||= {};
|
||||
$p ||={};
|
||||
|
||||
unless (ref($self)) {
|
||||
if ($class->useDummyRoot()) {
|
||||
$self = $class->dummyRoot();
|
||||
}
|
||||
|
||||
if (!defined($maxDepth)) {
|
||||
return $class->buildTree([$class->multiNew(%$p)],$nodes);
|
||||
} elsif (!ref($self)) {
|
||||
$self = $class->new(%$p,$class->keyColumn() => 0);
|
||||
}
|
||||
}
|
||||
$nodes->{$self->get($class->keyColumn())} ||= $self;
|
||||
|
||||
return $nodes if (defined($maxDepth) && ($maxDepth-- > 0));
|
||||
|
||||
my @objs = $class->multiNew(
|
||||
parentId => $self->get($class->keyColumn()),%$p
|
||||
);
|
||||
if (@objs) {
|
||||
$self->buildTree(\@objs,$nodes);
|
||||
return $nodes if (defined($maxDepth) && !$maxDepth) ;
|
||||
$_->getTree($p,$maxDepth,$nodes) foreach @objs;
|
||||
}
|
||||
|
||||
return $nodes;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 grandmotherChildrenAndSelf( $keyColumnId )
|
||||
|
||||
Using the given $keyColumnId this method fetches the grandmother, children,
|
||||
and the object refered to by the $keyColumnId.
|
||||
|
||||
Returns a list of objects.
|
||||
|
||||
=cut
|
||||
|
||||
sub grandmotherChildrenAndSelf {
|
||||
my ($class,$keyColumnId) = @_;
|
||||
return undef unless defined($keyColumnId);
|
||||
my $self = $class->new(-minimumFields=>1,$class->keyColumn() => $keyColumnId);
|
||||
return undef unless $self;
|
||||
return ($self,$class->motherSelfAndSisters($self->get('parentId')));
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 minimumFields
|
||||
|
||||
The minimumFields for Trees must also include the parentId, and the
|
||||
sequenceNumber.
|
||||
|
||||
See WebGUI::Persistent.
|
||||
|
||||
=cut
|
||||
|
||||
sub minimumFields {
|
||||
my ($class) = @_;
|
||||
unless ($class->classData->{minimumFields}) {
|
||||
my $fields = $class->SUPER::minimumFields();
|
||||
push @$fields, 'parentId';
|
||||
push @$fields, 'sequenceNumber' if ($class->properties->{sequenceNumber});
|
||||
}
|
||||
return $class->classData->{minimumFields};
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 motherSelfAndSisters( $keyColumnId )
|
||||
|
||||
Given the $keyColumnId, this method fetches the related mother and sisters.
|
||||
|
||||
Returns a list of objects.
|
||||
|
||||
=cut
|
||||
|
||||
sub motherSelfAndSisters {
|
||||
my ($class,$keyColumnId) = @_;
|
||||
return undef unless defined($keyColumnId);
|
||||
my $self = $class->new(-minimumFields=>1,$class->keyColumn() => $keyColumnId);
|
||||
return undef unless $self;
|
||||
|
||||
my $parentId = $self->get('parentId');
|
||||
my @objs = $class->multiNew(
|
||||
-minimumFields => 1,
|
||||
-where => [
|
||||
[{
|
||||
parentId => $parentId,
|
||||
$class->keyColumn() => $parentId,
|
||||
}],
|
||||
$class->keyColumn()." != $keyColumnId",
|
||||
]
|
||||
);
|
||||
if ($class->useDummyRoot() && $parentId == 0) {
|
||||
push @objs, $class->dummyRoot();
|
||||
}
|
||||
return ($self,@objs);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveDown( [ $keyColumnId ] )
|
||||
|
||||
In class context:
|
||||
|
||||
$class->moveDown($keyColumnId);
|
||||
|
||||
The required parent, sister and child objects are fetched from the database,
|
||||
and the tree is built and manipulated.This class' inheritance from
|
||||
WebGUI::Persistent takes care of any database work.
|
||||
|
||||
In instance context:
|
||||
|
||||
$self->moveDown();
|
||||
|
||||
The current object is assumed to be in a pre-built tree, and so the tree is
|
||||
simply manipulated. This class' inheritance from WebGUI::Persistent takes care
|
||||
of any database work.
|
||||
|
||||
=cut
|
||||
|
||||
sub moveDown {
|
||||
my ($self,$keyColumnId) = @_;
|
||||
my $class = ref($self) || $self;
|
||||
return unless $class->properties->{sequenceNumber};
|
||||
|
||||
unless (ref($self)) {
|
||||
my $nodes = $class->buildTree([$class->motherSelfAndSisters($keyColumnId)]);
|
||||
$self = $nodes->{$keyColumnId};
|
||||
}
|
||||
|
||||
return unless ($self && $self->canDown());
|
||||
|
||||
my $right = $self->right_sister;
|
||||
$self->swapSisters($right);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveLeft( [ $keyColumnId ] )
|
||||
|
||||
In class context:
|
||||
|
||||
$class->moveLeft($keyColumnId);
|
||||
|
||||
The required parent, sister and child objects are fetched from the database,
|
||||
and the tree is built and manipulated.This class' inheritance from
|
||||
WebGUI::Persistent takes care of any database work.
|
||||
|
||||
In instance context:
|
||||
|
||||
$self->moveLeft();
|
||||
|
||||
The current object is assumed to be in a pre-built tree, and so the tree is
|
||||
simply manipulated. This class' inheritance from WebGUI::Persistent takes care
|
||||
of any database work.
|
||||
|
||||
=cut
|
||||
|
||||
sub moveLeft {
|
||||
my ($self,$keyColumnId) = @_;
|
||||
my $class = ref($self) || $self;
|
||||
|
||||
unless (ref($self)) {
|
||||
my $nodes = $class->buildTree([$class->grandmotherChildrenAndSelf($keyColumnId)]);
|
||||
$self = $nodes->{$keyColumnId};
|
||||
}
|
||||
|
||||
return unless ($self && $self->canLeft());
|
||||
|
||||
my $sister = $self->mother;
|
||||
|
||||
# Close up hole left by imminent move
|
||||
map {
|
||||
$_->set({sequenceNumber => $_->get('sequenceNumber') - 1 })
|
||||
} $self->right_sisters();
|
||||
|
||||
$self->unlink_from_mother;
|
||||
$sister->add_right_sister($self);
|
||||
|
||||
my $newSequenceNumber = $sister->get('sequenceNumber') + 1;
|
||||
|
||||
map {
|
||||
$_->set({sequenceNumber => $_->get('sequenceNumber') + 1 })
|
||||
} $self->right_sisters();
|
||||
|
||||
$self->set({
|
||||
parentId => $sister->get('parentId'),
|
||||
sequenceNumber => $newSequenceNumber
|
||||
});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveRight( [ $keyColumnId ] )
|
||||
|
||||
In class context:
|
||||
|
||||
$class->moveRight($keyColumnId);
|
||||
|
||||
The required parent, sister and child objects are fetched from the database,
|
||||
and the tree is built and manipulated.This class' inheritance from
|
||||
WebGUI::Persistent takes care of any database work.
|
||||
|
||||
In instance context:
|
||||
|
||||
$self->moveRight();
|
||||
|
||||
The current object is assumed to be in a pre-built tree, and so the tree is
|
||||
simply manipulated. This class' inheritance from WebGUI::Persistent takes care
|
||||
of any database work.
|
||||
|
||||
=cut
|
||||
|
||||
sub moveRight {
|
||||
my ($self,$keyColumnId) = @_;
|
||||
my $class = ref($self) || $self;
|
||||
|
||||
unless (ref($self)) {
|
||||
my @objs = $class->motherSelfAndSisters($keyColumnId);
|
||||
my $nodes = $class->buildTree(\@objs);
|
||||
$self = $nodes->{$keyColumnId};
|
||||
}
|
||||
|
||||
return unless ($self && $self->canRight());
|
||||
|
||||
my $keyColumn = $class->keyColumn();
|
||||
my $mother = $self->left_sister;
|
||||
$mother->getTree({-minimumFields => 1},1);
|
||||
|
||||
# Close up hole left by imminent move
|
||||
map {
|
||||
$_->set({sequenceNumber => $_->get('sequenceNumber') -1 })
|
||||
} $self->right_sisters();
|
||||
|
||||
# Add as right-most daughter of current left-sister
|
||||
$self->unlink_from_mother;
|
||||
$mother->add_daughter($self);
|
||||
|
||||
my $newSequenceNumber = 1;
|
||||
if (my $sister = $self->left_sister()) {
|
||||
$newSequenceNumber = $sister->get('sequenceNumber') + 1;
|
||||
}
|
||||
|
||||
$self->set({
|
||||
parentId => $mother ? $mother->get($keyColumn) : 0,
|
||||
sequenceNumber => $newSequenceNumber
|
||||
});
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 moveUp( [ $keyColumnId ] )
|
||||
|
||||
In class context:
|
||||
|
||||
$class->moveUp($keyColumnId);
|
||||
|
||||
The required parent, sister and child objects are fetched from the database,
|
||||
and the tree is built and manipulated.This class' inheritance from
|
||||
WebGUI::Persistent takes care of any database work.
|
||||
|
||||
In instance context:
|
||||
|
||||
$self->moveUp();
|
||||
|
||||
The current object is assumed to be in a pre-built tree, and so the tree is
|
||||
simply manipulated. This class' inheritance from WebGUI::Persistent takes care
|
||||
of any database work.
|
||||
|
||||
=cut
|
||||
|
||||
sub moveUp {
|
||||
my ($self,$keyColumnId) = @_;
|
||||
my $class = ref($self) || $self;
|
||||
return unless $class->properties->{sequenceNumber};
|
||||
|
||||
unless (ref($self)) {
|
||||
my $nodes = $class->buildTree([$class->motherSelfAndSisters($keyColumnId)]);
|
||||
$self = $nodes->{$keyColumnId};
|
||||
}
|
||||
|
||||
return unless ($self && $self->canUp());
|
||||
|
||||
my $left = $self->left_sister;
|
||||
$self->swapSisters($left);
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 recursiveDelete
|
||||
|
||||
Deletes this element, and all subsequent elements in the tree. The C<getTree>
|
||||
method must have been called to build the tree.
|
||||
|
||||
=cut
|
||||
|
||||
sub recursiveDelete {
|
||||
my ($self) = @_;
|
||||
my @ids;
|
||||
$self->walk_down({callback => sub {push @ids, $_[0]->get($_[0]->keyColumn())}});
|
||||
$self->multiDelete(collateralFolderId => \@ids) if @ids;
|
||||
return @ids;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 sortSiblings( \@siblings )
|
||||
|
||||
Sorts an array of objects according to sequenceNumber
|
||||
|
||||
=cut
|
||||
|
||||
sub sortSiblings {
|
||||
my ($class,$siblings) = @_;
|
||||
return @$siblings unless $class->properties->{sequenceNumber};
|
||||
return sort {
|
||||
($a->get('sequenceNumber') <=> $b->get('sequenceNumber'))
|
||||
} @$siblings;
|
||||
}
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
|
||||
=head2 swapSisters( $sister )
|
||||
|
||||
Swaps two sisters over (they must be in a built tree), and updates their
|
||||
sequenc numbers.
|
||||
|
||||
=cut
|
||||
|
||||
sub swapSisters {
|
||||
my $self = shift;
|
||||
my ($other) = @_;
|
||||
my @daughters = $self->self_and_sisters;
|
||||
my $a = $self ->my_daughter_index;
|
||||
my $b = $other->my_daughter_index;
|
||||
@daughters[$a, $b] = ($other, $self);
|
||||
$self->mother->set_daughters(@daughters);
|
||||
|
||||
my $tmp = $self->get('sequenceNumber');
|
||||
$self->set({sequenceNumber => $other->get('sequenceNumber')});
|
||||
$other->set({sequenceNumber => $tmp});
|
||||
}
|
||||
|
||||
=head2 useDummyRoot
|
||||
|
||||
Returns true if useDummyRoot is set in classSettings().
|
||||
|
||||
=cut
|
||||
|
||||
sub useDummyRoot {
|
||||
my ($class) = @_;
|
||||
unless ($class->classData->{useDummyRoot}) {
|
||||
$class->classData->{useDummyRoot} = $class->classSettings->{useDummyRoot};
|
||||
}
|
||||
return $class->classData->{useDummyRoot}
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -48,9 +48,10 @@ use HTML::CalendarMonthSimple ();
|
|||
#use HTML::TagFilter (); # commented because it is causing problems with attachments
|
||||
use Net::LDAP ();
|
||||
use Parse::PlainConfig ();
|
||||
#use Authen::Smb (); #uncomment when using this type of authentication.
|
||||
use Tie::CPHash ();
|
||||
use Tie::IxHash ();
|
||||
|
||||
use Tree::DAG_Node ();
|
||||
|
||||
#----------------------------------------
|
||||
# WebGUI modules.
|
||||
|
|
@ -60,6 +61,7 @@ use WebGUI::Attachment ();
|
|||
use WebGUI::Authentication ();
|
||||
use WebGUI::Cache ();
|
||||
use WebGUI::Collateral ();
|
||||
use WebGUI::CollateralFolder ();
|
||||
use WebGUI::DateTime ();
|
||||
#use WebGUI::Discussion (); # compile problems when this is included
|
||||
use WebGUI::ErrorHandler ();
|
||||
|
|
@ -76,6 +78,13 @@ use WebGUI::Mail ();
|
|||
use WebGUI::MessageLog ();
|
||||
use WebGUI::Navigation ();
|
||||
use WebGUI::Node ();
|
||||
use WebGUI::Persistent ();
|
||||
use WebGUI::Persistent::Query ();
|
||||
use WebGUI::Persistent::Tree ();
|
||||
use WebGUI::Persistent::Query::Delete ();
|
||||
use WebGUI::Persistent::Query::Insert ();
|
||||
use WebGUI::Persistent::Query::Select ();
|
||||
use WebGUI::Persistent::Query::Update ();
|
||||
use WebGUI::Operation ();
|
||||
use WebGUI::Operation::Account ();
|
||||
use WebGUI::Operation::Admin ();
|
||||
|
|
|
|||
BIN
www/extras/toolbar/default/moveLeft.gif
Normal file
BIN
www/extras/toolbar/default/moveLeft.gif
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 363 B |
BIN
www/extras/toolbar/default/moveRight.gif
Normal file
BIN
www/extras/toolbar/default/moveRight.gif
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 363 B |
Loading…
Add table
Add a link
Reference in a new issue