allow more than a trailing alphanumeric part of an image filename to live
[bse.git] / site / cgi-bin / modules / DevHelp / FileUpload.pm
index fec5975..f9ae7c1 100644 (file)
@@ -3,9 +3,11 @@ use strict;
 use IO::File;
 use File::Copy;
 
+our $VERSION = "1.002";
+
 =head1 NAME
 
-  DevHelp::FileUpload - tools to maintain a file upload directory
+DevHelp::FileUpload - tools to maintain a file upload directory
 
 =head1 SYNOPSIS
 
@@ -49,6 +51,32 @@ sub make_img_copy {
   return $newname;
 }
 
+=item DevHelp::FileUpload->make_fh_copy($fh, $imgdir, $name, \$msg)
+
+=cut
+
+sub make_fh_copy {
+  my ($class, $fh, $imgdir, $name, $rmsg) = @_;
+
+  my ($newname, $out_fh) = $class->make_img_filename($imgdir, $name, $rmsg)
+    or return;
+
+  # $fh might be a CGI.pm special that confuses File::Copy
+  local $/ = \8192;
+  binmode $fh;
+  binmode $out_fh;
+  while (my $block = <$fh>) {
+    print $out_fh $block;
+  }
+  unless (close $out_fh) {
+    $$rmsg = "Cannot write work file: $!";
+    unlink "$imgdir/$newname";
+    return;
+  }
+
+  return $newname;
+}
+
 =item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
 
 =cut
@@ -56,8 +84,7 @@ sub make_img_copy {
 sub make_img_filename {
   my ($class, $imgdir, $name, $rmsg) = @_;
 
-  my $basename = '';
-  $name =~ /([\w.-]+)$/ and $basename = $1;
+  (my $basename = $name) =~ tr/A-Za-z0-9_./-/cs;
 
   if (length $basename > 60) {
     $basename = substr($basename, -60);