blib/lib/PowerTools/Upload/Blob.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 13 | 15 | 86.6 |
branch | n/a | ||
condition | n/a | ||
subroutine | 5 | 5 | 100.0 |
pod | n/a | ||
total | 18 | 20 | 90.0 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package PowerTools::Upload::Blob; | ||||||
2 | |||||||
3 | 1 | 1 | 37136 | use 5.000005; | |||
1 | 4 | ||||||
1 | 44 | ||||||
4 | 1 | 1 | 6 | use strict; | |||
1 | 2 | ||||||
1 | 32 | ||||||
5 | 1 | 1 | 5 | use warnings; | |||
1 | 6 | ||||||
1 | 35 | ||||||
6 | 1 | 1 | 12253 | use DBI; | |||
1 | 24812 | ||||||
1 | 77 | ||||||
7 | 1 | 1 | 500 | use File::Scan::ClamAV; | |||
0 | |||||||
0 | |||||||
8 | |||||||
9 | require Exporter; | ||||||
10 | |||||||
11 | our @ISA = qw(Exporter DBI); | ||||||
12 | |||||||
13 | # Items to export into callers namespace by default. Note: do not export | ||||||
14 | # names by default without a very good reason. Use EXPORT_OK instead. | ||||||
15 | # Do not simply export all your public functions/methods/constants. | ||||||
16 | |||||||
17 | # This allows declaration use PowerTools::Upload::Blob ':all'; | ||||||
18 | # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK | ||||||
19 | # will save memory. | ||||||
20 | our %EXPORT_TAGS = ( 'all' => [ qw(upload | ||||||
21 | |||||||
22 | ) ] ); | ||||||
23 | |||||||
24 | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | ||||||
25 | |||||||
26 | our @EXPORT = qw( | ||||||
27 | upload | ||||||
28 | ); | ||||||
29 | |||||||
30 | our $VERSION = '0.03'; | ||||||
31 | |||||||
32 | # Below is stub documentation for your module. You'd better edit it! | ||||||
33 | |||||||
34 | =head1 NAME | ||||||
35 | |||||||
36 | PowerTools::Upload::Blob - Additional Perl tool for Apache::ASP data uploading | ||||||
37 | |||||||
38 | =head1 SYNOPSIS | ||||||
39 | |||||||
40 | default table | ||||||
41 | |||||||
42 | CREATE TABLE `files`.`file` ( | ||||||
43 | `file_id` int(10) unsigned NOT NULL auto_increment, | ||||||
44 | `file_name` varchar(255) NOT NULL, | ||||||
45 | `file_type` varchar(255) NOT NULL, | ||||||
46 | `file_blob` longblob NOT NULL, | ||||||
47 | `file_size` int(10) unsigned NOT NULL, | ||||||
48 | PRIMARY KEY (`file_id`) | ||||||
49 | ) ENGINE=InnoDB DEFAULT CHARSET=latin1; | ||||||
50 | |||||||
51 | .asp file | ||||||
52 | |||||||
53 | use PowerTools::Upload::Blob; | ||||||
54 | |||||||
55 | my $up = PowerTools::Upload::File->new( # Create new object | ||||||
56 | path => 'E:/instale/test', # Path to directory where files will be stored (default: '/tmp') | ||||||
57 | field => 'plik', # Form field name (, default: 'file') | ||||||
58 | limit => $Server->Config("FileUploadMax"), # File size limit (default 100000000) | ||||||
59 | request => $Request, # Request object | ||||||
60 | clamav => 1, # Scan with ClamAV when uploading (0 -> no / 1 -> yes, default: 0) | ||||||
61 | overwrite => 0 # Overwrite file (0 -> no / 1 -> yes, default: 1) | ||||||
62 | ); | ||||||
63 | |||||||
64 | my $ret = $up->upload(); # Upload file | ||||||
65 | print $ret->{'filename'}." "; # Returns filename |
||||||
66 | print $ret->{'filesize'}." "; # Returns filesize |
||||||
67 | print $ret->{'filepath'}." "; # Returns filepath |
||||||
68 | print $ret->{'filescan'}." "; # Returns filescan |
||||||
69 | print $ret->{'filemime'}." "; # Returns filemime |
||||||
70 | print $ret->{'copytime'}." "; # Returns copytime |
||||||
71 | print $ret->{'status'}; # Returns upload status | ||||||
72 | |||||||
73 | |||||||
74 | =head1 AUTHOR | ||||||
75 | |||||||
76 | Piotr Ginalski, E |
||||||
77 | |||||||
78 | =head1 COPYRIGHT AND LICENSE | ||||||
79 | |||||||
80 | Copyright (C) 2007 by Piotr Ginalski | ||||||
81 | |||||||
82 | This library is free software; you can redistribute it and/or modify | ||||||
83 | it under the same terms as Perl itself, either Perl version 5.8.8 or, | ||||||
84 | at your option, any later version of Perl 5 you may have available. | ||||||
85 | |||||||
86 | |||||||
87 | =cut | ||||||
88 | |||||||
89 | sub new { | ||||||
90 | my $class = shift; | ||||||
91 | my (%options) = @_; | ||||||
92 | return bless \%options, $class; | ||||||
93 | } | ||||||
94 | |||||||
95 | sub upload { | ||||||
96 | my $self = shift; | ||||||
97 | |||||||
98 | my $field = $self->{field} || "file"; | ||||||
99 | my $limit = $self->{limit} || 100000000; | ||||||
100 | my $r = $self->{request}; | ||||||
101 | |||||||
102 | my $db_user = $self->{db_user} || "root"; | ||||||
103 | my $db_pass = $self->{db_pass} || ""; | ||||||
104 | my $db_name = $self->{db_name} || "files"; | ||||||
105 | |||||||
106 | my $db_host = $self->{db_host} || "localhost"; | ||||||
107 | my $db_port = $self->{db_port} || 3306; | ||||||
108 | my $db_type = $self->{db_type} || "mysql"; | ||||||
109 | |||||||
110 | my $dsn = "DBI:$db_type:database=$db_name;host=$db_host"; | ||||||
111 | |||||||
112 | my $dbh = DBI->connect($dsn, $db_user, $db_pass, { RaiseError => 1, AutoCommit => 1 }) || carp $DBI::errstr; | ||||||
113 | |||||||
114 | my $tname = $self->{table_file} || 'files'; | ||||||
115 | |||||||
116 | my $fid = $self->{field_file_id} || 'file_id'; | ||||||
117 | |||||||
118 | my $fname = $self->{field_file_name} || 'file_name'; | ||||||
119 | my $ftype = $self->{field_file_type} || 'file_type'; | ||||||
120 | my $fblob = $self->{field_file_blob} || 'file_blob'; | ||||||
121 | my $fsize = $self->{field_file_size} || 'file_size'; | ||||||
122 | |||||||
123 | $self->{'filename'} = ''; | ||||||
124 | $self->{'filesize'} = ''; | ||||||
125 | $self->{'filescan'} = ''; | ||||||
126 | $self->{'filemime'} = ''; | ||||||
127 | $self->{'copytime'} = ''; | ||||||
128 | $self->{'insertid'} = ''; | ||||||
129 | $self->{'status'} = ''; | ||||||
130 | |||||||
131 | if($r) { | ||||||
132 | |||||||
133 | my $ct = $r->FileUpload( $field, 'ContentType'); | ||||||
134 | my $bf = $r->FileUpload( $field, 'BrowserFile'); | ||||||
135 | my $fh = $r->FileUpload( $field, 'FileHandle'); | ||||||
136 | my $mh = $r->FileUpload( $field, 'Mime-Header'); | ||||||
137 | my $tf = $r->FileUpload( $field, 'TempFile'); | ||||||
138 | |||||||
139 | $self->{'filemime'} = $ct; | ||||||
140 | |||||||
141 | my $file = $bf; | ||||||
142 | $file =~ s/.*[\/\\](.*)/$1/; | ||||||
143 | |||||||
144 | $self->{'filename'} = $file; | ||||||
145 | |||||||
146 | my $code = "OK"; | ||||||
147 | my ($virus,$var); | ||||||
148 | binmode $fh; | ||||||
149 | read($fh, $var, -s $fh); | ||||||
150 | |||||||
151 | my $size = -s $fh; | ||||||
152 | $self->{'filesize'} = $size; | ||||||
153 | |||||||
154 | if($self->{clamav} == 1) { | ||||||
155 | my $av = new File::Scan::ClamAV(port => 3310); | ||||||
156 | if($av->ping){ | ||||||
157 | my ($code,$virus) = $av->streamscan($var); | ||||||
158 | $self->{'filescan'} = $code; | ||||||
159 | } | ||||||
160 | } | ||||||
161 | |||||||
162 | if( ($code eq 'OK') && ($size <= $limit) ) { | ||||||
163 | |||||||
164 | my $start_time = time(); | ||||||
165 | my $sql = "INSERT INTO $tname ($fname,$ftype,$fblob,$fsize) VALUES (?,?,?,?)"; | ||||||
166 | my $sth = $dbh->prepare($sql); | ||||||
167 | $sth->execute($file,$ct,$var,$size); | ||||||
168 | $sth->finish(); | ||||||
169 | $self->{'insertid'} = $dbh->{'mysql_insertid'}; | ||||||
170 | my $time_took = time() - $start_time; | ||||||
171 | $self->{'copytime'} = $time_took; | ||||||
172 | $self->{'status'} = 'OK'; | ||||||
173 | |||||||
174 | } else { | ||||||
175 | $self->{'status'} = 'File containing virus or size overlimit'; | ||||||
176 | carp $self->{'status'}; | ||||||
177 | } | ||||||
178 | |||||||
179 | $dbh->disconnect; | ||||||
180 | |||||||
181 | } else { | ||||||
182 | $self->{'status'} = 'No request object found'; | ||||||
183 | carp $self->{'status'}; | ||||||
184 | } | ||||||
185 | |||||||
186 | return $self; | ||||||
187 | |||||||
188 | } | ||||||
189 | |||||||
190 | 1; | ||||||
191 | __END__ |