File Coverage

blib/lib/jQuery/File/Upload.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package jQuery::File::Upload;
2              
3 1     1   16166 use 5.008008;
  1         2  
  1         62  
4 1     1   8 use strict;
  1         2  
  1         38  
5             #use warnings;
6              
7 1     1   16142 use CGI;
  1         15724  
  1         6  
8 1     1   845 use JSON::XS;
  1         5057  
  1         65  
9 1     1   739 use JSON;
  1         5025  
  1         4  
10 1     1   346 use Net::SSH2;
  0            
  0            
11             use Net::SSH2::SFTP;
12             use Image::Magick;
13             use Cwd 'abs_path';
14             use URI;
15             use Data::GUID;
16              
17             #use LWP::UserAgent;
18             #use LWP::Protocol::https;
19              
20             our $VERSION = '0.30';
21              
22             my %errors = (
23             '_validate_max_file_size' => 'File is too big',
24             '_validate_min_file_size' => 'File is too small',
25             '_validate_accept_file_types' => 'Filetype not allowed',
26             '_validate_reject_file_types' => 'Filetype not allowed',
27             '_validate_max_number_of_files' => 'Maximum number of files exceeded',
28             '_validate_max_width' => 'Image exceeds maximum width',
29             '_validate_min_width' => 'Image requires a minimum width',
30             '_validate_max_height' => 'Image exceeds maximum height',
31             '_validate_min_height' => 'Image requires a minimum height'
32             );
33              
34             #GETTERS/SETTERS
35             sub new {
36             my $invocant = shift;
37             my $class = ref($invocant) || $invocant;
38             my $self = {
39             field_name => 'files[]',
40             ctx => undef,
41             cgi => undef,
42             thumbnail_width => 80,
43             thumbnail_height => 80,
44             thumbnail_quality => 70,
45             thumbnail_format => 'jpg',
46             thumbnail_density => undef,
47             format => 'jpg',
48             quality => 70,
49              
50             process_images => 1,
51             thumbnail_filename => undef,
52             thumbnail_prefix => 'thumb_',
53             thumbnail_postfix => '',
54             filename => undef,
55             client_filename => undef,
56             show_client_filename => 1,
57             use_client_filename => undef,
58             filename_salt => '',
59             copy_file => 0,
60             script_url => undef,
61             tmp_dir => '/tmp',
62             should_delete => 1,
63              
64             absolute_filename => undef,
65             absolute_thumbnail_filename => undef,
66              
67             delete_params => [],
68              
69             upload_dir => undef,
70             thumbnail_upload_dir => undef,
71             upload_url_base => undef,
72             thumbnail_url_base => undef,
73             relative_url_path => '/files',
74             thumbnail_relative_url_path => undef,
75             relative_to_host => undef,
76             delete_url => undef,
77              
78             data => {},
79              
80             #callbacks
81             post_delete => sub {},
82             post_post => sub {},
83             post_get => sub {},
84              
85             #pre calls
86             pre_delete => sub {},
87             pre_post => sub {},
88             pre_get => sub {},
89              
90             #scp/rcp login info
91             scp => [],
92              
93             #user validation specifications
94             max_file_size => undef,
95             min_file_size => 1,
96             accept_file_types => [],
97             reject_file_types => [],
98             require_image => undef,
99             max_width => undef,
100             max_height => undef,
101             min_width => 1,
102             min_height => 1,
103             max_number_of_files => undef,
104              
105             #not to be used by users
106             output => undef,
107             handle => undef,
108             tmp_filename => undef,
109             fh => undef,
110             error => undef,
111             upload => undef,
112             file_type => undef,
113             is_image => undef,
114             image_magick => undef,
115             width => undef,
116             height => undef,
117             num_files_in_dir => undef,
118             user_error => undef,
119             @_, # Override previous attributes
120             };
121             return bless $self, $class;
122             }
123              
124             sub upload_dir {
125             my $self = shift;
126              
127             if (@_) {
128             $self->{upload_dir} = shift;
129             }
130              
131             #set upload_dir to directory of this script if not provided
132             if(!(defined $self->{upload_dir})) {
133             $self->{upload_dir} = abs_path($0);
134             $self->{upload_dir} =~ s/(.*)\/.*/$1/;
135             $self->{upload_dir} .= '/files';
136             }
137              
138             return $self->{upload_dir};
139             }
140              
141             sub thumbnail_upload_dir {
142             my $self = shift;
143              
144             if (@_) {
145             $self->{thumbnail_upload_dir} = shift;
146             }
147              
148             #set upload_dir to directory of this script if not provided
149             if(!(defined $self->{thumbnail_upload_dir})) {
150             $self->{thumbnail_upload_dir} = $self->upload_dir;
151             }
152              
153             return $self->{thumbnail_upload_dir};
154             }
155              
156             sub upload_url_base {
157             my $self = shift;
158              
159             if (@_) {
160             $self->{upload_url_base} = shift;
161             }
162              
163             if(!(defined $self->{upload_url_base})) {
164             $self->{upload_url_base} = $self->_url_base . $self->relative_url_path;
165             }
166              
167             return $self->{upload_url_base};
168             }
169              
170             sub _url_base {
171             my $self = shift;
172             my $url;
173              
174             if($self->relative_to_host) {
175             $url = $self->{uri}->scheme . '://' . $self->{uri}->host;
176             }
177             else {
178             $url = $self->script_url;
179             $url =~ s/(.*)\/.*/$1/;
180             }
181              
182             return $url;
183             }
184              
185             sub thumbnail_url_base {
186             my $self = shift;
187              
188             if (@_) {
189             $self->{thumbnail_url_base} = shift;
190             }
191              
192             if(!(defined $self->{thumbnail_url_base})) {
193             if(defined $self->thumbnail_relative_url_path) {
194             $self->{thumbnail_url_base} = $self->_url_base . $self->thumbnail_relative_url_path;
195             }
196             else {
197             $self->{thumbnail_url_base} = $self->upload_url_base;
198             }
199             }
200              
201             return $self->{thumbnail_url_base};
202             }
203              
204              
205             sub relative_url_path {
206             my $self = shift;
207              
208             if(@_) {
209             $self->{relative_url_path} = shift;
210             }
211              
212             return $self->{relative_url_path};
213             }
214              
215             sub thumbnail_relative_url_path {
216             my $self = shift;
217              
218             if(@_) {
219             $self->{thumbnail_relative_url_path} = shift;
220             }
221              
222             return $self->{thumbnail_relative_url_path};
223             }
224              
225             sub relative_to_host {
226             my $self = shift;
227              
228             if(@_) {
229             $self->{relative_to_host} = shift;
230             }
231              
232             return $self->{relative_to_host};
233             }
234              
235              
236              
237             sub field_name {
238             my $self = shift;
239              
240             if (@_) {
241             $self->{field_name} = shift;
242             }
243              
244             return $self->{field_name};
245             }
246              
247             sub ctx {
248             my $self = shift;
249              
250             if (@_) {
251             $self->{ctx} = shift;
252             }
253              
254             return $self->{ctx};
255             }
256              
257             sub cgi {
258             my $self = shift;
259              
260             if (@_) {
261             $self->{cgi} = shift;
262             }
263             $self->{cgi} = CGI->new unless defined $self->{cgi};
264              
265             return $self->{cgi};
266             }
267              
268             sub should_delete {
269             my $self = shift;
270              
271             if (@_) {
272             $self->{should_delete} = shift;
273             }
274              
275             return $self->{should_delete};
276             }
277              
278             sub scp {
279             my $self = shift;
280              
281             if (@_) {
282             $self->{scp} = shift;
283             }
284              
285             return $self->{scp};
286             }
287              
288             sub max_file_size {
289             my $self = shift;
290              
291             if (@_) {
292             $self->{max_file_size} = shift;
293             }
294              
295             return $self->{max_file_size};
296             }
297              
298             sub min_file_size {
299             my $self = shift;
300              
301             if (@_) {
302             $self->{min_file_size} = shift;
303             }
304              
305             return $self->{min_file_size};
306             }
307              
308             sub accept_file_types {
309             my $self = shift;
310              
311             if (@_) {
312             my $a_ref = shift;
313             die "accept_file_types must be an array ref" unless UNIVERSAL::isa($a_ref,'ARRAY');
314             $self->{accept_file_types} = $a_ref;
315             }
316              
317             if(scalar(@{$self->{accept_file_types}}) == 0 and $self->require_image) {
318             $self->{accept_file_types} = ['image/jpeg','image/jpg','image/png','image/gif'];
319             }
320              
321             return $self->{accept_file_types};
322             }
323              
324             sub reject_file_types {
325             my $self = shift;
326              
327             if (@_) {
328             my $a_ref = shift;
329             die "reject_file_types must be an array ref" unless UNIVERSAL::isa($a_ref,'ARRAY');
330             $self->{reject_file_types} = $a_ref;
331             }
332              
333             return $self->{reject_file_types};
334             }
335              
336             sub require_image {
337             my $self = shift;
338              
339             if (@_) {
340             $self->{require_image} = shift;
341             }
342              
343             return $self->{require_image};
344             }
345              
346             sub delete_params {
347             my $self = shift;
348              
349             if (@_) {
350             my $a_ref = shift;
351             die "delete_params must be an array ref" unless UNIVERSAL::isa($a_ref,'ARRAY');
352             $self->{delete_params} = $a_ref;
353             }
354              
355             return $self->{delete_params};
356             }
357              
358             sub delete_url {
359             my $self = shift;
360              
361             if(@_) {
362             $self->{delete_url} = shift;
363             }
364              
365             return $self->{delete_url};
366             }
367              
368             sub thumbnail_width {
369             my $self = shift;
370              
371             if (@_) {
372             $self->{thumbnail_width} = shift;
373             }
374              
375             return $self->{thumbnail_width};
376             }
377              
378             sub thumbnail_height {
379             my $self = shift;
380              
381             if (@_) {
382             $self->{thumbnail_height} = shift;
383             }
384              
385             return $self->{thumbnail_height};
386             }
387              
388             sub thumbnail_quality {
389             my $self = shift;
390              
391             if (@_) {
392             $self->{thumbnail_quality} = shift;
393             }
394              
395             return $self->{thumbnail_quality};
396             }
397              
398             sub thumbnail_format {
399             my $self = shift;
400              
401             if (@_) {
402             $self->{thumbnail_format} = shift;
403             }
404              
405             return $self->{thumbnail_format};
406             }
407              
408             sub thumbnail_density {
409             my $self = shift;
410              
411             if (@_) {
412             $self->{thumbnail_density} = shift;
413             }
414              
415             return $self->{thumbnail_density};
416             }
417              
418             sub thumbnail_prefix {
419             my $self = shift;
420              
421             if (@_) {
422             $self->{thumbnail_prefix} = shift;
423             }
424              
425             return $self->{thumbnail_prefix};
426             }
427              
428             sub thumbnail_postfix {
429             my $self = shift;
430              
431             if (@_) {
432             $self->{thumbnail_postfix} = shift;
433             }
434              
435             return $self->{thumbnail_postfix};
436             }
437              
438             sub thumbnail_final_width {
439             my $self = shift;
440              
441             if(@_) {
442             $self->{thumbnail_final_width} = shift;
443             }
444              
445             return $self->{thumbnail_final_width};
446             }
447              
448             sub thumbnail_final_height {
449             my $self = shift;
450              
451             if(@_) {
452             $self->{thumbnail_final_height} = shift;
453             }
454              
455             return $self->{thumbnail_final_height};
456             }
457              
458             sub quality {
459             my $self = shift;
460              
461             if (@_) {
462             $self->{quality} = shift;
463             }
464              
465             return $self->{quality};
466             }
467              
468             sub format {
469             my $self = shift;
470              
471             if (@_) {
472             $self->{format} = shift;
473             }
474              
475             return $self->{format};
476             }
477              
478             sub final_width {
479             my $self = shift;
480              
481             if(@_) {
482             $self->{final_width} = shift;
483             }
484              
485             return $self->{final_width};
486             }
487              
488             sub final_height {
489             my $self = shift;
490              
491             if(@_) {
492             $self->{final_height} = shift;
493             }
494              
495             return $self->{final_height};
496             }
497              
498             sub max_width {
499             my $self = shift;
500              
501             if (@_) {
502             $self->{max_width} = shift;
503             }
504              
505             return $self->{max_width};
506             }
507              
508             sub max_height {
509             my $self = shift;
510              
511             if (@_) {
512             $self->{max_height} = shift;
513             }
514              
515             return $self->{max_height};
516             }
517              
518             sub min_width {
519             my $self = shift;
520              
521             if (@_) {
522             $self->{min_width} = shift;
523             }
524              
525             return $self->{min_width};
526             }
527              
528             sub min_height {
529             my $self = shift;
530              
531             if (@_) {
532             $self->{min_height} = shift;
533             }
534              
535             return $self->{min_height};
536             }
537              
538             sub max_number_of_files {
539             my $self = shift;
540              
541             if (@_) {
542             $self->{max_number_of_files} = shift;
543             }
544              
545             return $self->{max_number_of_files};
546             }
547              
548             sub filename {
549             my $self = shift;
550              
551             if (@_) {
552             $self->{filename} = shift;
553             }
554              
555             return $self->{filename};
556             }
557              
558             sub absolute_filename {
559             my $self = shift;
560              
561             if (@_) {
562             $self->{absolute_filename} = shift;
563             }
564              
565             return $self->{absolute_filename};
566             }
567              
568             sub thumbnail_filename {
569             my $self = shift;
570              
571             if (@_) {
572             $self->{thumbnail_filename} = shift;
573             }
574              
575             return $self->{thumbnail_filename};
576             }
577              
578             sub absolute_thumbnail_filename {
579             my $self = shift;
580              
581             if (@_) {
582             $self->{absolute_thumbnail_filename} = shift;
583             }
584              
585             return $self->{absolute_thumbnail_filename};
586             }
587              
588             sub client_filename {
589             my $self = shift;
590              
591             if (@_) {
592             $self->{client_filename} = shift;
593             }
594              
595             return $self->{client_filename};
596             }
597              
598             sub show_client_filename {
599             my $self = shift;
600              
601             if (@_) {
602             $self->{show_client_filename} = shift;
603             }
604              
605             return $self->{show_client_filename};
606             }
607              
608             sub use_client_filename {
609             my $self = shift;
610              
611             if (@_) {
612             $self->{use_client_filename} = shift;
613             }
614              
615             return $self->{use_client_filename};
616             }
617              
618             sub filename_salt {
619             my $self = shift;
620              
621             if (@_) {
622             $self->{filename_salt} = shift;
623             }
624              
625             return $self->{filename_salt};
626             }
627              
628             sub tmp_dir {
629             my $self = shift;
630              
631             if (@_) {
632             $self->{tmp_dir} = shift;
633             }
634              
635             return $self->{tmp_dir};
636             }
637              
638             sub script_url {
639             my $self = shift;
640              
641             if (@_) {
642             $self->{script_url} = shift;
643             }
644              
645             if(!(defined $self->{script_url})) {
646             if(defined $self->ctx) {
647             $self->{script_url} = $self->ctx->request->uri;
648             }
649             else {
650             $self->{script_url} = $ENV{SCRIPT_URI};
651             }
652             }
653              
654             return $self->{script_url};
655             }
656              
657             sub data {
658             my $self = shift;
659              
660             if(@_) {
661             $self->{data} = shift;
662             }
663              
664             return $self->{data};
665             }
666              
667             sub process_images {
668             my $self = shift;
669              
670             if (@_) {
671             $self->{process_images} = shift;
672             }
673              
674             return $self->{process_images};
675             }
676              
677             sub copy_file {
678             my $self = shift;
679              
680             if (@_) {
681             $self->{copy_file} = shift;
682             }
683              
684             return $self->{copy_file};
685             }
686              
687             #GETTERS
688             sub output { shift->{output} }
689             sub url { shift->{url} }
690             sub thumbnail_url { shift->{thumbnail_url} }
691             sub is_image { shift->{is_image} }
692             sub size { shift->{file_size} }
693              
694             #OTHER METHODS
695             sub print_response {
696             my $self = shift;
697              
698             my $content_type = 'text/plain';
699             if(defined $self->ctx) {
700              
701             #thanks to Lukas Rampa for this suggestion
702             if ($self->ctx->req->headers->header('Accept') =~ qr(application/json) ) {
703             $content_type = 'application/json';
704             }
705              
706             $self->ctx->stash->{current_view} = '';
707             $self->ctx->res->content_type("$content_type; charset=utf-8");
708             $self->ctx->res->body($self->output . ""); #concatenate "" for when there is no output
709             }
710             else {
711             print "Content-type: $content_type\n\n";
712             print $self->output;
713             }
714             }
715              
716             sub handle_request {
717             my $self = shift;
718             my ($print) = @_;
719              
720             my $method = $self->_get_request_method;
721              
722             if($method eq 'GET') {
723             &{$self->pre_get}($self);
724             &{$self->post_get}($self);
725             }
726             elsif($method eq 'PATCH' or $method eq 'POST' or $method eq 'PUT') {
727             $self->{user_error} = &{$self->pre_post}($self);
728             unless($self->{user_error}) {
729             $self->_post;
730             &{$self->post_post}($self);
731             }
732             else { $self->_generate_output }
733             }
734             elsif($method eq 'DELETE') {
735             $self->{user_error} = &{$self->pre_delete}($self); #even though we may not delete, we should give user option to still run code
736             if(not $self->{user_error} and $self->should_delete) {
737             $self->_delete;
738             &{$self->post_delete}($self);
739             }
740             else { $self->_generate_output }
741             }
742             else {
743             $self->_set_status(405);
744             }
745              
746             $self->print_response if $print;
747             $self->_clear;
748             }
749              
750             sub generate_output {
751             my $self = shift;
752             my ($arr_ref) = @_;
753              
754             #necessary if we are going to use _url_base via thumbnail_url_base and upload_url_base
755             $self->_set_uri;
756              
757             my @arr;
758             for(@$arr_ref) {
759             my %h;
760             die "Must provide a filename in generate_output" unless exists $_->{filename};
761             die "Must provide a size in generate_output" unless exists $_->{size};
762             $self->{is_image} = $self->process_images && $_->{image} eq 'y' ? 1 : 0;
763             $h{size} = $_->{size};
764             $h{error} = $_->{error};
765              
766             if(exists $_->{'name'}) {
767             $h{name} = $_->{name}
768             }
769             else {
770             $h{name} = $_->{filename};
771             }
772              
773             if($_->{filename}) {
774             $self->filename($_->{filename});
775             }
776              
777             if(exists $_->{thumbnail_filename}) {
778             $self->thumbnail_filename($_->{thumbnail_filename});
779             }
780             else {
781             my $no_ext = $self->_no_ext;
782             $self->thumbnail_filename($self->thumbnail_prefix . $no_ext . $self->thumbnail_postfix . '.' . $self->thumbnail_format);
783             }
784              
785             $self->_set_urls;
786             $h{url} = $_->{url} eq '' ? $self->url : $_->{url};
787             $h{thumbnailUrl} = $_->{thumbnailUrl} eq '' ? $self->thumbnail_url : $_->{thumbnailUrl};
788              
789             $h{deleteUrl} = $_->{'deleteUrl'} eq '' ? $self->_delete_url($_->{delete_params}) : $_->{'deleteUrl'};
790             $h{deleteType} = 'DELETE';
791             push @arr, \%h;
792              
793             #reset for the next time around
794             $self->delete_url('');
795             }
796              
797             #they should provide image=y or image=n if image
798             my $json = JSON::XS->new->ascii->pretty->allow_nonref;
799             $self->{output} = $json->encode({files => \@arr});
800             }
801              
802             sub _no_ext {
803             my $self = shift;
804             $self->filename($_->{filename});
805             my ($no_ext) = $self->filename =~ qr/(.*)\.(.*)/;
806             return $no_ext;
807             }
808              
809             #PRE/POST METHODS
810             sub pre_delete {
811             my $self = shift;
812              
813             if (@_) {
814             $self->{pre_delete} = shift;
815             }
816              
817             return $self->{pre_delete};
818             }
819              
820             sub post_delete {
821             my $self = shift;
822              
823             if (@_) {
824             $self->{post_delete} = shift;
825             }
826              
827             return $self->{post_delete};
828             }
829              
830             sub pre_post {
831             my $self = shift;
832              
833             if (@_) {
834             $self->{pre_post} = shift;
835             }
836              
837             return $self->{pre_post};
838             }
839              
840             sub post_post {
841             my $self = shift;
842              
843             if (@_) {
844             $self->{post_post} = shift;
845             }
846              
847             return $self->{post_post};
848             }
849              
850             sub pre_get {
851             my $self = shift;
852              
853             if (@_) {
854             $self->{pre_get} = shift;
855             }
856              
857             return $self->{pre_get};
858             }
859              
860             sub post_get {
861             my $self = shift;
862              
863             if (@_) {
864             $self->{post_get} = shift;
865             }
866              
867             return $self->{post_get};
868             }
869              
870             sub _clear {
871             my $self = shift;
872              
873             #clear cgi object so we get a new one for new request
874             $self->{cgi} = undef;
875             $self->{handle} = undef;
876             $self->{tmp_filename} = undef;
877             $self->{upload} = undef;
878             $self->{fh} = undef;
879             $self->{file_size} = undef;
880             $self->{error} = undef;
881             $self->{file_type} = undef;
882             $self->{is_image} = 0;
883             $self->{width} = undef;
884             $self->{height} = undef;
885             $self->{num_files_in_dir} = undef;
886             $self->{output} = undef;
887             $self->{client_filename} = undef;
888             $self->{tmp_thumb_path} = undef;
889             $self->{tmp_file_path} = undef;
890             $self->{user_error} = undef;
891             }
892              
893             sub _post {
894             my $self = shift;
895              
896             if($self->_prepare_file_attrs and $self->_validate_file) {
897             if($self->is_image) {
898             $self->_create_thumbnail;
899             $self->_create_tmp_image
900             }
901             $self->_save;
902             }
903              
904             #delete temporary files
905             if($self->is_image) {
906             unlink ($self->{tmp_thumb_path}, $self->{tmp_file_path});
907             }
908              
909             #generate json output
910             $self->_generate_output;
911             }
912              
913             sub _generate_output {
914             my $self = shift;
915              
916             my $method = $self->_get_request_method;
917             my $obj;
918              
919             if($method eq 'POST') {
920             my %hash;
921             unless($self->{user_error}) {
922             $hash{'url'} = $self->url;
923             $hash{'thumbnailUrl'} = $self->thumbnail_url;
924             $hash{'deleteUrl'} = $self->_delete_url;
925             $hash{'deleteType'} = 'DELETE';
926             $hash{error} = $self->_generate_error;
927             }
928             else {
929             $self->_prepare_file_basics;
930             $hash{error} = $self->{user_error};
931             }
932              
933             $hash{'name'} = $self->show_client_filename ? $self->client_filename . "" : $self->filename;
934             $hash{'size'} = $self->{file_size};
935             $obj->{files} = [\%hash];
936             }
937             elsif($method eq 'DELETE') {
938             unless($self->{user_error}) {
939             $obj->{$self->_get_param('filename')} = JSON::true;
940             }
941             else {
942             $obj->{error} = $self->{user_error};
943             }
944             }
945              
946             my $json = JSON::XS->new->ascii->pretty->allow_nonref;
947             $self->{output} = $json->encode($obj);
948             }
949              
950             sub _delete {
951             my $self = shift;
952              
953             my $filename = $self->_get_param('filename');
954             my $thumbnail_filename = $self->_get_param('thumbnail_filename');
955             my $image_yn = $self->_get_param('image');
956              
957             if(@{$self->scp}) {
958             for(@{$self->scp}) {
959              
960             my $ssh2 = $self->_auth_user($_);
961             $_->{thumbnail_upload_dir} = $_->{upload_dir} if $_->{thumbnail_upload_dir} eq '';
962              
963             my $sftp = $ssh2->sftp;
964             $sftp->unlink($_->{upload_dir} . '/' . $filename);
965             $sftp->unlink($_->{thumbnail_upload_dir} . '/' . $thumbnail_filename) if $image_yn eq 'y';
966             }
967             }
968             else {
969             my $no_ext = $self->_no_ext;
970             unlink $self->upload_dir . '/' . $filename;
971             unlink($self->thumbnail_upload_dir . '/' . $thumbnail_filename) if $image_yn eq 'y';
972             }
973              
974             $self->_generate_output;
975             }
976              
977             sub _get_param {
978             my $self = shift;
979             my ($param) = @_;
980              
981             if(defined $self->ctx) {
982             return $self->ctx->req->params->{$param};
983             }
984             else {
985             return $self->cgi->param($param);
986             }
987             }
988              
989             sub _delete_url {
990             my $self = shift;
991             return if $self->delete_url ne '';
992             my ($delete_params) = @_;
993              
994             my $url = $self->script_url;
995             my $uri = $self->{uri}->clone;
996              
997             my $image_yn = $self->is_image ? 'y' : 'n';
998              
999             unless(defined $delete_params and scalar(@$delete_params)) {
1000             $delete_params = [];
1001             }
1002              
1003             push @$delete_params, @{$self->delete_params} if @{$self->delete_params};
1004             push @$delete_params, ('filename',$self->filename,'image',$image_yn);
1005             push @$delete_params, ('thumbnail_filename',$self->thumbnail_filename) if $self->is_image;
1006              
1007             $uri->query_form($delete_params);
1008              
1009             $self->delete_url($uri->as_string);
1010              
1011             return $self->delete_url;
1012             }
1013              
1014             sub _script_url {
1015             my $self = shift;
1016              
1017             if(defined $self->ctx) {
1018             return $self->ctx->request->uri;
1019             }
1020             else {
1021             return $ENV{'SCRIPT_URI'};
1022             }
1023             }
1024              
1025             sub _prepare_file_attrs {
1026             my $self = shift;
1027              
1028             #ORDER MATTERS
1029             return unless $self->_prepare_file_basics;
1030             $self->_set_tmp_filename;
1031             $self->_set_file_type;
1032             $self->_set_is_image;
1033             $self->_set_filename;
1034             $self->_set_absolute_filenames;
1035             $self->_set_image_magick;
1036             $self->_set_width;
1037             $self->_set_height;
1038             $self->_set_num_files_in_dir;
1039             $self->_set_uri;
1040             $self->_set_urls;
1041              
1042             return 1;
1043             }
1044              
1045             sub _prepare_file_basics {
1046             my ($self) = @_;
1047              
1048             return undef unless $self->_set_upload_obj;
1049             $self->_set_fh;
1050             $self->_set_file_size;
1051             $self->_set_client_filename;
1052              
1053             return 1;
1054             }
1055              
1056             sub _set_urls {
1057             my $self = shift;
1058              
1059             if($self->is_image) {
1060             $self->{thumbnail_url} = $self->thumbnail_url_base . '/' . $self->thumbnail_filename;
1061             }
1062             $self->{url} = $self->upload_url_base . '/' . $self->filename;
1063             }
1064              
1065             sub _set_uri {
1066             my $self = shift;
1067             #if catalyst, use URI already made?
1068             if(defined $self->ctx) {
1069             $self->{uri} = $self->ctx->req->uri;
1070             }
1071             else {
1072             $self->{uri} = URI->new($self->script_url);
1073             }
1074             }
1075              
1076             sub _generate_error {
1077             my $self = shift;
1078             return undef unless defined $self->{error} and @{$self->{error}};
1079              
1080             my $restrictions = join ',', @{$self->{error}->[1]};
1081             return $errors{$self->{error}->[0]} . " Restriction: $restrictions Provided: " . $self->{error}->[2];
1082             }
1083              
1084             sub _validate_file {
1085             my $self = shift;
1086             return undef unless
1087             $self->_validate_max_file_size and
1088             $self->_validate_min_file_size and
1089             $self->_validate_accept_file_types and
1090             $self->_validate_reject_file_types and
1091             $self->_validate_max_width and
1092             $self->_validate_min_width and
1093             $self->_validate_max_height and
1094             $self->_validate_min_height and
1095             $self->_validate_max_number_of_files;
1096              
1097             return 1;
1098             }
1099              
1100             sub _save {
1101             my $self = shift;
1102              
1103             if(@{$self->scp}) {
1104             $self->_save_scp;
1105             }
1106             else {
1107             $self->_save_local;
1108             }
1109             }
1110              
1111             sub _save_scp {
1112             my $self = shift;
1113              
1114             for(@{$self->scp}) {
1115             die "Must provide a host to scp" if $_->{host} eq '';
1116              
1117             $_->{thumbnail_upload_dir} = $_->{upload_dir} if $_->{thumbnail_upload_dir} eq '';
1118              
1119             my $path = $_->{upload_dir} . '/' . $self->filename;
1120             my $thumb_path = $_->{thumbnail_upload_dir} . '/' . $self->thumbnail_filename;
1121              
1122             if(($_->{user} ne '' and $_->{public_key} ne '' and $_->{private_key} ne '') or ($_->{user} ne '' and $_->{password} ne '')) {
1123             my $ssh2 = $self->_auth_user($_);
1124              
1125             #if it is an image, scp both file and thumbnail
1126             if($self->is_image) {
1127             $ssh2->scp_put($self->{tmp_file_path}, $path);
1128             $ssh2->scp_put($self->{tmp_thumb_path}, $thumb_path);
1129             }
1130             else {
1131             $ssh2->scp_put($self->{tmp_filename}, $path);
1132             }
1133              
1134             $ssh2->disconnect;
1135             }
1136             else {
1137             die "Must provide a user and password or user and identity file for connecting to host";
1138             }
1139              
1140             }
1141             }
1142              
1143             sub _auth_user {
1144             my $self = shift;
1145             my ($auth) = @_;
1146              
1147             my $ssh2 = Net::SSH2->new;
1148              
1149             $ssh2->connect($auth->{host}) or die $!;
1150              
1151             #authenticate
1152             if($auth->{user} ne '' and $auth->{public_key} ne '' and $auth->{private_key} ne '') {
1153             $ssh2->auth_publickey($auth->{user},$auth->{public_key},$auth->{private_key});
1154             }
1155             else {
1156             $ssh2->auth_password($auth->{user},$auth->{password});
1157             }
1158              
1159             unless($ssh2->auth_ok) {
1160             die "error authenticating with remote server";
1161             }
1162              
1163             die "upload directory must be provided with scp hash" if $auth->{upload_dir} eq '';
1164              
1165             return $ssh2;
1166             }
1167              
1168             sub _save_local {
1169             my $self = shift;
1170              
1171             #if image
1172             if($self->is_image) {
1173             rename $self->{tmp_file_path}, $self->absolute_filename;
1174             rename $self->{tmp_thumb_path}, $self->absolute_thumbnail_filename;
1175             }
1176             #if non-image with catalyst
1177             elsif(defined $self->ctx) {
1178             if ($self->copy_file) {
1179             $self->{upload}->copy_to($self->absolute_filename);
1180             } else {
1181             $self->{upload}->link_to($self->absolute_filename);
1182             }
1183             }
1184             #if non-image with regular CGI perl
1185             else {
1186             my $io_handle = $self->{fh}->handle;
1187              
1188             my $buffer;
1189             open (OUTFILE,'>', $self->absolute_filename);
1190             while (my $bytesread = $io_handle->read($buffer,1024)) {
1191             print OUTFILE $buffer;
1192             }
1193              
1194             close OUTFILE;
1195             }
1196             }
1197              
1198             sub _validate_max_file_size {
1199             my $self = shift;
1200             return 1 unless $self->max_file_size;
1201              
1202             if($self->{file_size} > $self->max_file_size) {
1203             $self->{error} = ['_validate_max_file_size',[$self->max_file_size],$self->{file_size}];
1204             return undef;
1205             }
1206             else {
1207             return 1;
1208             }
1209             }
1210              
1211             sub _validate_min_file_size {
1212             my $self = shift;
1213             return 1 unless $self->min_file_size;
1214              
1215             if($self->{file_size} < $self->min_file_size) {
1216             $self->{error} = ['_validate_min_file_size',[$self->min_file_size],$self->{file_size}];
1217             return undef;
1218             }
1219             else {
1220             return 1;
1221             }
1222             }
1223              
1224             sub _validate_accept_file_types {
1225             my $self = shift;
1226              
1227             #if accept_file_types is empty, we except all types
1228             #so return true
1229             return 1 unless @{$self->accept_file_types};
1230              
1231             if(grep { $_ eq $self->{file_type} } @{$self->{accept_file_types}}) {
1232             return 1;
1233             }
1234             else {
1235             my $types = join ",", @{$self->accept_file_types};
1236             $self->{error} = ['_validate_accept_file_types',[$types],$self->{file_type}];
1237             return undef;
1238             }
1239             }
1240              
1241             sub _validate_reject_file_types {
1242             my $self = shift;
1243              
1244             #if reject_file_types is empty, we except all types
1245             #so return true
1246             return 1 unless @{$self->reject_file_types};
1247              
1248             unless(grep { $_ eq $self->{file_type} } @{$self->{reject_file_types}}) {
1249             return 1;
1250             }
1251             else {
1252             my $types = join ",", @{$self->reject_file_types};
1253             $self->{error} = ['_validate_reject_file_types',[$types],$self->{file_type}];
1254             return undef;
1255             }
1256             }
1257              
1258             sub _validate_max_width {
1259             my $self = shift;
1260             return 1 unless $self->is_image;
1261              
1262             #if set to undef, there's no max_width
1263             return 1 unless $self->max_width;
1264              
1265             if($self->{width} > $self->max_width) {
1266             $self->{error} = ['_validate_max_width',[$self->max_width],$self->{width}];
1267             return undef;
1268             }
1269             else {
1270             return 1;
1271             }
1272             }
1273              
1274             sub _validate_min_width {
1275             my $self = shift;
1276             return 1 unless $self->is_image;
1277              
1278             #if set to undef, there's no min_width
1279             return 1 unless $self->min_width;
1280              
1281             if($self->{width} < $self->min_width) {
1282             $self->{error} = ['_validate_min_width',[$self->min_width],$self->{width}];
1283             return undef;
1284             }
1285             else {
1286             return 1;
1287             }
1288             }
1289              
1290             sub _validate_max_height {
1291             my $self = shift;
1292             return 1 unless $self->is_image;
1293              
1294             #if set to undef, there's no max_height
1295             return 1 unless $self->max_height;
1296              
1297             if($self->{height} > $self->max_height) {
1298             $self->{error} = ['_validate_max_height',[$self->max_height],$self->{height}];
1299             return undef;
1300             }
1301             else {
1302             return 1;
1303             }
1304             }
1305              
1306             sub _validate_min_height {
1307             my $self = shift;
1308             return 1 unless $self->is_image;
1309              
1310             #if set to undef, there's no max_height
1311             return 1 unless $self->min_height;
1312              
1313             if($self->{height} < $self->min_height) {
1314             $self->{error} = ['_validate_min_height',[$self->min_height],$self->{height}];
1315             return undef;
1316             }
1317             else {
1318             return 1;
1319             }
1320             }
1321              
1322             sub _validate_max_number_of_files {
1323             my $self = shift;
1324             return 1 unless $self->max_number_of_files;
1325              
1326             if($self->{num_files_in_dir} > $self->max_number_of_files) {
1327             $self->{error} = ['_validate_max_number_of_files',[$self->max_number_of_files],$self->{num_files_in_dir}];
1328             return undef;
1329             }
1330             else {
1331             return 1;
1332             }
1333             }
1334              
1335             sub _set_file_size {
1336             my $self = shift;
1337              
1338             if(defined $self->ctx) {
1339             $self->{file_size} = $self->{upload}->size;
1340             }
1341             else {
1342             $self->{file_size} = -s $self->{upload};
1343             }
1344              
1345             return $self->{file_size};
1346             }
1347              
1348             sub _set_client_filename {
1349             my $self = shift;
1350             return if defined $self->client_filename;
1351              
1352             if(defined $self->ctx) {
1353             $self->client_filename($self->{upload}->filename);
1354             }
1355             else {
1356             $self->client_filename($self->cgi->param($self->field_name));
1357             }
1358              
1359             return $self->client_filename;
1360             }
1361              
1362             sub _set_filename {
1363             my $self = shift;
1364             return if defined $self->filename;
1365              
1366             if($self->use_client_filename) {
1367             $self->filename($self->client_filename);
1368             }
1369             else {
1370             my $filename = Data::GUID->new->as_string . $self->filename_salt;
1371             $self->thumbnail_filename($self->thumbnail_prefix . $filename . $self->thumbnail_postfix . '.' . $self->thumbnail_format) unless $self->thumbnail_filename;
1372              
1373             if($self->is_image) {
1374             $filename .= '.' . $self->format;
1375             }
1376             else {
1377             #add extension if present
1378             if($self->client_filename =~ qr/.*\.(.*)/) {
1379             $filename .= '.' . $1;
1380             }
1381             }
1382             $self->filename($filename) unless $self->filename;
1383             }
1384              
1385             return $self->filename;
1386             }
1387              
1388             sub _set_absolute_filenames {
1389             my $self = shift;
1390              
1391             $self->absolute_filename($self->upload_dir . '/' . $self->filename) unless $self->absolute_filename;
1392             $self->absolute_thumbnail_filename($self->thumbnail_upload_dir . '/' . $self->thumbnail_filename) unless $self->absolute_thumbnail_filename;
1393             }
1394              
1395             sub _set_file_type {
1396             my $self = shift;
1397              
1398             if(defined $self->ctx) {
1399             $self->{file_type} = $self->{upload}->type;
1400             }
1401             else {
1402             $self->{file_type} = $self->cgi->uploadInfo($self->client_filename)->{'Content-Type'};
1403             }
1404              
1405             return $self->{file_type};
1406             }
1407              
1408             sub _set_is_image {
1409             my $self = shift;
1410              
1411             if($self->process_images and ($self->process_images and ($self->{file_type} eq 'image/jpeg' or $self->{file_type} eq 'image/jpg' or $self->{file_type} eq 'image/png' or $self->{file_type} eq 'image/gif'))) {
1412             $self->{is_image} = 1;
1413             }
1414             else {
1415             $self->{is_image} = 0;
1416             }
1417              
1418             return $self->is_image;
1419             }
1420              
1421             sub _set_image_magick {
1422             my $self = shift;
1423             return unless $self->is_image;
1424              
1425             #if used in persistent setting, don't recreate object
1426             $self->{image_magick} = Image::Magick->new unless defined $self->{image_magick};
1427              
1428             $self->{image_magick}->Read(file => $self->{fh});
1429              
1430             return $self->{image_magick};
1431             }
1432              
1433             sub _set_width {
1434             my $self = shift;
1435             return unless $self->is_image;
1436              
1437             $self->{width} = $self->{image_magick}->Get('width');
1438             }
1439              
1440             sub _set_height {
1441             my $self = shift;
1442             return unless $self->is_image;
1443              
1444             $self->{height} = $self->{image_magick}->Get('height');
1445             }
1446              
1447             sub _set_tmp_filename {
1448             my $self = shift;
1449              
1450             my $tmp_filename;
1451             if(defined $self->ctx) {
1452             $self->{tmp_filename} = $self->{upload}->tempname;
1453             }
1454             else {
1455             $self->{tmp_filename} = $self->cgi->tmpFileName($self->client_filename);
1456             }
1457             }
1458              
1459             sub _set_upload_obj {
1460             my $self = shift;
1461              
1462             if(defined $self->ctx) {
1463             $self->{upload} = $self->ctx->request->upload($self->field_name);
1464             }
1465             else {
1466             $self->{upload} = $self->cgi->upload($self->field_name);
1467             }
1468              
1469             return defined $self->{upload};
1470             }
1471              
1472             sub _set_fh {
1473             my $self = shift;
1474              
1475             if(defined $self->ctx) {
1476             $self->{fh} = $self->{upload}->fh;
1477             }
1478             else {
1479             $self->{fh} = $self->{upload};
1480             }
1481              
1482             return $self->{fh};
1483             }
1484              
1485             sub _set_num_files_in_dir {
1486             my $self = shift;
1487             return unless $self->max_number_of_files;
1488              
1489             #DO SCP VERSION
1490             if(@{$self->{scp}}) {
1491             my $max = 0;
1492             for(@{$self->{scp}}) {
1493             my $ssh2 = $self->_auth_user($_);
1494             my $chan = $ssh2->channel();
1495             $chan->exec('ls -rt ' . $_->{upload_dir} . ' | wc -l');
1496             my $buffer;
1497             $chan->read($buffer,1024);
1498             ($self->{num_files_in_dir}) = $buffer =~ qr/(\d+)/;
1499             $max = $self->{num_files_in_dir} if $self->{num_files_in_dir} > $max;
1500             }
1501              
1502             #set to maximum of hosts because we know if one's over that's too many
1503             $self->{num_files_in_dir} = $max;
1504             }
1505             else {
1506             my $dir = $self->upload_dir;
1507             my @files = <$dir/*>;
1508             $self->{num_files_in_dir} = @files;
1509             }
1510              
1511             return $self->{num_files_in_dir};
1512             }
1513              
1514             sub _get_request_method {
1515             my $self = shift;
1516              
1517             my $method = '';
1518             if(defined $self->ctx) {
1519             $method = $self->ctx->req->method;
1520             }
1521             else {
1522             $method = $self->cgi->request_method;
1523             }
1524              
1525             return $method;
1526             }
1527              
1528             sub _set_status {
1529             my $self = shift;
1530             my ($response) = @_;
1531              
1532             if(defined $self->ctx) {
1533             $self->ctx->response->status($response);
1534             }
1535             else {
1536             print $self->cgi->header(-status=>$response);
1537             }
1538             }
1539              
1540             sub _set_header {
1541             my $self = shift;
1542             my ($key,$val) = @_;
1543              
1544             if(defined $self->ctx) {
1545             $self->ctx->response->header($key => $val);
1546             }
1547             else {
1548             print $self->cgi->header($key,$val);
1549             }
1550             }
1551              
1552             sub _create_thumbnail {
1553             my $self = shift;
1554              
1555             my $im = $self->{image_magick}->Clone;
1556              
1557             #thumb is added at beginning of tmp_thumb_path as to not clash with the original image file path
1558             my $output = $self->{tmp_thumb_path} = $self->tmp_dir . '/thumb_' . $self->thumbnail_filename;
1559             my $width = $self->thumbnail_width;
1560             my $height = $self->thumbnail_height;
1561              
1562             my $density = $self->thumbnail_density || $width . "x" . $height;
1563             my $quality = $self->thumbnail_quality;
1564             my $format = $self->thumbnail_format;
1565              
1566             # source image dimensions
1567             my ($o_width, $o_height) = $im->Get('width','height');
1568              
1569             # calculate image dimensions required to fit onto thumbnail
1570             my ($t_width, $t_height, $ratio);
1571             # wider than tall (seems to work...) needs testing
1572             if( $o_width > $o_height ){
1573             $ratio = $o_width / $o_height;
1574             $t_width = $width;
1575             $t_height = $width / $ratio;
1576              
1577             # still won't fit, find the smallest size.
1578             while($t_height > $height){
1579             $t_height -= $ratio;
1580             $t_width -= 1;
1581             }
1582             }
1583             # taller than wide
1584             elsif( $o_height > $o_width ){
1585             $ratio = $o_height / $o_width;
1586             $t_height = $height;
1587             $t_width = $height / $ratio;
1588              
1589             # still won't fit, find the smallest size.
1590             while($t_width > $width){
1591             $t_width -= $ratio;
1592             $t_height -= 1;
1593             }
1594             }
1595             # square (fixed suggested by Philip Munt phil@savvyshopper.net.au)
1596             elsif( $o_width == $o_height){
1597             $ratio = 1;
1598             $t_height = $width;
1599             $t_width = $width;
1600             while (($t_width > $width) or ($t_height > $height)){
1601             $t_width -= 1;
1602             $t_height -= 1;
1603             }
1604             }
1605              
1606             # Create thumbnail
1607             if( defined $im ){
1608             $im->Resize( width => $t_width, height => $t_height );
1609             $im->Set( quality => $quality );
1610             $im->Set( density => $density );
1611              
1612             $self->final_width($t_width);
1613             $self->final_height($t_height);
1614              
1615             $im->Write("$format:$output");
1616             }
1617             }
1618              
1619             sub _create_tmp_image {
1620             my $self = shift;
1621             my $im = $self->{image_magick};
1622              
1623             #main_ is added as to not clash with thumbnail tmp path if thumbnail_prefix = '' and they have the same name
1624             my $output = $self->{tmp_file_path} = $self->tmp_dir . '/main_' . $self->filename;
1625             my $quality = $self->thumbnail_quality;
1626             my $format = $self->thumbnail_format;
1627              
1628             if( defined $im ){
1629             $im->Set( quality => $quality );
1630              
1631             $im->Write("$format:$output");
1632              
1633             $self->final_width($im->Get('width'));
1634             $self->final_height($im->Get('height'));
1635             }
1636             }
1637              
1638             #sub _save_cloud {
1639             # my $self = shift;
1640             # my $io_handle = $self->{fh}->handle;
1641             #
1642             # #IF IS IMAGE, MUST UPLOAD BOTH IMAGES
1643             #
1644             # my $s_contents;
1645             # while (my $bytesread = $io_handle->read($buffer,1024)) {
1646             # print OUTFILE $buffer;
1647             ## }
1648             #
1649             #
1650             ## while()
1651             # {
1652             # $s_contents .= $_;
1653             ## }
1654             #
1655             ## ### we will call this resource whatever comes after the last /
1656             # my $s_resourceName;
1657             #
1658             ## if($param->{'path'} =~ /^.*\/(.*)$/)
1659             # {
1660             # $s_resourceName = $1;
1661             ## }
1662             # else
1663             # {
1664             # return('fail', "could not parse path: $param->{'path'}");
1665             ## }
1666             #
1667             # ### should we pass these vars ... or look them up?
1668             # my $s_user = '';
1669             # my $s_key = '';
1670             ## my $s_cdn_uri ='';
1671             #
1672             # my $ua = LWP::UserAgent->new;
1673             # my $req = HTTP::Request->new(GET => 'https://auth.api.rackspacecloud.com/v1.0');
1674             ## $req->header('X-Auth-User' => $s_user);
1675             # $req->header('X-Auth-Key' => $s_key);
1676             #
1677             ## my $res = $ua->request($req);
1678             #
1679             # if ($res->is_success)
1680             ## {
1681             # my $s_url = $res->header('X-Storage-Url') . "/container/" . $s_resourceName;
1682             #
1683             ## my $reqPUT = HTTP::Request->new(PUT => $s_url);
1684             # $reqPUT->header('X-Auth-Token' => $res->header('X-Auth-Token'));
1685             #
1686             ## $reqPUT->content( $s_contents );
1687             #
1688             # my $resPUT = $ua->request($reqPUT);
1689             ##
1690             # if($resPUT->is_success)
1691             # {
1692             ## my $s_returnURI = $s_cdn_uri . "/" . $s_resourceName;
1693             # return('pass','passed afaict', $s_returnURI);
1694             # }
1695             ## else
1696             # {
1697             # my $s_temp = $resPUT->as_string;
1698             # $s_temp =~ s/'/\\'/g;
1699             ## return('fail',"PUT failed with response:$s_temp")
1700             # }
1701             # }
1702             ## else
1703             # {
1704             # my $s_temp = $res->as_string;
1705             ## $s_temp =~ s/'/\\'/g;
1706             # return('fail',"failed with response:$s_temp")
1707             # }
1708             ## }
1709             # else
1710             # {
1711             ## return("fail","sorry no file found at $param->{'path'}");
1712             # }
1713             #}
1714             #
1715             ##sub _delete_cloud {
1716             # my $self = shift;
1717             # my $request = HTTP::Request->new( 'DELETE', $self->_url,
1718             #Q [ 'X-Auth-Token' => $self->cloudfiles->token ] );
1719             # my $response = $self->cloudfiles->_request($request);
1720             # confess 'Object ' . $self->name . ' not found' if $response->code == 404;
1721             # confess 'Unknown error' if $response->code != 204;
1722             #}
1723              
1724             # Preloaded methods go here.
1725              
1726             1;
1727             __END__