Fix anti UNC substitution, log-file creation, lack-of-volname handlin…

…g, parent_dir * Dancer.pm - Added handling for absent vol-name (e.g. in unix) which prevents catdir()/etc creating double-leading-slashes. - Used a more portable syntax for parent directory * Dancer::FileUtils - Created _trim_UNC() -> reusable, more robust, faster anti-UNC-substitution. - Used splitpath in path_no_verify() -> simpler, faster and more fault-tolerant path calculation. * Dancer::Logger::File - Rewrote logfile creation functions -> more fault-tolerant, cleaner, faster. - Used tempdir() for temp-log-file creation -> replace previous hackish methods. - Removed double-carp error (when logdir doesn't exist). * t/02_request/14_uploads.t - Unmask all but the one remaining masked test for Win32. Include a note explaining why the remaining test fails on Win32. * many files - Forced the TMPDIR => 1 option for tempdir(), so Win32 behaves.
PerlDancer · Feb 23, 2011 · e98c7b7 · e98c7b7
1 parent 732cd12
commit e98c7b7
Show file tree

Hide file tree

Showing 18 changed files with 95 additions and 79 deletions.
diff --git a/lib/Dancer.pm b/lib/Dancer.pm
@@ -324,7 +324,12 @@ sub _init {
     }
 
     my @script_dirs = File::Spec->splitdir($script_dirs);
-    my $script_path = Dancer::FileUtils::d_catdir($script_vol, $script_dirs);
+    my $script_path;
+    if ($script_vol) {
+        $script_path = path($script_vol, $script_dirs);
+    } else {
+        $script_path = path($script_dirs);
+    }
 
     my $LAYOUT_PRE_DANCER_1_2 = 1;
 
@@ -337,7 +342,7 @@ sub _init {
       || (
           $LAYOUT_PRE_DANCER_1_2
         ? $script_path
-        : File::Spec->rel2abs(path($script_path, '..'))
+        : File::Spec->rel2abs(path($script_path, File::Spec->updir()))
       );
 
     # once the dancer_appdir have been defined, we export to env

diff --git a/lib/Dancer/FileUtils.pm b/lib/Dancer/FileUtils.pm
@@ -13,36 +13,42 @@ use vars '@EXPORT_OK';
 
 @EXPORT_OK = qw(path dirname read_file_content read_glob_content open_file);
 
-# Undo UNC special-casing catfile-voodoo on cygwin in the next three functions
-sub d_catfile {
-    my $root = shift;
-    $root =~ s{^[/\\]+([/\\])}{$1};
-    File::Spec->catfile($root, @_);
-}
-sub d_catdir {
-    my $root = shift;
-    $root =~ s{^[/\\]+([/\\])}{$1};
-    File::Spec->catdir($root, @_);
-}
-sub d_canonpath {
-    my $root = shift;
-    $root =~ s{^[/\\]+([/\\])}{$1};
-    File::Spec->canonpath($root, @_);
+# Undo UNC special-casing catfile-voodoo on cygwin
+sub _trim_UNC {
+    if ($^O eq 'cygwin') {
+        return if ($#_ < 0);
+        my ($slashes, $part, @parts) = (0, undef, @_);
+        while(defined($part = shift(@parts))) { last if ($part); $slashes++ }
+        $slashes += ($part =~ s/^[\/\\]+//);
+        if ($slashes == 2) {
+            return("/" . $part, @parts);
+        } else {
+            my $slashstr = '';
+            $slashstr .= '/' for (1 .. $slashes);
+            return($slashstr . $part, @parts);
+        }
+    }
+    return(@_);
 }
+sub d_catfile { File::Spec->catfile(_trim_UNC(@_)) }
+sub d_catdir { File::Spec->catdir(_trim_UNC(@_)) }
+sub d_canonpath { File::Spec->canonpath(_trim_UNC(@_)) }
+sub d_catpath { File::Spec->catpath(_trim_UNC(@_)) }
+sub d_splitpath { File::Spec->splitpath(_trim_UNC(@_)) }
 
 sub path { d_catfile(@_) }
 
 sub path_no_verify {
-    my @nodes = @_;
+    my @nodes = File::Spec->splitpath(d_catdir(@_)); # 0=vol,1=dirs,2=file
     my $path = '';
 
     # [0->?] path(must exist),[last] file(maybe exists)
-    if($#nodes > 0) {
-        $path = realpath(d_catdir(@nodes[0 .. ($#nodes - 1)])).'/';
-    } elsif(not File::Spec->file_name_is_absolute($nodes[0])) {
-        $path = Cwd::cwd.'/';
+    if($nodes[1]) {
+        $path = realpath(File::Spec->catpath(@nodes[0 .. 1],'')) . '/';
+    } else {
+        $path = Cwd::cwd . '/';
     }
-    $path .= d_canonpath($nodes[$#nodes]);
+    $path .= $nodes[2];
     return $path;
 }
 

diff --git a/lib/Dancer/Logger/File.pm b/lib/Dancer/Logger/File.pm
@@ -4,20 +4,31 @@ use warnings;
 use Carp;
 use base 'Dancer::Logger::Abstract';
 
-use File::Spec;
+use File::Temp qw/tempdir/;
 use Dancer::Config 'setting';
 use Dancer::FileUtils qw(open_file);
 use IO::File;
 
 sub logdir {
     my $altpath = setting('log_path');
     return $altpath if($altpath);
-    my $appdir = setting('appdir');
-    my $logroot = $appdir;
-    unless($logroot) {
-        $logroot = Dancer::FileUtils::d_canonpath(File::Spec->tmpdir().'/dancer-'.$$);
-        if (!-d $logroot and not mkdir $logroot) {
-            carp "log directory $logroot doesn't exist, unable to create";
+    my $logroot = setting('appdir');
+    if ($logroot) {
+        if (!-d $logroot && not mkdir $logroot) {
+            carp "log directory $logroot doesn't exist, am unable to create it";
+            return;
+        }
+    } else {
+        unless($logroot = tempdir(CLEANUP => 1, TMPDIR => 1)) {
+            carp "cannot create temp log directory";
+            return;
+        }
+    }
+    unless (-w $logroot and -x $logroot) {
+        my $perm = (stat $logroot)[2] & 07777;
+        chmod($perm | 0700, $logroot);
+        unless (-w $logroot and -x $logroot) {
+            carp "log directory $logroot isn't writable/executable and can't chmod it";
             return;
         }
     }
@@ -27,23 +38,16 @@ sub logdir {
 sub init {
     my ($self) = @_;
     my $logdir = logdir();
+    return unless ($logdir);
+    my $logfile = setting('environment');
 
-    if (!-d $logdir && not mkdir $logdir) {
-        carp "log directory $logdir doesn't exist, unable to create";
+    mkdir($logdir) unless(-d $logdir);
+    $logfile = File::Spec->catfile($logdir, "$logfile.log");
+    my $fh;
+    unless($fh = open_file('>>', $logfile)) {
+        carp "unable to create or append to $logfile";
         return;
     }
-    if (!-w $logdir or !-x $logdir) {
-        my $perm = (stat $logdir)[2] & 07777;
-        chmod($perm | 0700, $logdir);
-        carp "log directory $logdir isn't writable/executable, can't chmod it";
-        return;
-    }
-
-    my $logfile = setting('environment');
-    $logfile = Dancer::FileUtils::path_no_verify($logdir, "$logfile.log");
-
-    my $fh = open_file('>>', $logfile) or carp "unable to create or append to $logfile";
-
     $fh->autoflush;
     $self->{logfile} = $logfile;
     $self->{fh} = $fh;

diff --git a/t/01_config/03_logger.t b/t/01_config/03_logger.t
@@ -6,10 +6,10 @@ use Dancer::FileUtils;
 use File::Temp qw/tempdir/;
 use File::Spec qw/catfile/;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 set appdir => $dir;
 
-eval { logger 'foobar'};
+eval { logger 'foobar' };
 like($@, qr/unknown logger/, 'invalid logger detected');
 
 ok(logger('file'), 'file-based logger correctly set');
@@ -23,26 +23,24 @@ ok(error($message), "error sent");
 my $logdir = Dancer::FileUtils::path_no_verify(setting('appdir'), 'logs');
 ok((-d $logdir), "log directory exists");
 
-my $logfile = Dancer::FileUtils::d_catfile($logdir, "development.log");
-ok((-r $logfile), "logfile exists");
+my $dev_logfile = Dancer::FileUtils::d_catfile($logdir, "development.log");
+ok((-r $dev_logfile), "logfile exists");
 
-open LOGFILE, '<', $logfile;
+open LOGFILE, '<', $dev_logfile;
 my @content = <LOGFILE>;
 close LOGFILE;
 
 ok(grep(/debug \@.*$message/, @content), 'debug message found');
 ok(grep(/warn \@.*$message/, @content), 'warning message found');
 ok(grep(/error \@.*$message/, @content), 'error message found');
 
-unlink $logfile;
-
 set environment => 'test';
 logger 'file';
 
-$logfile = Dancer::FileUtils::d_catfile($logdir, "test.log");
-ok((-r $logfile), "environment logfile exists");
+my $test_logfile = Dancer::FileUtils::d_catfile($logdir, "test.log");
+ok((-r $test_logfile), "environment logfile exists");
 
-open LOGFILE, '<', $logfile;
+open LOGFILE, '<', $test_logfile;
 @content = <LOGFILE>;
 close LOGFILE;
 
@@ -53,5 +51,6 @@ ok(warning($message), 'warning message is logged');
 ok(error($message), 'error message is logged');
 
 Dancer::Logger::logger->{fh}->close;
-unlink $logfile;
+unlink $dev_logfile;
+unlink $test_logfile;
 File::Temp::cleanup();
diff --git a/t/01_config/04_config_file.t b/t/01_config/04_config_file.t
@@ -12,7 +12,7 @@ use File::Spec;
 use lib File::Spec->catdir( 't', 'lib' );
 use TestUtils;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 set appdir => $dir;
 my $envdir = File::Spec->catdir($dir, 'environments');
 mkdir $envdir;

diff --git a/t/01_config/06_config_api.t b/t/01_config/06_config_api.t
@@ -16,7 +16,7 @@ eval {
 
 like $@, qr/Unable to parse the configuration file/;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 
 my $config_file = File::Spec->catfile($dir, 'settings.yml');
 

diff --git a/t/02_request/14_uploads.t b/t/02_request/14_uploads.t
@@ -4,6 +4,7 @@ use warnings;
 use Dancer ':syntax';
 use Dancer::Request;
 use Dancer::FileUtils;
+use File::Temp qw(tempdir);
 use Test::More 'import' => ['!pass'];
 
 
@@ -91,23 +92,24 @@ do {
       "filename is accessible via params";
 
     # copy_to, link_to
-    my $dest_dir = File::Temp::tempdir( CLEANUP => 1 );
+    my $dest_dir = tempdir(CLEANUP => 1, TMPDIR => 1);
     my $dest_file = File::Spec->catfile( $dest_dir, $upload->basename );
     $upload->copy_to($dest_file);
     ok( ( -f $dest_file ), "file '$dest_file' has been copied" );
 
-    $upload->link_to( Dancer::FileUtils::path_no_verify( $dest_dir, "hardlink" ) );
-    ok( ( -f Dancer::FileUtils::path_no_verify( $dest_dir, "hardlink" ) ), "hardlink is created" );
+    my $dest_file_link = File::Spec->catfile( $dest_dir, "hardlink" );
+    $upload->link_to( $dest_file_link );
+    ok( ( -f $dest_file_link ), "hardlink '$dest_file_link' has been created" );
 
-  SKIP: {
-        skip "bogus upload tests on win32", 2 if ( $^O eq 'MSWin32' or $^O eq 'cygwin'  );
-
-        # make sure cleanup is performed when the HTTP::Body object is purged
-        my $file = $upload->tempname;
-        ok( ( -f $file ), 'temp file exists while HTTP::Body lives' );
-        undef $req->{_http_body};
+    # make sure cleanup is performed when the HTTP::Body object is purged
+    my $file = $upload->tempname;
+    ok( ( -f $file ), 'temp file exists while HTTP::Body lives' );
+    undef $req->{_http_body};
+    SKIP: {
+        skip "Win32 can't remove file/link while open, deadlock with HTTP::Body", 1 if ($^O eq 'MSWin32');
         ok( ( !-f $file ), 'temp file is removed when HTTP::Body object dies' );
     }
 
+    unlink($file) if ($^O eq 'MSWin32');
 };
 
diff --git a/t/03_route_handler/07_compilation_warning.t b/t/03_route_handler/07_compilation_warning.t
@@ -7,7 +7,7 @@ use Dancer ':syntax';
 use Dancer::Logger;
 use File::Temp qw/tempdir/;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 set appdir => $dir;
 Dancer::Logger->init('File');
 

diff --git a/t/03_route_handler/11_redirect.t b/t/03_route_handler/11_redirect.t
@@ -7,7 +7,7 @@ use Dancer::Logger;
 use File::Temp qw/tempdir/;
 use Dancer::Test;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 set appdir => $dir;
 Dancer::Logger->init('File');
 

diff --git a/t/03_route_handler/29_forward.t b/t/03_route_handler/29_forward.t
@@ -7,7 +7,7 @@ use Dancer::Logger;
 use File::Temp qw/tempdir/;
 use Dancer::Test;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 set appdir => $dir;
 Dancer::Logger->init('File');
 

diff --git a/t/08_session/03_http_requests.t b/t/08_session/03_http_requests.t
@@ -15,7 +15,7 @@ use LWP::UserAgent;
 
 use File::Spec;
 use File::Temp 'tempdir';
-my $tempdir = tempdir('Dancer.XXXXXX', DIR => File::Spec->curdir, CLEANUP => 1);
+my $tempdir = tempdir(CLEANUP => 1, TMPDIR => 1);
 
 use Dancer;
 use Dancer::Logger;

diff --git a/t/08_session/05_yaml.t b/t/08_session/05_yaml.t
@@ -19,7 +19,7 @@ BEGIN {
 }
 
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 set appdir => $dir;
 
 my $session = Dancer::Session::YAML->create();

diff --git a/t/09_cookies/03_persistence.t b/t/09_cookies/03_persistence.t
@@ -14,7 +14,7 @@ use Dancer;
 
 use File::Spec;
 use File::Temp 'tempdir';
-my $tempdir = tempdir('Dancer.XXXXXX', DIR => File::Spec->curdir, CLEANUP => 1);
+my $tempdir = tempdir(CLEANUP => 1, TMPDIR => 1);
 
 plan tests => 9;
 Test::TCP::test_tcp(

diff --git a/t/11_logger/02_factory.t b/t/11_logger/02_factory.t
@@ -7,7 +7,7 @@ use t::lib::TestUtils;
 use File::Temp qw/tempdir/;
 use Dancer ':syntax';
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 setting appdir => $dir;
 
 use_ok 'Dancer::Logger';

diff --git a/t/11_logger/03_file.t b/t/11_logger/03_file.t
@@ -7,7 +7,7 @@ use File::Temp qw/tempdir/;
 use t::lib::TestUtils;
 use Dancer;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 setting appdir => $dir;
 
 use_ok 'Dancer::Logger::File';
@@ -28,7 +28,7 @@ ok($l->warning("Perl Dancer test message 3/4"), "warning works");
 ok($l->error("Perl Dancer test message 4/4"), "error works");
 
 #Create a new tmp directory to test log_path option
-my $dir2 = tempdir(CLEANUP => 1);
+my $dir2 = tempdir(CLEANUP => 1, TMPDIR => 1);
 setting log_path => $dir2;
 
 is(Dancer::Logger::File->logdir, $dir2, 

diff --git a/t/15_plugins/02_config.t b/t/15_plugins/02_config.t
@@ -15,7 +15,7 @@ use TestUtils;
 
 use File::Temp qw/tempdir/;
 
-my $dir = tempdir(CLEANUP => 1);
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 set(appdir => $dir);
 set(confdir => $dir);
 mkdir File::Spec->catdir( $dir, 'environments' );

diff --git a/t/19_dancer/01_script.t b/t/19_dancer/01_script.t
@@ -24,7 +24,7 @@ sub slurp {
     <$fh>;
 }
 
-my $dir = tempdir( CLEANUP => 1 );
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 my $cwd = cwd;
 
 chdir $dir;

diff --git a/t/19_dancer/02_script_version_from.t b/t/19_dancer/02_script_version_from.t
@@ -12,7 +12,7 @@ my %cases = (
     'A::B' => [ 'A-B', 'lib/A/B.pm' ],
 );
 
-my $dir = tempdir( CLEANUP => 1 );
+my $dir = tempdir(CLEANUP => 1, TMPDIR => 1);
 my $cwd = cwd;
 
 chdir $dir;