File Coverage

blib/lib/File/Tabular/Web/Attachments.pm

Criterion	Covered	Total	%
statement	15	113	13.2
branch	0	46	0.0
condition	0	8	0.0
subroutine	5	18	27.7
pod	11	13	84.6
total	31	198	15.6

=begin TODO

  - override "display" to accept V=UploadField
     => would redirect to attached file

  - support for multiple files under same field

=end TODO

=cut


package File::Tabular::Web::Attachments;
use base 'File::Tabular::Web';
use strict;
use warnings;

use File::Path;
use Scalar::Util qw/looks_like_number/;


#----------------------------------------------------------------------
sub app_initialize {
#----------------------------------------------------------------------
  my $self = shift;

  $self->SUPER::app_initialize;

  # field names specified as "upload fields" in config
  $self->{app}{upload_fields} = $self->{app}{cfg}->get('fields_upload');
}


#----------------------------------------------------------------------
sub open_data {
#----------------------------------------------------------------------
  my $self = shift;

  $self->SUPER::open_data;

  # upload fields must be present in the data file
  my %data_headers = map {$_ => 1} $self->{data}->headers;
  my @upld = keys %{$self->{app}{upload_fields}};
  my $invalid = join ", ", grep {not $data_headers{$_}} @upld;
  die "upload fields in config but not in data file: $invalid" if $invalid;
}


#----------------------------------------------------------------------
sub before_update { #
#----------------------------------------------------------------------
  my ($self, $record) = @_;

  my @upld = keys %{$self->{app}{upload_fields}};

  # remember paths and names of old files (in case we must delete them later)
  foreach my $field (grep {$record->{$_}} @upld) {
    $self->{old_name}{$field} = $record->{$field};
    $self->{old_path}{$field} = $self->upload_fullpath($record, $field);
  }

  # call parent method
  $self->SUPER::before_update($record);

  # find out about next autoNum (WARN: breaks encapsulation of File::Tabular!)
  if ($self->{cfg}->get('fields_autoNum')) {
    $self->{next_autoNum} = $self->{data}{autoNum};
  }

  # now deal with file uploads
  foreach my $field (@upld) {

    my $remote_name = $self->param($field);
    # If we have a Plack::Request , use the uploads func to
    # retrieve the file that was uploaded
    if(!$remote_name && $self->{req}) {
      my $upload = $self->{req}->uploads->{$field};
      $remote_name = $upload->basename if ($upload);
    }
    if ($remote_name) {
      $self->do_upload_file($record, $field, $remote_name);
    }
    else { # upload is "" ==> must restore old name in record
      $record->{$field} = $self->{old_name}{$field} || "";
    }
  };
}

#----------------------------------------------------------------------
sub do_upload_file { #
#----------------------------------------------------------------------
  my ($self, $record, $field, $remote_name) = @_;

  my $src_fh;

  if ($self->{modperl}) {
    require Apache2::Request;
    require Apache2::Upload;
    my $req  = Apache2::Request->new($self->{modperl});
    my $upld = $req->upload($field) or die "no upload object for field $field";
    $src_fh = $upld->fh;
  }
  else {
    my @uploads = $self->{req}->upload($field); # may be an array
    my @upld_fh = map { $_->path } @uploads;

    # TODO : some convention for deleting an existing attached file
    # if @upload_fh == 0 && $remote_name =~ /^( |del)/ {...}

    # no support at the moment for multiple files under same field
    @upld_fh < 2  or die "several files uploaded to $field";

    # need to open the filehandle to reproduce Apache2::Upload's behaviour
    open $src_fh, "<$upld_fh[0]" or die "open <$upld_fh[0] : $!";

  }

  # compute server name and server path
  $record->{$field}
                = $self->generate_upload_name($record, $field, $remote_name);
  my $path      = $self->upload_fullpath($record, $field);
  my $old_path  = $self->{old_path}{$field};

  # avoid clobbering existing files
  not -e $path or $path eq $old_path
    or die "upload $field : file $path already exists";

  # check that upload path is unique
  not exists $self->{results}{uploaded}{$path}
    or die "multiple uploads to same server location : $path";

  # remember new and old path
  $self->{results}{uploaded}{$path} = {field    => $field,
                                       old_path => $old_path};

  # do the transfer
  my ($dir) = ($path =~ m[^(.*)[/\\]]);
  -d $dir or mkpath $dir; # will die if can't make path

  open my $dest_fh, ">$path.new" or die "open >$path.new : $!";

  binmode($dest_fh), binmode($src_fh);
  my $buf;
  while (read($src_fh, $buf, 4096)) { print $dest_fh $buf;}

  $self->{msg} .= "file $remote_name uploaded to $path";
}


#----------------------------------------------------------------------
sub after_update {
#----------------------------------------------------------------------
  my ($self, $record) = @_;

  my $uploaded = $self->{results}{uploaded};

  # rename uploaded files and delete old versions
  while (my ($path, $info) = each %$uploaded) {
    my $field    = $info->{field};
    my $old_path = $info->{old_path};

    $self->before_delete_attachment($record, $field, $old_path)
      if $old_path;

    rename "$path.new", "$path" or die "rename $path.new => $path : $!";

    if ($old_path) {
      if ($old_path eq $path) {
	$self->{msg} .= "old file $old_path has been replaced";
      }
      else {
	my $unlink_ok = unlink $old_path;
	$self->{msg} .= $unlink_ok ? "removed old file $old_path"
                                   : "remove $old_path : $^E";
      }
    }
    $self->after_add_attachment($record, $field, $path);
  }
}




#----------------------------------------------------------------------
sub rollback_update { # undo what was done by "before_update"
#----------------------------------------------------------------------
  my ($self, $record) = @_;
  my $uploaded = $self->{results}{uploaded};
  foreach my $path (keys %$uploaded) {
    unlink("$path.new");
  }
}




#----------------------------------------------------------------------
sub after_delete {
#----------------------------------------------------------------------
  my ($self, $record)= @_;

  $self->SUPER::after_delete($record);

  # suppress files attached to deleted record
  my @upld = keys %{$self->{app}{upload_fields}};
  foreach my $field (@upld) {
    my $path = $self->upload_fullpath($record, $field)
      or next;

    $self->before_delete_attachment($record, $path);
    my $unlink_ok = unlink "$path";
    my $msg = $unlink_ok ? "was suppressed" : "couldn't be suppressed ($!)";
    $self->{msg} .= "Attached file $path $msg";
  }
}


#----------------------------------------------------------------------
sub generate_upload_name {
#----------------------------------------------------------------------
  my ($self, $record, $field, $remote_name)= @_;

  # just keep the trailing part of the remote name
  $remote_name =~ s{^.*[/\\]}{};
  return $remote_name;
}


#----------------------------------------------------------------------
sub upload_path {
#----------------------------------------------------------------------
  my ($self, $record, $field)= @_;

  return "" if not $record->{$field};

  # get the id of that record; if creating, cheat by guessing next autoNum
  my $autonum_char = $self->{data}{autoNumChar};
  (my $key = $self->key($record)) =~ s/$autonum_char/$self->{next_autoNum}/;

  my $dir = looks_like_number($key) ? sprintf "%05d/", int($key / 100)
                                    : "";

  return "${field}/${dir}${key}_$record->{$field}";
}


#----------------------------------------------------------------------
sub upload_fullpath {
#----------------------------------------------------------------------
  my ($self, $record, $field)= @_;
  my $path = $self->upload_path($record, $field);
  return $path ? "$self->{app}{dir}$path" : "";
}


#----------------------------------------------------------------------
sub download { # default implementation; override in subclasses
#----------------------------------------------------------------------
  my ($self, $record, $field)= @_;

  return $self->upload_path($record, $field); # relative to app URL
}




sub after_add_attachment     {}
sub before_delete_attachment {}







1;

__END__