3e9e7d4591dbc22a20b6dd4274fdf8b8049dbc67
[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 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;