site/cgi-bin/modules/DevHelp/FileUpload.pm

   1 package DevHelp::FileUpload;
   2 use strict;
   3 use IO::File;
   4 use File::Copy;
   5
   6 our $VERSION = "1.001";
   7
   8 =head1 NAME
   9
  10   DevHelp::FileUpload - tools to maintain a file upload directory
  11
  12 =head1 SYNOPSIS
  13
  14   use DevHelp::FileUpload;
  15
  16   my $msg;
  17   my ($name, $handle) =
  18     DevHelp::FileUpload->make_img_filename($image_dir, $original_name, \$msg)
  19       or die $msg;
  20   my $newname =
  21     DevHelp::FileUpload->make_img_copy($image_dir, $oldname, \$msg)
  22       or die $msg;
  23
  24 =head1 DESCRIPTION
  25
  26 =over
  27
  28 =item DevHelp::FileUpload->make_img_copy($imgdir, $oldname, \$msg)
  29
  30 =cut
  31
  32 sub make_img_copy {
  33   my ($class, $imgdir, $oldname, $rmsg) = @_;
  34
  35   # remove the time value and optional counter
  36   (my $workname = $oldname) =~ s/^\d+_(?:\d+_)?//;
  37
  38   my ($newname, $fh) = $class->make_img_filename($imgdir, $workname, $rmsg)
  39     or return;
  40
  41   unless (copy("$imgdir/$oldname", $fh)) {
  42     $$rmsg = "Cannot copy to new file: $!";
  43     close $fh; undef $fh;
  44     unlink "$imgdir/$newname";
  45     return;
  46   }
  47
  48   close $fh;
  49   undef $fh;
  50
  51   return $newname;
  52 }
  53
  54 =item DevHelp::FileUpload->make_fh_copy($fh, $imgdir, $name, \$msg)
  55
  56 =cut
  57
  58 sub make_fh_copy {
  59   my ($class, $fh, $imgdir, $name, $rmsg) = @_;
  60
  61   my ($newname, $out_fh) = $class->make_img_filename($imgdir, $name, $rmsg)
  62     or return;
  63
  64   # $fh might be a CGI.pm special that confuses File::Copy
  65   local $/ = \8192;
  66   binmode $fh;
  67   binmode $out_fh;
  68   while (my $block = <$fh>) {
  69     print $out_fh $block;
  70   }
  71   unless (close $out_fh) {
  72     $$rmsg = "Cannot write work file: $!";
  73     unlink "$imgdir/$newname";
  74     return;
  75   }
  76
  77   return $newname;
  78 }
  79
  80 =item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
  81
  82 =cut
  83
  84 sub make_img_filename {
  85   my ($class, $imgdir, $name, $rmsg) = @_;
  86
  87   my $basename = '';
  88   $name =~ /([\w.-]+)$/ and $basename = $1;
  89
  90   if (length $basename > 60) {
  91     $basename = substr($basename, -60);
  92   }
  93
  94   my $filename = time . '_' . $basename;
  95
  96   my $fh;
  97   my $counter = "";
  98   $filename = time . '_' . $counter . '_' . $basename
  99     until $fh = IO::File->new("$imgdir/$filename", O_CREAT | O_WRONLY | O_EXCL)
 100       or ++$counter > 100;
 101
 102   unless ($fh) {
 103     $$rmsg = "Could not open image file $imgdir/$filename: $!";
 104     return;
 105   }
 106
 107   binmode $fh;
 108
 109   return ($filename, $fh);
 110 }
 111
 112 =back
 113
 114 =head1 AUTHOR
 115
 116 Tony Cook <tony@develop-help.com>
 117
 118 =cut
 119
 120 1;