0.14_27 commit
[bse.git] / site / cgi-bin / modules / DevHelp / FileUpload.pm
1 package DevHelp::FileUpload;
2 use strict;
3 use IO::File;
4 use File::Copy;
5
6 =head1 NAME
7
8   DevHelp::FileUpload - tools to maintain a file upload directory
9
10 =head1 SYNOPSIS
11
12   use DevHelp::FileUpload;
13
14   my $msg;
15   my ($name, $handle) = 
16     DevHelp::FileUpload->make_img_filename($image_dir, $original_name, \$msg)
17       or die $msg;
18   my $newname = 
19     DevHelp::FileUpload->make_img_copy($image_dir, $oldname, \$msg)
20       or die $msg;
21
22 =head1 DESCRIPTION
23
24 =over
25
26 =item DevHelp::FileUpload->make_img_copy($imgdir, $oldname, \$msg)
27
28 =cut
29
30 sub make_img_copy {
31   my ($class, $imgdir, $oldname, $rmsg) = @_;
32
33   # remove the time value and optional counter
34   (my $workname = $oldname) =~ s/^\d+_(?:\d+_)?//;
35
36   my ($newname, $fh) = $class->make_img_filename($imgdir, $workname, $rmsg)
37     or return;
38
39   unless (copy("$imgdir/$oldname", $fh)) {
40     $$rmsg = "Cannot copy to new file: $!";
41     close $fh; undef $fh;
42     unlink "$imgdir/$newname";
43     return;
44   }
45     
46   close $fh;
47   undef $fh;
48
49   return $newname;
50 }
51
52 =item DevHelp::FileUpload->make_img_filename($imgdir, $name, \$msg)
53
54 =cut
55
56 sub make_img_filename {
57   my ($class, $imgdir, $name, $rmsg) = @_;
58
59   my $basename = '';
60   $name =~ /([\w.-]+)$/ and $basename = $1;
61
62   my $filename = time . '_' . $basename;
63
64   my $fh;
65   my $counter = "";
66   $filename = time . '_' . $counter . '_' . $basename
67     until $fh = IO::File->new("$imgdir/$filename", O_CREAT | O_WRONLY | O_EXCL)
68       or ++$counter > 100;
69
70   unless ($fh) {
71     $$rmsg = "Could not open image file $imgdir/$filename: $!";
72     return;
73   }
74
75   binmode $fh;
76
77   return ($filename, $fh);
78 }
79
80 =back
81
82 =head1 AUTHOR
83
84 Tony Cook <tony@develop-help.com>
85
86 =cut
87
88 1;