Merge branch 'master' into WebGUI8. Merged up to 7.9.12

docs/changelog/7.x.x.txt

@@ -1,3 +1,14 @@
+7.9.13
+
+7.9.12
+ - webgui.org homepage gives 404  (#11778)
+ - fixed #11779: SQLReport can run arbitrary queries
+ - fixed possible vulnerability loading template parser
+ - fixed possible vulnerability loading help files
+ - fixed possible vulnerability with filenames in storage locations
+ - fixed possible vulnerability with extracting tar files in storage locations
+ - fixed possible vulnerability with extracting files in Zip Archive assets.
+
 7.9.11
  - fixed #11755: New cart does not update shipping methods correctly
  - fixed #11757: Update the USPS International driver for new country names

lib/WebGUI/Asset/File/ZipArchive.pm

@@ -46,7 +46,7 @@ use Archive::Tar;
 use Archive::Zip;
 use Cwd ();
 use Scope::Guard ();
-
+use WebGUI::Utility qw/isIn/;
 
 
 =head1 NAME
@@ -96,19 +96,21 @@ sub unzip {
     my $dir_guard = Scope::Guard->new(sub { chdir $cwd });
    
 	my $i18n = WebGUI::International->new($self->session,"Asset_ZipArchive");
-	if ($filename =~ m/\.zip/i) {
+	if ($filename =~ m/\.zip$/i) {
 		my $zip = Archive::Zip->new();
 		unless ($zip->read($filename) == $zip->AZ_OK){
 			$self->session->errorHandler->warn($i18n->get("zip_error"));
 			return 0;
 		}
-		$zip->extractTree();  
-	} elsif ($filename =~ m/\.tar/i) {
+		$zip->extractTree();
+        $self->fixFilenames;
+	} elsif ($filename =~ m/\.tar$/i) {
 		Archive::Tar->extract_archive($filepath.'/'.$filename,1);
 		if (Archive::Tar->error) {
 			$self->session->errorHandler->warn(Archive::Tar->error);
 			return 0;
 		}
+        $self->fixFilenames;
 	} else {
 		$self->session->errorHandler->warn($i18n->get("bad_archive"));
 	}
@@ -118,6 +120,28 @@ sub unzip {
 
 #-------------------------------------------------------------------
 
+=head2 fixFilenames ( )
+
+Fix any files with dangerous extensions, in all files that were extracted.  This is done
+locally, because if we used a method from Storage, then it would also rename HTML files.
+
+=cut
+
+sub fixFilenames {
+	my $self    = shift;
+    my $storage = $self->getStorageLocation;
+    my $files   = $storage->getFiles('all');
+    FILE: foreach my $file (@{ $files }) {
+        my $extension = $storage->getFileExtension($file);
+        next FILE unless isIn($extension, qw/pl perl pm cgi php asp sh/);
+        my $newFile = $file;
+        $newFile =~ s/\.$extension/_$extension.txt/;
+        $storage->renameFile($file, $newFile);
+    }
+}
+
+#-------------------------------------------------------------------
+
 =head2 prepareView ( )
 
 See WebGUI::Asset::prepareView() for details.
@@ -159,7 +183,7 @@ override processEditForm => sub {
 		return undef;
 	}
 	
-	unless ($file =~ m/\.tar/i || $file =~ m/\.zip/i) {
+	unless ($file =~ m/\.tar$/i || $file =~ m/\.zip$/i) {
 		$storage->delete;
 		$self->session->db->write("update FileAsset set filename=NULL where assetId=".$self->session->db->quote($self->getId));
 		$self->session->scratch->set("za_error",$i18n->get("za_error"));

lib/WebGUI/Asset/Template.pm

@@ -113,6 +113,7 @@ use WebGUI::Asset::Template::HTMLTemplate;
 use WebGUI::Utility;
 use WebGUI::Form;
 use WebGUI::Exception;
+use List::MoreUtils qw{ any };
 use Tie::IxHash;
 use Clone qw/clone/;
 use HTML::Packer;
@@ -410,14 +411,23 @@ A parser class to use. Defaults to "WebGUI::Asset::Template::HTMLTemplate"
 sub getParser {
     my $class = shift;
     my $session = shift;
-    my $parser = shift || $session->config->get("defaultTemplateParser") || "WebGUI::Asset::Template::HTMLTemplate";
+    my $parser = shift;
 
-    if ($parser eq "") {
-        return WebGUI::Asset::Template::HTMLTemplate->new($session);
-    } else {
-        eval("use $parser");
-        return $parser->new($session);
+    # If parser is not in the config, throw an error message
+    if ( $parser && $parser ne $session->config->get('defaultTemplateParser') 
+                && !any { $_ eq $parser } @{$session->config->get('templateParsers')} ) {
+        WebGUI::Error::NotInConfig->throw(
+            error       => "Attempted to load template parser '$parser' that is not in config file",
+            module      => $parser,
+            configKey   => 'templateParsers',
+        );
     }
+    else {
+        $parser ||= $session->config->get("defaultTemplateParser") || "WebGUI::Asset::Template::HTMLTemplate";
+    }
+
+    WebGUI::Pluggable::load( $parser );
+    return $parser->new($session);
 }
 
 #-------------------------------------------------------------------

lib/WebGUI/Content/Asset.pm

@@ -62,7 +62,6 @@ The URL for this request.
 sub dispatch {
     my $session      = shift;
 	my $assetUrl     = shift;
-    return undef unless $assetUrl;
     my $permutations = getUrlPermutations($assetUrl);
     foreach my $url (@{ $permutations }) {
         if (my $asset = getAsset($session, $url)) {
@@ -137,14 +136,17 @@ The URL to permute.
 
 sub getUrlPermutations {
     my $url          = shift;
+    ##Handle empty urls (sitename only)
+    return ['/'] if !$url
+                 ||  $url eq '/';
     my @permutations = ();
-    return \@permutations if !$url;
     if ($url =~ /\.\w+$/) {
         push @permutations, $url;
         $url =~ s/\.\w+$//;
     }
     my $uri       = URI->new($url);
     my @fragments = $uri->path_segments();
+    use Data::Dumper;
     FRAG: while (@fragments) {
         last FRAG if $fragments[-1] eq '';
         push @permutations, join "/", @fragments;

lib/WebGUI/DatabaseLink.pm

@@ -382,6 +382,9 @@ sub queryIsAllowed {
 	my $self  = shift;
 	my $query = shift;
 
+    # Remove all comments before checking validity
+    $query =~ s{/[*].*?[*]/}{}g;
+
     my ($firstWord) = $query =~ /(\w+)/;
     $firstWord = lc $firstWord;
     return isIn($firstWord, split(/\s+/, lc $self->{_databaseLink}{allowedKeywords})) ? 1 : 0;

lib/WebGUI/Exception.pm

@@ -284,6 +284,12 @@ use Exception::Class (
         isa             => 'WebGUI::Error',
         description     => 'A database error',
     },
+
+    'WebGUI::Error::NotInConfig' => {
+        isa             => 'WebGUI::Error',
+        description     => 'A module was requested that does not exist in the configuration file.',
+        fields          => [qw{ module configKey }],
+    },
 );
 
 {

lib/WebGUI/Operation/Help.pm

@@ -41,18 +41,16 @@ been already and logs errors during the load.
 sub _loadHelp {
 	my $session = shift;
 	my $helpPackage = shift;
+        eval { WebGUI::Pluggable::load( $helpPackage ); };
+	if ($@) {
+		$session->errorHandler->error("Help failed to compile: $helpPackage. ".$@);
+		return {};
+	}
 	if (defined *{"$helpPackage\::HELP"}) {  ##Symbol table lookup
 		our $table;
 		*table = *{"$helpPackage\::HELP"};  ##Create alias into symbol table
 		return $table;  ##return whole hashref
 	}
-	my $load = sprintf 'use %-s; $%-s::HELP', $helpPackage, $helpPackage;
-	my $help = eval($load);
-	if ($@) {
-		$session->errorHandler->error("Help failed to compile: $helpPackage. ".$@);
-		return {};
-	}
-	return $help;
 }
 
 #-------------------------------------------------------------------

lib/WebGUI/Storage.pm

@@ -316,10 +316,7 @@ sub addFileFromFilesystem {
         return undef;
     }
     my $filename = (File::Spec->splitpath( $pathToFile ))[2];
-    if (isIn($self->getFileExtension($filename), qw(pl perl sh cgi php asp pm))) {
-        $filename =~ s/\./\_/g;
-        $filename .= ".txt";
-    }
+    $filename = $self->block_extensions($filename);
     $filename = $self->session->url->makeCompliant($filename);
     my $source;
     my $dest;
@@ -382,11 +379,7 @@ sub addFileFromFormPost {
             if ($upload->size > 1024 * $self->session->setting->get("maxAttachmentSize"));
         $clientFilename =~ s/.*[\/\\]//;
         $clientFilename =~ s/^thumb-//;
-        my $type = $self->getFileExtension($clientFilename);
-        if (isIn($type, qw(pl perl sh cgi php asp html htm))) { # make us safe from malicious uploads
-            $clientFilename =~ s/\./\_/g;
-            $clientFilename .= ".txt";
-        }
+        $clientFilename = $self->block_extensions($clientFilename);
         $filename = $session->url->makeCompliant($clientFilename);
         my $filePath = $self->getPath($filename);
         $attachmentCount++;
@@ -451,10 +444,7 @@ The content to write to the file.
 
 sub addFileFromScalar {
 	my ($self, $filename, $content) = @_;
-    if (isIn($self->getFileExtension($filename), qw(pl perl sh cgi php asp html htm))) { # make us safe from malicious uploads
-        $filename =~ s/\./\_/g;
-        $filename .= ".txt";
-    }
+    $filename = $self->block_extensions($filename);
     $filename = $self->session->url->makeCompliant($filename);
 	if (open(my $FILE, ">", $self->getPath($filename))) {
 		print $FILE $content;
@@ -500,6 +490,32 @@ sub adjustMaxImageSize {
 
 #-------------------------------------------------------------------
 
+=head2 block_extensions ( $file )
+
+Rename files so they can't be used for malicious purposes.  The list of bad extensions
+includs shell script, perl scripts, php, ASP, perl modules and HTML files.
+
+Any file found with a bad extension will be renamed from file.ext to file_ext.txt
+
+=head3 $file
+
+The file to check for bad extensions.
+
+=cut 
+
+sub block_extensions {
+    my $self = shift;
+    my $file = shift;
+    my $extension = $self->getFileExtension($file);
+    if (isIn($extension, qw(pl perl sh cgi php asp pm html htm))) {
+        $file =~ s/\.$extension/\_$extension/;
+        $file .= ".txt";
+    }
+    return $file;
+}
+
+#-------------------------------------------------------------------
+
 =head2 clear ( )
 
 Clears a storage location of all files.  If configured for CDN, add
@@ -1827,6 +1843,13 @@ sub untar {
     }, ".");
     $self->_changeOwner(@files);
 
+    ##Prevent dangerous files from being added to the storage location via untar
+    FILE: foreach my $file (@files) {
+        my $blockname = $temp->block_extensions($file);
+        next FILE if $blockname eq $file;
+        $temp->renameFile($file, $blockname);
+    }
+
     chdir $originalDir;
     return $temp;
 }

t/Asset/File/ZipArchive.t

@@ -0,0 +1,44 @@
+#-------------------------------------------------------------------
+# WebGUI is Copyright 2001-2009 Plain Black Corporation.
+#-------------------------------------------------------------------
+# Please read the legal notices (docs/legal.txt) and the license
+# (docs/license.txt) that came with this distribution before using
+# this software.
+#-------------------------------------------------------------------
+# http://www.plainblack.com                     info@plainblack.com
+#-------------------------------------------------------------------
+
+use FindBin;
+use strict;
+use lib "$FindBin::Bin/../../lib";
+
+use WebGUI::Storage;
+use WebGUI::Asset;
+use WebGUI::Asset::File::ZipArchive;
+
+use WebGUI::Test;
+use Test::More; # increment this value for each test you create
+use Test::Deep;
+plan tests => 2;
+
+my $session = WebGUI::Test->session;
+
+my $node = WebGUI::Asset->getImportNode($session);
+
+my $arch = $node->addChild({
+    className => 'WebGUI::Asset::File::ZipArchive',
+});
+
+WebGUI::Test->addToCleanup($arch);
+
+my $storage = $arch->getStorageLocation;
+$storage->addFileFromFilesystem(WebGUI::Test->getTestCollateralPath('extensions.tar'));
+ok($arch->unzip($storage, 'extensions.tar'), 'unzip returns true when it successfully unpacked');
+
+$arch->fixFilenames();
+
+cmp_bag(
+    $storage->getFiles, 
+    [ qw{ extensions.tar extension_pm.txt extension_perl.txt extension.html extensions extensions/extension.html }], 
+    'files after fixFilenames, html files left alone'
+);

t/Asset/Template.t

@@ -16,9 +16,11 @@ use WebGUI::Test;
 use WebGUI::Session;
 use WebGUI::Asset::Template;
 use Exception::Class;
-use Test::More tests => 46; # increment this value for each test you create
+
+use Test::More;
 use Test::Deep;
 use Data::Dumper;
+use Test::Exception;
 use JSON qw{ from_json };
 
 my $session = WebGUI::Test->session;
@@ -211,3 +213,28 @@ is($session->setting->get('userFunctionStyleId'), $userStyleTemplate->getId, 'Re
 
 $userStyleTemplate->purge;
 is($session->setting->get('userFunctionStyleId'), 'PBtmpl0000000000000060', 'purge resets the user function style template to Fail Safe');
+
+#----------------------------------------------------------------------------
+# Verify getParser
+WebGUI::Test->originalConfig( 'defaultTemplateParser' );
+WebGUI::Test->originalConfig( 'templateParsers' );
+$session->config->set( 'templateParsers', [ 'WebGUI::Asset::Template::HTMLTemplateExpr' ] );
+# Leaving out 'WebGUI::Asset::Template::TemplateToolkit' on purpose
+$session->config->set( 'defaultTemplateParser', 'WebGUI::Asset::Template::HTMLTemplateExpr' );
+
+my $class = 'WebGUI::Asset::Template';
+dies_ok { $class->getParser( $session, '::HI::' ) } "Invalid parser dies";
+
+isa_ok $class->getParser( $session ), 'WebGUI::Asset::Template::HTMLTemplateExpr', 'no parser passed in gets the default parser';
+
+$session->config->delete( 'defaultTemplateParser' );
+isa_ok $class->getParser( $session ), 'WebGUI::Asset::Template::HTMLTemplate', 'no parser passed and no default gets HTMLTemplate';
+$session->config->set( 'defaultTemplateParser', 'WebGUI::Asset::Template::HTMLTemplateExpr' );
+
+throws_ok 
+    { $class->getParser( $session, 'WebGUI::Asset::Template::TemplateToolkit') } 
+    'WebGUI::Error::NotInConfig',
+    'Parser not in config dies';
+isa_ok $class->getParser( $session, 'WebGUI::Asset::Template::HTMLTemplateExpr'), 'WebGUI::Asset::Template::HTMLTemplateExpr', 'parser in config is created';
+
+done_testing;

t/Asset/Wobject/Matrix.t

@@ -135,6 +135,8 @@ is($matrixListing->get('views'),'1','Views were incremented');
 # Test getListings
 
 my $expectedAssetId = $matrixListing->getId;
+my $safeAssetId     = $expectedAssetId;
+$safeAssetId =~ s/-/_____/;
 
 my $listings = $matrix->getListings;
 
@@ -209,19 +211,19 @@ cmp_deeply(
         $compareListData,
         {ResultSet=>{
             Result=>[
-                    {$expectedAssetId=>$matrixListingLastUpdatedHuman,fieldType=>"lastUpdated",name=>"Last Updated"},
-                    {fieldType=>"category",name=>"category1",$expectedAssetId=>$matrixListing->get('title').' '},
-                    {fieldType=>"category",name=>"category2",$expectedAssetId=>$matrixListing->get('title').' '}
+                    {$safeAssetId=>$matrixListingLastUpdatedHuman,fieldType=>"lastUpdated",name=>"Last Updated"},
+                    {fieldType=>"category",name=>"category1",$safeAssetId=>$matrixListing->get('title').' '},
+                    {fieldType=>"category",name=>"category2",$safeAssetId=>$matrixListing->get('title').' '}
                     ]
             },
          ColumnDefs=>[{
-            key         =>$expectedAssetId,
+            key         =>$safeAssetId,
             label       =>$matrixListing->get('title').' '.$matrixListing->get('version'),
             formatter   =>"formatColors",
             url         =>$matrixListing->getUrl,
             lastUpdated =>$matrixListingLastUpdatedHuman,
             }],
-         ResponseFields=>["attributeId", "name", "description","fieldType", "checked",$expectedAssetId,$expectedAssetId."_compareColor"]
+         ResponseFields=>["attributeId", "name", "description","fieldType", "checked",$safeAssetId,$safeAssetId."_compareColor"]
         },
         'Getting compareListData as JSON'
     ); 

t/Asset/Wobject/SyndicatedContent.t

@@ -51,7 +51,7 @@ isa_ok($syndicated_content, 'WebGUI::Asset::Wobject::SyndicatedContent');
 my $newSyndicatedContentSettings = {
 	cacheTimeout => 124,
 	templateId   => "PBtmpl0000000000000065", 
-    rssUrl      => 'http://svn.webgui.org/svnweb/plainblack/rss/WebGUI/',
+    rssUrl      => 'http://github.com/plainblack/webgui/commits/master.atom',
 };
 
 # update the new values for this instance

t/Content/Asset.t

@@ -22,6 +22,8 @@ use WebGUI::Test; # Must use this before any other WebGUI modules
 use WebGUI::Session;
 use WebGUI::Content::Asset;
 
+my $output;
+
 #----------------------------------------------------------------------------
 # Init
 my $session         = WebGUI::Test->session;
@@ -74,20 +76,26 @@ my $td
         url             => 'testdispatch',
     } );
 
+diag $td->getId;
 WebGUI::Test->addToCleanup( WebGUI::VersionTag->getWorking( $session ) );
 
 #----------------------------------------------------------------------------
 # Tests
 
-plan tests => 15;        # Increment this number for each test you create
+plan tests => 17;        # Increment this number for each test you create
 
 #----------------------------------------------------------------------------
 # test getUrlPermutation( url ) method
 
 cmp_deeply( 
     WebGUI::Content::Asset::getUrlPermutations( ),
-    [ ],
-    "Handles no URL gracefully",
+    [ '/' ],
+    "No URL returns /",
+);
+cmp_deeply( 
+    WebGUI::Content::Asset::getUrlPermutations( '/' ),
+    [ '/' ],
+    "URL with only slash is handled",
 );
 cmp_deeply( 
     WebGUI::Content::Asset::getUrlPermutations( "one" ),
@@ -119,19 +127,13 @@ cmp_deeply(
 #----------------------------------------------------------------------------
 # test dispatch( session, url ) method
 is ($session->asset, undef, 'session asset is not defined, yet');
-is(
-    WebGUI::Content::Asset::dispatch( $session, "testdispatch" ),
-    "www_view one",
-    "Regular www_view",
-);
+$output = WebGUI::Content::Asset::dispatch( $session, "testdispatch" );
+is $output, "www_view one", "Regular www_view";
 
-is ($session->asset->getId, $td->getId, 'dispatch set the session asset');
+is $session->asset && $session->asset->getId, $td->getId, 'dispatch set the session asset';
 
-is(
-    WebGUI::Content::Asset::dispatch( $session, "testdispatch/foo" ),
-    "bar",
-    "special /foo handler",
-);
+$output = WebGUI::Content::Asset::dispatch( $session, "testdispatch/foo" );
+is $output, "bar", "special /foo handler";
 
 # Add an asset that clobbers the TestDispatch's /foo
 my $clobberingTime
@@ -170,8 +172,16 @@ $session->request->setup_body({
     func        => "edit",
 });
 
-my $output  = WebGUI::Content::Asset::dispatch( $session, "testdispatch/foo" );
+$output  = WebGUI::Content::Asset::dispatch( $session, "testdispatch/foo" );
 isnt( $output, "you'll never see me!", "func=edit was declined" );
 isnt( $output, "www_edit one", "func=edit was not for us" );
 
+# Test that empty URL returns the default page.
+$session->request->setup_body({ });
+my $originalDefaultPage = $session->setting->get('defaultPage');
+$session->setting->set('defaultPage', $td->getId);
+$output  = WebGUI::Content::Asset::dispatch( $session );
+is $output, 'www_view one', 'an empty URL returns the default asset';
+$session->setting->set('defaultPage', $originalDefaultPage);
+
 #vim:ft=perl

t/DatabaseLink.t

@@ -156,6 +156,11 @@ my $queries = [
         expect  => 1,
         comment => '... parenthesized',
     },
+    {
+        query   => '/* SELECT */ DELETE FROM users',
+        expect  => 0,
+        comment => 'Initial comment with valid keyword',
+    },
 ];
 
 plan tests => 14

t/Help/compiled.t

@@ -16,13 +16,14 @@ use WebGUI::Test;
 use WebGUI::Session;
 use WebGUI::Pluggable;
 use WebGUI::Operation::Help;
+use Test::More;
+use Test::Exception;
 
 #The goal of this test is to verify that all entries in the lib/WebGUI/Help
 #directory compile.  This test is necessary because WebGUI::Operation::Help
 #will return an empty hash if it won't compile, and the help will simply
 #disappear.
 
-use Test::More;
 my $numTests = 0;
 
 my $session = WebGUI::Test->session;
@@ -31,10 +32,19 @@ my @helpFileSet = WebGUI::Pluggable::findAndLoad('WebGUI::Help');
 
 $numTests = scalar @helpFileSet; #One for each help compile
 
-plan tests => $numTests;
+plan tests => $numTests + 2;
 
 foreach my $helpFile (@helpFileSet) {
     my ($namespace) = $helpFile =~ m{WebGUI::Help::(.+$)};
     my $help = WebGUI::Operation::Help::_load($session, $namespace);
     ok(keys %{ $help }, "$namespace compiled");
 }
+
+#----------------------------------------------------------------------------
+# Test invalid help files
+WebGUI::Test->interceptLogging( sub {
+    my $log_data = shift;
+    lives_ok { WebGUI::Operation::Help::_load( $session, '::HI::' ) } "invalid help module doesnt die";
+    like( $log_data->{error}, qr/^Help failed to compile/, 'invalid help module errored' );
+});
+

t/Storage.t

@@ -29,10 +29,13 @@ my $session = WebGUI::Test->session;
 
 my $cwd = Cwd::cwd();
 
-my ($extensionTests, $fileIconTests) = setupDataDrivenTests($session);
+my ($extensionTests, $fileIconTests, $block_extension_tests) = setupDataDrivenTests($session);
 
-my $numTests = 140; # increment this value for each test you create
-plan tests => $numTests + scalar @{ $extensionTests } + scalar @{ $fileIconTests };
+plan tests => 141
+            + scalar @{ $extensionTests }
+            + scalar @{ $fileIconTests  }
+            + scalar @{ $block_extension_tests }
+            ;
 
 my $uploadDir = $session->config->get('uploadsPath');
 ok ($uploadDir, "uploadDir defined in config");
@@ -374,6 +377,17 @@ ok (-e $tempStor->getPath(), '... directory was created');
 ok($tempStor->getHexId, '... getHexId returns something');
 is($tempStor->getHexId, $session->id->toHex($tempStor->getId), '... returns the hexadecimal value of the GUID');
 
+####################################################
+#
+# block_extensions
+#
+####################################################
+
+##Run a set of extensions through and watch how the files get changed.
+foreach my $extTest (@{ $block_extension_tests }) {
+	is( $storage1->block_extensions($extTest->{filename}), $extTest->{blockname}, $extTest->{comment} );
+}
+
 ####################################################
 #
 # tar
@@ -397,10 +411,20 @@ my $untarStorage = $tarStorage->untar('tar.tar');
 addToCleanup($untarStorage);
 isa_ok( $untarStorage, "WebGUI::Storage", "untar: returns a WebGUI::Storage object");
 is (substr($untarStorage->getPathFrag, 0, 5), 'temp/', 'untar: puts stuff in the temp directory');
-##Note, getFiles will NOT recurse, so do not use a deep directory structure here
 cmp_bag($untarStorage->getFiles, $copiedStorage->getFiles, 'tar and untar loop preserve all files');
 isnt($untarStorage->getPath, $tarStorage->getPath, 'untar did not reuse the same path as the tar storage object');
 
+$tarStorage->addFileFromFilesystem(WebGUI::Test->getTestCollateralPath('extensions.tar'));
+my $extensionStorage = $tarStorage->untar('extensions.tar');
+WebGUI::Test->addToCleanup($extensionStorage);
+use Data::Dumper;
+diag Dumper $extensionStorage->getFiles;
+cmp_bag(
+    $extensionStorage->getFiles, 
+    [ qw{ extension_pm.txt extension_perl.txt extension_html.txt extensions extensions/extension_html.txt }], 
+    'untar fixes file extensions'
+);
+
 ####################################################
 #
 # clear
@@ -474,11 +498,11 @@ use HTTP::Request::Common;
 
 {
     my $req = POST '/', Content_Type => 'form-data', Content => [
-        oneFile => [ WebGUI::Test->getTestCollateralPath('International/lib/WebGUI/i18n/PigLatin/WebGUI.pm') ],
+        oneFile => [ WebGUI::Test->getTestCollateralPath('littleTextFile') ],
     ];
     local $session->{_request} = Plack::Request->new($req->to_psgi);
-    is($formStore->addFileFromFormPost('oneFile'), 'WebGUI.pm', '... returns the name of the uploaded file');
-    cmp_bag($formStore->getFiles, [ qw/WebGUI.pm/ ], '... adds the file to the storage location');
+    is($formStore->addFileFromFormPost('oneFile'), 'littleTextFile', '... returns the name of the uploaded file');
+    cmp_bag($formStore->getFiles, [ qw/littleTextFile/ ], '... adds the file to the storage location');
 }
 
 {
@@ -487,7 +511,7 @@ use HTTP::Request::Common;
     ];
     local $session->{_request} = Plack::Request->new($req->to_psgi);
     is($formStore->addFileFromFormPost('thumbFile'), 'thumb.gif', '... strips thumb- prefix from files');
-    cmp_bag($formStore->getFiles, [ qw/WebGUI.pm thumb.gif/ ], '... adds the file to the storage location');
+    cmp_bag($formStore->getFiles, [ qw/littleTextFile thumb.gif/ ], '... adds the file to the storage location');
 }
 
 ####################################################
@@ -754,6 +778,63 @@ sub setupDataDrivenTests {
         },
     ];
 
+    my $block_extension_tests = [
+        {
+            filename  => 'filename',
+            blockname => 'filename',
+            comment  => 'no extension',
+        },
+        {
+            filename  => 'filename.pl',
+            blockname => 'filename_pl.txt',
+            comment  => 'pl file',
+        },
+        {
+            filename  => 'filename.perl',
+            blockname => 'filename_perl.txt',
+            comment  => 'perl file',
+        },
+        {
+            filename  => 'filename.cgi',
+            blockname => 'filename_cgi.txt',
+            comment  => 'cgi file',
+        },
+        {
+            filename  => 'filename.php',
+            blockname => 'filename_php.txt',
+            comment  => 'php file',
+        },
+        {
+            filename  => 'filename.asp',
+            blockname => 'filename_asp.txt',
+            comment  => 'asp file',
+        },
+        {
+            filename  => 'filename.pm',
+            blockname => 'filename_pm.txt',
+            comment  => 'perl module file',
+        },
+        {
+            filename  => 'filename.htm',
+            blockname => 'filename_htm.txt',
+            comment  => 'htm file',
+        },
+        {
+            filename  => 'filename.html',
+            blockname => 'filename_html.txt',
+            comment  => 'html file',
+        },
+        {
+            filename  => 'filename.pm.txt',
+            blockname => 'filename.pm.txt',
+            comment  => 'internal .pm not touched',
+        },
+        {
+            filename  => 'filename.txt.pm',
+            blockname => 'filename.txt_pm.txt',
+            comment  => 'double extension handled',
+        },
+    ];
     my $fileIconTests = [
         {
             filename => 'filename',
@@ -777,5 +858,5 @@ sub setupDataDrivenTests {
         },
     ];
 
-    return ($extensionTests, $fileIconTests)
+    return ($extensionTests, $fileIconTests, $block_extension_tests);
 }