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

Clone stopped working in several tests in 5.14.2. Remove it in favor of Storable::dclone.

Browse source 
Clone handles being passed scalar data, but dclone does not.
This commit is contained in:
Colin Kuskie 2012-10-23 10:00:53 -07:00
parent 1b4f7c33fa
commit be37f12ab1
23 changed files with 70 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

6
docs/gotcha.txt
View file

@ -7,6 +7,12 @@ upgrading from one version to the next, or even between multiple
versions. Be sure to heed the warnings contained herein as they will
save you many hours of grief.
7.10.27
--------------------------------------------------------------------
* Due to instability in the Clone module, WebGUI is now using Storable's
dclone instead. Storable is a core Perl module, so you do not need
to install anything new.
7.10.25
--------------------------------------------------------------------
* Custom WebGUI plugins written using WebGUI::Crud with hand built forms

4
lib/WebGUI/Asset.pm
View file

@ -16,7 +16,7 @@ package WebGUI::Asset;
use Carp qw( croak confess );
use Scalar::Util qw( blessed weaken );
use Clone qw(clone);
use Storable qw/dclone/;
use JSON;
use HTML::Packer;
@ -2721,7 +2721,7 @@ to set the keywords for this asset.
sub update {
my $self = shift;
my $requestedProperties = shift;
my $properties = clone($requestedProperties);
my $properties = dclone($requestedProperties);
$properties->{lastModified} = time();
# if keywords were specified, then let's set them the right way

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

@ -23,7 +23,7 @@ use WebGUI::Form;
use WebGUI::Exception;
use List::MoreUtils qw{ any };
use Tie::IxHash;
use Clone qw/clone/;
use Storable qw/dclone/;
use HTML::Packer;
use JSON qw{ to_json from_json };
use Try::Tiny;
@ -914,8 +914,8 @@ on this being here.
sub update {
my $self = shift;
my $requestedProperties = shift;
my $properties = clone($requestedProperties);
my $requestedProperties = shift || {};
my $properties = dclone($requestedProperties);
if (exists $properties->{headBlock}) {
$properties->{extraHeadTags} .= $properties->{headBlock};

14
lib/WebGUI/Asset/Wobject/Survey/ResponseJSON.pm
View file

@ -45,7 +45,7 @@ use strict;
use JSON;
use Params::Validate qw(:all);
use List::Util qw(shuffle);
use Clone qw/clone/;
use Storable qw/dclone/;
use Safe;
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
@ -368,7 +368,12 @@ sub surveyOrderIndex {
if ($variable) {
return $self->response->{surveyOrderLookup}{$variable};
} else {
return clone $self->response->{surveyOrderLookup};
if (ref $self->response->{surveyOrderLookup}) {
return dclone $self->response->{surveyOrderLookup};
}
else {
return {};
}
}
}
@ -1465,7 +1470,10 @@ sub responseReport {
my $answer = $self->survey->answer( [ $sIndex, $qIndex, $aIndex ] );
# Massage each answer response and push it onto the list
if ( my $response = clone $self->responses->{$answerId} ) {
if ( my $response = $self->responses->{$answerId} ) {
if (ref $response) {
$response = dclone $response;
}
$response->{isCorrect} = $answer->{isCorrect} ? 1 : 0;
$response->{id} = $aIndex;
$response->{score} = $answer->{value}; # N.B. answer score is consistently misnamed 'value'

19
lib/WebGUI/Asset/Wobject/Survey/SurveyJSON.pm
View file

@ -50,7 +50,7 @@ use strict;
use JSON;
use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { WebGUI::Error::InvalidParam->throw( error => shift ) } );
use Clone qw/clone/;
use Storable qw/dclone/;
use WebGUI::Asset::Wobject::Survey::ExpressionEngine;
# The maximum value of questionsPerPage is currently hardcoded here
@ -407,13 +407,13 @@ sub getObject {
return if !$count;
if ( $count == 1 ) {
return clone $self->sections->[ sIndex($address) ];
return dclone $self->sections->[ sIndex($address) ];
}
elsif ( $count == 2 ) {
return clone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ];
return dclone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ];
}
else {
return clone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ]->{answers}
return dclone $self->sections->[ sIndex($address) ]->{questions}->[ qIndex($address) ]->{answers}
->[ aIndex($address) ];
}
}
@ -950,21 +950,21 @@ sub copy {
if ( $count == 1 ) {
# Clone the indexed section onto the end of the list of sections..
push @{ $self->{_sections} }, clone $self->section($address);
push @{ $self->{_sections} }, dclone $self->section($address);
# Update $address with the index of the newly created section
$address->[0] = $self->lastSectionIndex;
}
elsif ( $count == 2 ) {
# Clone the indexed question onto the end of the list of questions..
push @{ $self->section($address)->{questions} }, clone $self->question($address);
push @{ $self->section($address)->{questions} }, dclone $self->question($address);
# Update $address with the index of the newly created question
$address->[1] = $self->lastQuestionIndex($address);
}
elsif ( $count == 3 ) {
# Clone the indexed answer onto the end of the list of answers..
push @{ $self->question($address)->{answers} }, clone $self->answer($address);
push @{ $self->question($address)->{answers} }, dclone $self->answer($address);
# Update $address with the index of the newly created answer
$address->[2]++;
@ -1194,7 +1194,10 @@ sub getMultiChoiceBundle {
my ($type) = validate_pos( @_, { type => SCALAR | UNDEF } );
# Return a cloned copy of the bundle structure
return clone $self->{multipleChoiceTypes}->{$type};
if ($self->{multipleChoiceTypes}->{$type}) {
return dclone $self->{multipleChoiceTypes}->{$type};
}
return undef;
}
=head2 addAnswersToQuestion ($address, $answers)

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

@ -24,7 +24,7 @@ use HTML::Parser;
use URI::Escape;
use WebGUI::Form;
use WebGUI::Search;
use Clone qw/clone/;
use Storable qw/dclone/;
#-------------------------------------------------------------------
@ -618,7 +618,7 @@ sub getKeywordVariables {
my $variables = [];
KEYWORD: foreach my $member (@{ $hierarchy }) {
my $varBlock = clone $member;
my $varBlock = dclone $member;
$varBlock->{level} = $level;
$varBlock->{isTopLevel} = $level == 0;
$varBlock->{indent_loop} = [ map { { indent => $_ } } 1..$level ];

4
lib/WebGUI/Cache/CHI.pm
View file

@ -3,7 +3,7 @@ package WebGUI::Cache::CHI;
use strict;
use base 'WebGUI::Cache';
use File::Temp qw/tempdir/;
use Clone qw/clone/;
use Storable qw/dclone/;
use CHI;
=head1 NAME
@ -93,7 +93,7 @@ sub new {
# Create CHI object from config
my $chi;
unless ( $chi = $session->stow->get( "CHI" ) ) {
my $cacheConf = clone $session->config->get('cache');
my $cacheConf = dclone $session->config->get('cache');
$cacheConf->{namespace} = $namespace;
$cacheConf->{is_size_aware} = 1;

11
lib/WebGUI/Crud.pm
View file

@ -20,7 +20,7 @@ use strict;
use Class::InsideOut qw(readonly private id register);
use JSON;
use Tie::IxHash;
use Clone qw/clone/;
use Storable qw/dclone/;
use WebGUI::DateTime;
use WebGUI::Exception;
use WebGUI::Utility;
@ -579,11 +579,16 @@ sub get {
# return a specific property
if (defined $name) {
return clone $objectData{id $self}{$name};
if (ref $objectData{id $self}{$name}) {
return dclone $objectData{id $self}{$name};
}
else {
return $objectData{id $self}{$name};
}
}
# return a copy of all properties
return clone $objectData{id $self};
return dclone $objectData{id $self};
}
#-------------------------------------------------------------------

4
lib/WebGUI/Shop/PayDriver.pm
View file

@ -27,7 +27,7 @@ use WebGUI::Macro;
use WebGUI::User;
use WebGUI::Shop::Cart;
use JSON;
use Clone qw/clone/;
use Storable qw/dclone/;
use Scalar::Util qw/blessed/;
=head1 NAME
@ -708,7 +708,7 @@ sub update {
$jsonOptions,
$self->paymentGatewayId
]);
my $storedProperties = clone $properties;
my $storedProperties = dclone $properties;
$options{ id $self } = $storedProperties;
return;

2
sbin/testEnvironment.pl
View file

@ -133,7 +133,6 @@ checkModule("File::Path", "2.07" );
checkModule("Module::Find", "0.06" );
checkModule("Class::C3", "0.21" );
checkModule("Params::Validate", "0.91" );
checkModule("Clone", "0.31" );
checkModule('JavaScript::Packer', '1.002' );
checkModule('CSS::Packer', '1.000' );
checkModule('HTML::Packer', "1.000" );
@ -162,6 +161,7 @@ checkModule('Kwargs', );
checkModule('Data::ICal', '0.16' );
checkModule('common::sense', '3.2' );
checkModule('Geo::Coder::Googlev3', '0.07' );
checkModule('Storable', '2.00' );
failAndExit("Required modules are missing, running no more checks.") if $missingModule;

2
t/Asset/Wobject/Collaboration/templateVariables.t
View file

@ -89,7 +89,7 @@ ok( !$posts->[0]->{'user.isVisitor'}, 'first post made by visitor');
ok( $posts->[0]->{'hideProfileUrl'}, 'hide profile url, and user is visitor');
ok( !$posts->[0]->{'lastReply.user.isVisitor'}, 'lastReply not made by visitor');
ok( $posts->[0]->{'lastReply.hideProfileUrl'}, 'lastReply hide profile url, since user is visitor');
is( $posts->[0]->{'lastReply.url'}, $threads[1]->getUrl.'?pn=1#id'.$threads[1]->getId, 'lastReply url has a query fragment prefixed by "id"');
is( $posts->[0]->{'lastReply.url'}, $threads[1]->getUrl.'#id'.$threads[1]->getId, 'lastReply url has a query fragment prefixed by "id"');
is( $posts->[0]->{'url'}, $threads[1]->getUrl.'#id'.$threads[1]->getId, 'url has a query fragment prefixed by "id"');

8
t/Asset/Wobject/Survey/SurveyJSON.t
View file

@ -13,7 +13,7 @@ use Data::Dumper;
use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session;
use JSON;
use Clone qw/clone/;
use Storable qw/dclone/;
#----------------------------------------------------------------------------
# Init
@ -2112,13 +2112,13 @@ sub buildSectionSkeleton {
my $sections = [];
my ($bareSection, $bareQuestion, $bareAnswer) = getBareSkeletons();
foreach my $questionSpec ( @{ $spec } ) {
my $section = clone $bareSection;
my $section = dclone $bareSection;
push @{ $sections }, $section;
foreach my $answers ( @{$questionSpec} ) {
my $question = clone $bareQuestion;
my $question = dclone $bareQuestion;
push @{ $section->{questions} }, $question;
while ($answers-- > 0) {
my $answer = clone $bareAnswer;
my $answer = dclone $bareAnswer;
push @{ $question->{answers} }, $answer;
}
}

1
t/Asset/Wobject/Survey/Test.t
View file

@ -13,7 +13,6 @@ use Data::Dumper;
use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session;
use JSON;
use Clone qw/clone/;
#----------------------------------------------------------------------------
# Init

4
t/Asset/Wobject/Survey/package.t
View file

@ -9,7 +9,7 @@ use lib "$FindBin::Bin/../../../lib";
use Test::More;
use Test::Deep;
use Data::Dumper;
use Clone qw/clone/;
use Storable qw/dclone/;
use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session;
WebGUI::Error->Trace(1); # Turn on tracing of uncaught Exception::Class exceptions
@ -52,7 +52,7 @@ ok exists $asset_data->{question_types}->{toes}, 'the toes type in a question ty
explain $asset_data;
ok !exists $asset_data->{question_types}->{name}, 'name question not in question types';
$asset_data->{question_types}->{fingers} = clone $asset_data->{question_types}->{toes};
$asset_data->{question_types}->{fingers} = $asset_data->{question_types}->{toes};
$survey->importAssetCollateralData($asset_data);

4
t/Asset/Wobject/WeatherData.t
View file

@ -19,7 +19,7 @@ use strict;
use lib "$FindBin::Bin/../../lib";
use Test::More;
use Test::Deep;
use Clone qw/clone/;
use Storable qw/dclone/;
use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session;
@ -64,7 +64,7 @@ my $templateMock = Test::MockObject->new({});
$templateMock->set_isa('WebGUI::Asset::Template');
$templateMock->set_always('getId', $templateId);
my $templateVars;
$templateMock->mock('process', sub { $templateVars = clone $_[1]; } );
$templateMock->mock('process', sub { $templateVars = dclone $_[1]; } );
my $asset = $node->addChild( {
className => 'WebGUI::Asset::Wobject::WeatherData',

4
t/Asset/maximum_assets.t
View file

@ -18,7 +18,7 @@ use WebGUI::Asset;
use Test::More;
use Test::Deep;
use Clone qw/clone/;
use Storable qw/dclone/;
plan tests => 1;
@ -37,7 +37,7 @@ my $templateMock = Test::MockObject->new({});
$templateMock->set_isa('WebGUI::Asset::Template');
$templateMock->set_always('getId', $templateId);
my $templateVars;
$templateMock->mock('process', sub { $templateVars = clone($_[1]); } );
$templateMock->mock('process', sub { $templateVars = dclone($_[1]); } );
$session->setting->set('userFunctionStyleId', $templateId);
##Have to have a user who can add assets to the root node

4
t/Asset/processTemplate.t
View file

@ -18,7 +18,7 @@ use WebGUI::Asset;
use Test::More;
use Test::Deep;
use Clone qw/clone/;
use Storable qw/dclone/;
plan tests => 1;
@ -39,7 +39,7 @@ my $templateMock = Test::MockObject->new({});
$templateMock->set_isa('WebGUI::Asset::Template');
$templateMock->set_always('getId', $templateId);
my $templateVars;
$templateMock->mock('process', sub { $templateVars = clone($_[1]); } );
$templateMock->mock('process', sub { $templateVars = dclone($_[1]); } );
{
WebGUI::Test->mockAssetId($templateId, $templateMock);

2
t/Group.t
View file

@ -396,7 +396,7 @@ cmp_ok($expirationDate-time(), '>', 50, 'checking expire offset override on addU
$session->db->dbh->do('DROP TABLE IF EXISTS myUserTable');
WebGUI::Test->addToCleanup(SQL => 'DROP TABLE IF EXISTS myUserTable');
$session->db->dbh->do(q!CREATE TABLE myUserTable (userId CHAR(22) binary NOT NULL default '', PRIMARY KEY(userId)) TYPE=InnoDB!);
$session->db->dbh->do(q!CREATE TABLE myUserTable (userId CHAR(22) binary NOT NULL default '', PRIMARY KEY(userId)) ENGINE=InnoDB!);
my $sth = $session->db->prepare('INSERT INTO myUserTable VALUES(?)');
foreach my $mob (@mob) {

2
t/Macro/GroupText.t
View file

@ -49,7 +49,7 @@ is($output, 'Group Not a Group was not found', 'Non-existant group returns an er
##Create a small database
$session->db->dbh->do('DROP TABLE IF EXISTS myUserTable');
$session->db->dbh->do(q!CREATE TABLE myUserTable (userId CHAR(22) binary NOT NULL default '', PRIMARY KEY(userId)) TYPE=InnoDB!);
$session->db->dbh->do(q!CREATE TABLE myUserTable (userId CHAR(22) binary NOT NULL default '', PRIMARY KEY(userId)) Engine=InnoDB!);
WebGUI::Test->addToCleanup(SQL => 'DROP TABLE IF EXISTS myUserTable');
##Create a bunch of users and put them in the table.

2
t/Macro/SQL.t
View file

@ -33,7 +33,7 @@ my $originalMacroAccessValue = $WebGUIdbLink->macroAccessIsAllowed();
$session->db->dbh->do('DROP TABLE IF EXISTS testTable');
WebGUI::Test->addToCleanup(SQL => 'DROP TABLE testTable');
$session->db->dbh->do('CREATE TABLE testTable (zero int(8), one int(8), two int(8), three int(8), four int(8), five int(8), six int(8), seven int(8), eight int(8), nine int(8), ten int(8), eleven int(8) ) TYPE=InnoDB');
$session->db->dbh->do('CREATE TABLE testTable (zero int(8), one int(8), two int(8), three int(8), four int(8), five int(8), six int(8), seven int(8), eight int(8), nine int(8), ten int(8), eleven int(8) ) ENGINE=InnoDB');
$session->db->dbh->do('INSERT INTO testTable (zero, one, two, three, four, five, six, seven, eight, nine, ten, eleven ) VALUES(0,1,2,3,4,5,6,7,8,9,10,11)');
$session->db->dbh->do('INSERT INTO testTable (zero, one, two, three, four, five, six, seven, eight, nine, ten, eleven ) VALUES(100,101,102,103,104,105,106,107,108,109,110,111)');

2
t/SQL.t
View file

@ -173,7 +173,7 @@ SKIP: {
skip("No InnoDB tables in this MySQL. Skipping all transaction related tests.",7) if (lc $mysqlVariables{have_innodb} ne 'yes');
$session->db->dbh->do('DROP TABLE IF EXISTS testTable');
$session->db->dbh->do('CREATE TABLE testTable (myIndex int(8) NOT NULL default 0, message CHAR(64), PRIMARY KEY(myIndex)) TYPE=InnoDB');
$session->db->dbh->do('CREATE TABLE testTable (myIndex int(8) NOT NULL default 0, message CHAR(64), PRIMARY KEY(myIndex)) Engine=InnoDB');
addToCleanup( SQL => 'DROP TABLE testTable' );
my $dbh2 = WebGUI::SQL->connect($session,$session->config->get("dsn"), $session->config->get("dbuser"), $session->config->get("dbpass"));

4
t/Shop/Transaction.t
View file

@ -23,7 +23,7 @@ use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Session;
use WebGUI::Shop::Transaction;
use WebGUI::Inbox;
use Clone qw/clone/;
use Storable qw/dclone/;
#----------------------------------------------------------------------------
# Init
@ -269,7 +269,7 @@ my $templateMock = Test::MockObject->new({});
$templateMock->set_isa('WebGUI::Asset::Template');
$templateMock->set_always('getId', $templateId);
my @templateVars;
$templateMock->mock('process', sub { push @templateVars, clone $_[1]; } );
$templateMock->mock('process', sub { push @templateVars, dclone $_[1]; } );
$session->setting->set('shopReceiptEmailTemplateId', $templateId);

6
t/lib/WebGUI/Test.pm
View file

@ -29,7 +29,7 @@ use base qw(Test::Builder::Module);
use Test::MockObject;
use Test::MockObject::Extends;
use Log::Log4perl; # load early to ensure proper order of END blocks
use Clone qw(clone);
use Storable qw(dclone);
use File::Basename qw(dirname fileparse);
use File::Spec::Functions qw(abs2rel rel2abs catdir catfile updir);
use IO::Handle ();
@ -108,7 +108,7 @@ sub import {
sub _initSession {
my $session = our $SESSION = $CLASS->newSession(1);
my $originalSetting = clone $session->setting->get;
my $originalSetting = dclone $session->setting->get;
$CLASS->addToCleanup(sub {
while (my ($param, $value) = each %{ $originalSetting }) {
$session->setting->set($param, $value);
@ -612,7 +612,7 @@ sub originalConfig {
my ($class, $param) = @_;
my $safeValue = my $value = $CLASS->session->config->get($param);
if (ref $value) {
$safeValue = clone $value;
$safeValue = dclone $value;
}
# add cleanup handler if this is the first time we were run
if (! keys %originalConfig) {