Story Archive now plays nice with urlExtensions

docs/gotcha.txt

@@ -7,6 +7,11 @@ 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.4
+--------------------------------------------------------------------
+    * WebGUI now depends on Monkey::Patch for doing sanely scoped
+      monkeypatches.
+
 7.10.3
 --------------------------------------------------------------------
      * In the Collaboration System, previously the Group to Post group

lib/WebGUI/Asset/Wobject/StoryArchive.pm

@@ -367,9 +367,14 @@ Constructs a url for a subfolder with the given name.
 
 sub getFolderUrl {
     my ($self, $name) = @_;
-    my $base = $self->getUrl;
-    $base    =~ s/(.*)\..*/$1/;
-    return "$base/$name";
+    my $session = $self->session;
+    my $base    = $self->getUrl;
+    $base       =~ s/(.*)\..*/$1/;
+    my $url     = "$base/$name";
+    if (my $ext = $session->setting->get('urlExtension')) {
+        $url .= ".$ext";
+    }
+    return $session->url->urlize($url);
 }
 
 #-------------------------------------------------------------------

sbin/testEnvironment.pl

@@ -148,6 +148,7 @@ checkModule("CHI",                          "0.34"       );
 checkModule('IO::Socket::SSL',                           );
 checkModule('Net::Twitter',                 "3.13006"    );
 checkModule('PerlIO::eol',                  "0.14"       );
+checkModule('Monkey::Patch',                '0.03'       );
 
 failAndExit("Required modules are missing, running no more checks.") if $missingModule;
 

t/Asset/Wobject/StoryArchive.t

@@ -63,7 +63,7 @@ $canPostMaker->prepare({
     fail     => [1, $reader            ],
 });
 
-my $tests = 54
+my $tests = 56
           + $canPostMaker->plan
           ;
 plan tests => 1
@@ -133,22 +133,34 @@ my $folderName = $dt->strftime('%B_%d_%Y');
 $folderName =~ s/^(\w+_)0/$1/;
 is($todayFolder->getTitle, $folderName, '... folder has the right name');
 my $folderUrl = $archive->getFolderUrl($folderName);
-is($todayFolder->getUrl, $folderUrl, '... folder has the right URL');
+is($todayFolder->get('url'), $folderUrl, '... folder has the right URL');
 is($todayFolder->getParent->getId, $archive->getId, '... created folder has the right parent');
 is($todayFolder->get('state'),  'published', '... created folder is published');
 is($todayFolder->get('status'), 'approved',  '... created folder is approved');
 is($todayFolder->get('styleTemplateId'), $archive->get('styleTemplateId'),  '... created folder has correct styleTemplateId');
 
 {
+    my $undo = WebGUI::Test->overrideSetting(urlExtension => 'ext');
     my $arch2 = $home->addChild({
         className => $class,
-        url       => 'home/extension-tester.ext',
         title     => 'Extension Tester',
     });
     addToCleanup($arch2);
-    ok defined $arch2->getFolder($now), 'getFolder with url extension';
-    is $arch2->getFolderUrl('blah'), '/home/extension-tester/blah',
-        'folder urls have extension properly stripped';
+
+    is $arch2->get('url'),
+        'home/extension-tester.ext',
+        'ext added';
+
+    is $arch2->getFolderUrl('blah'),
+        'home/extension-tester/blah.ext',
+        'folder url: strip extension from parent and add to child';
+
+    my $folder = $arch2->getFolder($now);
+    ok defined $folder, 'getFolder with url extension';
+
+    is $folder->get('url'),
+        $arch2->getFolderUrl($folder->getMenuTitle),
+        'getFolderUrl and folder getUrl match';
 }
 
 my $sameFolder = $archive->getFolder($now);

t/lib/WebGUI/Test.pm

@@ -39,6 +39,7 @@ use Scalar::Util        qw( blessed );
 use List::MoreUtils     qw( any );
 use Carp                qw( carp croak );
 use JSON                qw( from_json to_json );
+use Monkey::Patch       qw( patch_object );
 use Scope::Guard;
 
 BEGIN {
@@ -687,6 +688,24 @@ sub getMailFromQueue {
 
 #----------------------------------------------------------------------------
 
+=head2 overrideSetting (name, val)
+
+Overrides WebGUI::Test->session->setting->get($name) to return $val until the
+handle this method returns goes out of scope.
+
+=cut
+
+sub overrideSetting {
+    my ($class, $name, $val) = @_;
+    patch_object $class->session->setting => get => sub {
+        my $get = shift;
+        return $val if $_[1] eq $name;
+        goto &$get;
+    };
+}
+
+#----------------------------------------------------------------------------
+
 =head2 cleanupAdminInbox ( )
 
 Push a list of Asset objects onto the stack of assets to be automatically purged