1 package DevHelp::FileUpload;
6 our $VERSION = "1.001";
10 DevHelp::FileUpload - tools to maintain a file upload directory
14 use DevHelp::FileUpload;
18 DevHelp::FileUpload->make_img_filename($image_dir, $original_name, \$msg)
21 DevHelp::FileUpload->make_img_copy($image_dir, $oldname, \$msg)
28 =item DevHelp::FileUpload->make_img_copy($imgdir, $oldname, \$msg)
33 my ($class, $imgdir, $oldname, $rmsg) = @_;
35 # remove the time value and optional counter
36 (my $workname = $oldname) =~ s/^\d+_(?:\d+_)?//;
38 my ($newname, $fh) = $class->make_img_filename($imgdir, $workname, $rmsg)
41 unless (copy("$imgdir/$oldname", $fh)) {
42 $$rmsg = "Cannot copy to new file: $!";
44 unlink "$imgdir/$newname";
54 =item DevHelp::FileUpload->make_fh_copy($fh, $imgdir, $name, \$msg)
59 my ($class, $fh, $imgdir, $name, $rmsg) = @_;
61 my ($newname, $out_fh) = $class->make_img_filename($imgdir, $name, $rmsg)
64 # $fh might be a CGI.pm special that confuses File::Copy
68 while (my $block = <$fh>) {
71 unless (close $out_fh) {
72 $$rmsg = "Cannot write work file: $!";
73 unlink "$imgdir/$newname";
80 =item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
84 sub make_img_filename {
85 my ($class, $imgdir, $name, $rmsg) = @_;
88 $name =~ /([\w.-]+)$/ and $basename = $1;
90 if (length $basename > 60) {
91 $basename = substr($basename, -60);
94 my $filename = time . '_' . $basename;
98 $filename = time . '_' . $counter . '_' . $basename
99 until $fh = IO::File->new("$imgdir/$filename", O_CREAT | O_WRONLY | O_EXCL)
103 $$rmsg = "Could not open image file $imgdir/$filename: $!";
109 return ($filename, $fh);
116 Tony Cook <tony@develop-help.com>