File Coverage

blib/lib/File/Tabular/Web.pm

Criterion	Covered	Total	%
statement	307	372	82.5
branch	75	144	52.0
condition	32	82	39.0
subroutine	50	57	87.7
pod	29	31	93.5
total	493	686	71.8

package File::Tabular::Web; # documentation at bottom of file

our $VERSION = "0.24";

use strict;
use warnings;
no warnings 'uninitialized';
use locale;
use Template;
use POSIX 'strftime';
use List::Util      qw/min/;
use List::MoreUtils qw/uniq any all/;
use AppConfig       qw/:argcount/;
use File::Tabular 0.71;
use Search::QueryParser;
use Try::Tiny;

use parent 'Plack::Component';
use Plack::Request;
use Plack::Response;

my %app_cache;
my %datafile_cache;      #  persistent data private to _cached_content

#======================================================================
#             MAIN ENTRY POINT
#======================================================================

#----------------------------------------------------------------------
sub call { # Plack request dispatcher (see L)
#----------------------------------------------------------------------
  my ($self, $env) = @_;

  try {
    # regular response
    $self->_new($env);
    $self->_dispatch_request;
  }
    # in case of an exception
    catch {
      # try displaying through msg view..
      $self->{msg} = "ERROR : $_";
      $self->{view} = 'msg';
      try {$self->display}
        catch {
          # .. or else fallback with simple HTML page
          my $res = Plack::Response->new(500);
          $res->body("$self->{msg}");
          $res->content_type('text/html');
          return $res->finalize;
        };
    };
}



#----------------------------------------------------------------------
sub handler : method { # for backwards compatibility : can be called
                       # as a modperl handler or from a CGI script.
                       # New apps should rather use the Plack interface.
#----------------------------------------------------------------------
  my ($class, $request) = @_;

  my $self = $class->new;
  my $app  = $self->to_app;

  if ($request && ref($request) =~ /^Apache2/) {
    require Plack::Handler::Apache2;
    Plack::Handler::Apache2->call_app($request, $app);
  }
  else {
    require Plack::Handler::CGI;
    $ENV{QUERY_STRING} = $request if $request;
    Plack::Handler::CGI->new->run($app);
  }
}


#======================================================================
#     METHODS FOR CREATING / INITIALIZING "APPLICATION" HASHREFS      #
#======================================================================

#----------------------------------------------------------------------
sub _app_new { # creates a new application hashref (not an object)
#----------------------------------------------------------------------
  my ($self, $config_file) = @_;
  my $app = {};

  # application name and directory : defaults from the name of config file
  @{$app}{qw(dir name)} = ($config_file =~ m[^(.+[/\\])(.+?)(?:\.[^.]*)$]);

  # read the config file
  $app->{cfg} = $self->_app_read_config($config_file);

  my $tmp; # predeclare $tmp so that it can be used in "and" clauses

  # application directory
  $tmp = $app->{cfg}->get('application_dir')  and do {
    $tmp =~ s{[^/\\]$}{/}; # add trailing "/" to dir if necessary
    $app->{dir} = $tmp;
  };

  # application name
  $tmp = $app->{cfg}->get('application_name') and $app->{name} = $tmp;

  # data file
  $tmp = $app->{cfg}->get('application_data');
  $app->{data_file} = $app->{dir} . ($tmp || "$app->{name}.txt");

  # application class
  $app->{class} = ref $self; # initial value, may be overridden
  $tmp = $app->{cfg}->get('application_class') and do {
    eval "require $tmp"      or die $@; # dynamically load the requested code
    $tmp->isa($app->{class}) or die "$tmp is not a $app->{class}";
    $app->{class} = $tmp;
  };

  return $app;
}

#----------------------------------------------------------------------
sub _app_read_config { # read configuration file through Appconfig
#----------------------------------------------------------------------
  my ($class, $config_file) = @_;

  # error handler : die for all errors except "no such variable"
  my $error_func = sub {
    my $fmt = shift;
    die sprintf("AppConfig : $fmt\n", @_)
      unless $fmt =~ /no such variable/;
  };

  # create AppConfig object (options documented in L)
  my $cfg = AppConfig->new({
    CASE   => 1,                         # case-sensitive
    CREATE => 1,                         # accept dynamic creation of variables
    ERROR  => $error_func,               # specific error handler
    GLOBAL => {ARGCOUNT => ARGCOUNT_ONE},# default option for undefined vars
  });

  # define specific options for some variables
  # NOTE: fields_upload is not used here, but by F::T::Attachments
  foreach my $hash_var (qw/fields_default fields_time fields_upload/) {
    $cfg->define($hash_var => {ARGCOUNT => ARGCOUNT_HASH});
  }
  $cfg->define(fieldSep  => {DEFAULT => "|"});

  # read the configuration file
  $cfg->file($config_file); # or croak "AppConfig: open $config_file: $^E";
  # BUG : AppConfig does not return any error code if ->file(..) fails !!

  return $cfg;
}



#----------------------------------------------------------------------
sub app_initialize {
#----------------------------------------------------------------------
  # NOTE: this method is called after instance creation and therefore
  # takes into account the subclass which may have been given in the
  # config file.

  my ($self)   = @_;
  my $app      = $self->{app};
  my ($last_subdir) = ($app->{dir} =~ m[^.*[/\\](.+)[/\\]?$]);
  my $default  =   $self->{template_root}
                || $self->app_tmpl_default_dir;

  # directories to search for Templates
  my @tmpl_dirs = grep {-d} ($app->{cfg}->get("template_dir"),
                             $app->{dir},
                             "$default/$last_subdir",
                             $default,
                             "$default/default",
                            );

  # initialize template toolkit object
  $app->{tmpl} = Template->new({
    INCLUDE_PATH => \@tmpl_dirs,
    FILTERS      => $self->app_tmpl_filters,
    EVAL_PERL    => 1,
   })
    or die Template->error;

   # special fields : time of last modif, author of last modif
  $app->{time_fields} = $app->{cfg}->get('fields_time');
  $app->{user_field}  = $app->{cfg}->get('fields_user');
}


#----------------------------------------------------------------------
sub app_tmpl_default_dir { # default; override in subclasses
#----------------------------------------------------------------------
  my ($self) = @_;

  return "$self->{app_root}/../lib/tmpl/ftw";
}


#----------------------------------------------------------------------
sub app_tmpl_filters { # default; override in subclasses
#----------------------------------------------------------------------
  my ($self) = @_;
  my $cfg = $self->{app}{cfg};
  my $ini_marker = $cfg->get('preMatch');
  my $end_marker = $cfg->get('postMatch');

  # no highlight filters without pre/postMatch
  $ini_marker && $end_marker or return {};

  my $HL_class   = $cfg->get('highlightClass') || "HL";
  my $regex      = qr/\Q$ini_marker\E(.*?)\Q$end_marker\E/s;

  my $filters = {
    highlight => sub {
      my $text = shift;
      $text =~ s[$regex][$1]g;
      return $text;
    },
    unhighlight => sub {
      my $text = shift;
      $text =~ s[$regex][$1]g;
      return $text;
    }
   };
  return $filters;
}




#----------------------------------------------------------------------
sub app_phases_definitions {
#----------------------------------------------------------------------
  my $class = shift;

# PHASES DEFINITIONS TABLE : each single letter is expanded into
# optional methods for data preparation, data operation, and view.
# It is also possible to differentiate between GET and POST requests.
  return (

    A => # prepare a new record for adding
      {GET  => {pre => 'empty_record',                  view => 'modif'},
       POST => {pre => 'empty_record', op => 'update'                  }  },

    D => # delete record
      {pre => 'search_key', op => 'delete'                                },

    H => # display home page
      {                                                 view => 'home'    },

    L => # display "long" view of one single record
      {pre => 'search_key',                             view => 'long'    },

    M => # modif: GET displays the form, POST performs the update
      {GET  => {pre => 'search_key',                    view => 'modif'},
       POST => {pre => 'search_key', op => 'update'                }  },

    S => # search and display "short" view
      {pre => 'search', op => 'sort_and_slice',         view => 'short'   },

    X => # display all records in "download view" (mnemonic: eXtract)
      {pre => 'prepare_download',                       view => 'download'},

   );
}



#======================================================================
#           METHODS FOR INSTANCE CREATION / INITIALIZATION            #
#======================================================================



#----------------------------------------------------------------------
sub _new { # expands and re-blesses the File::Tabular::Web instance
#----------------------------------------------------------------------
  my ($self, $env) = @_;

  my $req       = Plack::Request->new($env);
  my $path_info = $req->path_info
    or die __PACKAGE__ . ": no application (PATH_INFO is empty)";

  # add some fields within object
  $self->{req}    = $req;
  $self->{user}   = $req->user || "Anonymous";
  $self->{url}    = $req->base . $path_info;
  $self->{method} = $req->method;
  $self->{msg}    = "";

  # are we running under mod_perl ? if so, have a handle to the Rec object.
  my $mod_perl = do {my $input = $self->{req}->env->{'psgi.input'};
                     $input->isa('Apache2::RequestRec') && $input};

  # find the app root, by default equal to server document root
  $self->{app_root}
    ||=   $mod_perl && $mod_perl->document_root
       || $env->{CONTEXT_DOCUMENT_ROOT} # new in Apache2.4
       || $env->{DOCUMENT_ROOT};        # standard CGI protocol

  # find application file
  my $app_file =   $mod_perl && $mod_perl->filename
                || $env->{SCRIPT_FILENAME}
                || $env->{PATH_TRANSLATED}
                || $self->{app_root} . $req->script_name . $path_info;

  # compare modification time with cache; load app if necessary
  my $mtime = (stat $app_file)[9]
    or die "couldn't stat app file for $path_info";
  my $cache_entry = $app_cache{$app_file};
  my $app_initialized = $cache_entry && $cache_entry->{mtime} == $mtime;
  if (not $app_initialized) {
    $app_cache{$app_file} = {mtime   => $mtime,
                             content => $self->_app_new($app_file)};
  }
  $self->{app} = $app_cache{$app_file}->{content};
  $self->{cfg} = $self->{app}{cfg}; # shortcut

  # rebless the request obj into the application class, initialize and return
  bless $self, $self->{app}{class};

  # now that we have the proper class, initialize the app if needed
  $self->app_initialize unless $app_initialized;

  # initialize the request obj
  $self->initialize;

  return $self;
}


#----------------------------------------------------------------------
sub initialize { # setup params from config and/or CGI params
#----------------------------------------------------------------------
  my $self = shift;

  # default values
  $self->{max}     = $self->param('max')   || 500;
  $self->{count}   = $self->param('count') ||  50;
  $self->{orderBy} = $self->param('orderBy')
                  || $self->param('sortBy'); # for backwards compatibility

  return $self;
}


#----------------------------------------------------------------------
sub _setup_phases { # decide about next phases
#----------------------------------------------------------------------
  my $self = shift;

  # get all phases definitions (expansions of single-letter param)
  my %request_phases = $self->app_phases_definitions;

  # find out which single-letter was requested
  my @letters = grep {defined $request_phases{$_}} uniq $self->param;

  # cannot ask for several operations at once
  @letters <= 1 or die "conflict in request: " . join(" / ", @letters);

  # by default : homepage
  my $letter = $letters[0] || "H";

  # argument passed to operation
  my $letter_arg = $self->param($letters[0]);

  # special case : with POST requests, we want to also consider the ?A or ?M=..
  # or ?D=.. from the query string
  if (not @letters and $self->{method} eq 'POST') {
  LETTER:
    for my $try_letter (qw/A M D/) {
      $letter_arg = $self->{req}->query_parameters->get($try_letter);
      $letter = $try_letter and last LETTER if defined($letter_arg);
    }
  }

  # setup info in $self according to the chosen letter
  my $entry     = $request_phases{$letter};
  my $phases    = $entry->{$self->{method}} || $entry;
  $self->{view} = $self->param('V') || $phases->{view};
  $self->{pre}  = $phases->{pre};
  $self->{op}   = $phases->{op};

  return $letter_arg;
}


#----------------------------------------------------------------------
sub open_data { # open File::Tabular object on data file
#----------------------------------------------------------------------
  my $self = shift;

  # parameters for opening the file
  my $open_src = $self->{app}{data_file};
  my $mtime    = (stat $open_src)[9] or die "couldn't stat $open_src";

  # text version of modified time for templates
  if (my $fmt = $self->{cfg}->get('application_mtime')) {
    $self->{mtime} = strftime($fmt, localtime($mtime));
  }

  my $open_mode = ($self->{op} =~ /delete|update/) ? "+<" : "<";

  # application option : use in-memory cache only for read operations
  if ($self->{cfg}->get('application_useFileCache')
        && $open_mode eq '<') {
    my $cache_entry = $datafile_cache{$open_src};
    unless ($cache_entry && $cache_entry->{mtime} == $mtime) {
      open my $fh, $open_src or die "open $open_src : $^E";
      local $/ = undef;
      my $content = <$fh>;	# slurps the whole file into memory
      close $fh;
      $datafile_cache{$open_src} = {mtime   => $mtime,
                                    content => \$content };
    }
    $open_src = $cache_entry->{content}; # ref to in-memory content
  }

  # set up options for creating File::Tabular object
  my %options;
  foreach (qw/preMatch postMatch avoidMatchKey fieldSep recordSep/) {
    $options{$_} = $self->{cfg}->get($_);
  }
  $options{autoNumField} = $self->{cfg}->get('fields_autoNum');
  my $jFile = $self->{cfg}->get('journal');
  $options{journal} = "$self->{app}{dir}$jFile" if $jFile;

  # create File::Tabular object
  $self->{data} = new File::Tabular($open_mode, $open_src, \%options);
}


#======================================================================
#               PUBLIC METHODS CALLABLE FROM TEMPLATES                #
#======================================================================


#----------------------------------------------------------------------
sub param { # Encapsulates access to the lower layer param() method, and
            # merge with config information.
#----------------------------------------------------------------------
  my ($self, $param_name) = @_; # $param_name might be undef

  # Like old CGI->param(), we only return body parameters on POST
  # requests (ignoring query parameters).
  my $params = $self->{method} eq 'POST' ? $self->{req}->body_parameters
                                         : $self->{req}->parameters;

  # if no arg, just return the list of param names
  return keys %$params if not defined $param_name;

  # otherwise, first check in "fixed" section in config
  my $val = $self->{cfg}->get("fixed_$param_name");
  return $val if $val;

  # then check in parameters to this request (flattened into a scalar)
  my @vals = $params->get_all($param_name);
  if (@vals) {
    $val = join(' ', @vals);    # join multiple values
    $val =~ s/^\s+//;           # remove initial spaces
    $val =~ s/\s+$//;           # remove final spaces
    return $val;
  }

  # finally check in "default" section in config
  return $self->{cfg}->get("default_$param_name");
}


#----------------------------------------------------------------------
sub can_do { # can be called from templates; $record is optional
#----------------------------------------------------------------------
  my ($self, $action, $record) = @_;

  my $allow  = $self->{cfg}->get("permissions_$action");
  my $deny = $self->{cfg}->get("permissions_no_$action");

  # some permissions are granted by default to everybody
  $allow ||= "*" if $action =~ /^(read|search|download)$/;

  for ($allow, $deny) {
    $_ or next;                   # no acl list => nothing to do
    $_ = $self->user_match($_)    #    if acl list matches user name
       ||(   /\$(\S+)\b/i         # or if acl list contains a field name ...
	  && defined($record)                   # ... and got a specific record
          && defined($record->{$1})             # ... and field is defined
	  && $self->user_match($record->{$1})); # ... and field content matches
  }

  return $allow && !$deny;
}



#======================================================================
#                 REQUEST HANDLING : GENERAL METHODS                  #
#======================================================================


#----------------------------------------------------------------------
sub _dispatch_request { # go through phases and choose appropriate handling
#----------------------------------------------------------------------
  my $self = shift;
  my $method;

  # determine phases from single-letter param; keep arg value from that letter
  my $letter_arg = $self->_setup_phases;

  # data access
  $self->open_data;

  # data preparation : invoke method if any, passing the arg saved above
  $method = $self->{pre} and $self->$method($letter_arg);

  # data manipulation : invoke method if any
  $method = $self->{op} and $self->$method;

  # force message view if there is a message
  $self->{view} = 'msg' if $self->{msg};

  # print the output
  $self->display;
}


#----------------------------------------------------------------------
sub display { # display results in the requested view
#----------------------------------------------------------------------
  my ($self) = @_;
  my $view = $self->{view} or die "display : no view";


  # name of the template for this view
  my $default_tmpl = $view eq 'download' ? "download.tt"
                                         : "$self->{app}{name}_$view.tt";
  my $tmpl_name = $self->{cfg}->get("template_$view") || $default_tmpl;

  # override template toolkit's failsafe counter for while loops
  # in case of download action
  local $Template::Directive::WHILE_MAX = 50000 if $view eq 'download';

  # call that template
  my $body;
  my $vars = {self => $self, found => $self->{results}};
  $self->{app}{tmpl}->process($tmpl_name, $vars, \$body)
    or die $self->{app}{tmpl}->error();

  # generate Plack response
  my $res = Plack::Response->new(200);
  $res->headers({"Content-type"   => "text/html",
                 "Content-length" => length($body),
                 "Last-modified"  => $self->{data}->stat->{mtime},
                 "Expires"        => 0});
  $res->body($body);

  return $res->finalize;
}


#======================================================================
#                 REQUEST HANDLING : SEARCH METHODS                   #
#======================================================================


#----------------------------------------------------------------------
sub search_key { # search by record key
#----------------------------------------------------------------------
  my ($self, $key) = @_;
  $self->can_do("read") or
    die "no 'read' permission for $self->{user}";
  $key or die "search_key : no key!";
  $key =~ s/<.*?>//g; # remove any markup (maybe inserted by pre/postMatch)

  my $query = "K_E_Y:$key";

  my ($records, $lineNumbers) = $self->{data}->fetchall(where => $query);
  my $count = @$records;
  $self->{results}{count}       = $count;
  $self->{results}{records}     = $records;
  $self->{results}{lineNumbers} = $lineNumbers;
}



#----------------------------------------------------------------------
sub search { # search records and display results
#----------------------------------------------------------------------
  my ($self, $search_string) = @_;

  # check permissions
  $self->can_do('search') or
    die "no 'search' permission for $self->{user}";

  $self->{search_string_orig} = $search_string;
  $self->before_search;
  $self->log_search;

  $self->{results}{count}       = 0;
  $self->{results}{records}     = [];
  $self->{results}{lineNumbers} = [];

  return if $self->{search_string} =~ /^\s*$/; # no query, no results

  my $qp = new Search::QueryParser;

  # compile query with an implicit '+' prefix in front of every item
  my $parsedQ = $qp->parse($self->{search_string}, '+') or
    die "error parsing query : $self->{search_string}";

  my $filter;

  eval {$filter = $self->{data}->compileFilter($parsedQ);} or
    die("error in query : $@ ," . $qp->unparse($parsedQ)
                                  . " ($self->{search_string})");

  # perform the search
  @{$self->{results}}{qw(records lineNumbers)} =
    $self->{data}->fetchall(where => $filter);
  $self->{results}{count} = @{$self->{results}{records}};

  # VERY CHEAP way of generating regex for highlighting results
  my @words_queried = uniq(grep {length($_)>2} $self->words_queried);
  $self->{results}{wordsQueried} = join "|", @words_queried;
}


#----------------------------------------------------------------------
sub before_search {
#----------------------------------------------------------------------
  my ($self) = @_;
  $self->{search_string} = $self->{search_string_orig} || "";
  return $self;
}



#----------------------------------------------------------------------
sub sort_and_slice { # sort results, then just keep the desired slice
#----------------------------------------------------------------------
  my $self = shift;

  delete $self->{results}{lineNumbers}; # not going to use those

  # sort results
  if ($self->{orderBy}) {
    eval {
      my $cmpfunc = $self->{data}->ht->cmp($self->{orderBy});
      $self->{results}{records} = [sort $cmpfunc @{$self->{results}{records}}];
    }
      or die "orderBy : $@";
  }

  # restrict to the desired slice
  my $start_record = $self->param('start') || ($self->{results}{count} ? 1 : 0);
  my $end_record   = min($start_record + $self->{count} - 1,
			 $self->{results}{count});
  die "illegal start value : $start_record" if $start_record > $end_record;
  $self->{results}{records} = $self->{results}{count}
    ? [ @{$self->{results}{records}}[$start_record-1 ... $end_record-1] ]
    : [];

  # check read permission on records (looping over records only if necessary)
  my $must_loop_on_records # true if  permission depends on record fields
    =  (($self->{cfg}->get("permissions_read") || "")    =~ /\$/)
    || (($self->{cfg}->get("permissions_no_read") || "") =~ /\$/);
  if ($must_loop_on_records) {
    foreach my $record (@{$self->{results}{records}}) {
      $self->can_do('read', $record)
        or die "no 'read' permission for $self->{user}";
    }
  }
  else { # no need for a loop
    $self->can_do('read')
      or die "no 'read' permission for $self->{user}";
  }

  # for user display : record numbers start with 1, not 0
  $self->{results}{start} = $start_record;
  $self->{results}{end}   = $end_record;


  # links to previous/next slice
  my $prev_idx = $start_record - $self->{count};
     $prev_idx = 1 if $prev_idx < 1;
  $self->{results}{prev_link} = $self->_url_for_next_slice($prev_idx)
    if $start_record > 1;
  my $next_idx = $start_record + $self->{count};
  $self->{results}{next_link} = $self->_url_for_next_slice($next_idx)
    if $next_idx <= $self->{results}{count};
}


#----------------------------------------------------------------------
sub _url_for_next_slice {
#----------------------------------------------------------------------
  my ($self, $start) = @_;

  my $url = "?" . join "&", $self->params_for_next_slice($start);

  # uri encoding
  $url =~ s/([^;\/?:@&=\$,A-Z0-9\-_.!~*'() ])/sprintf("%%%02X", ord($1))/ige;

  return $url;
}


#----------------------------------------------------------------------
sub params_for_next_slice {
#----------------------------------------------------------------------
  my ($self, $start) = @_;

  # need request object to invoke native param() method
  my $req = $self->{req};

  my @params = ("S=$self->{search_string_orig}", "start=$start");
  push @params, "orderBy=$self->{orderBy}" if $req->parameters->{orderBy};
  push @params, "count=$self->{count}"     if $req->parameters->{count};

  return @params;
}


#----------------------------------------------------------------------
sub words_queried {
#----------------------------------------------------------------------
  my $self = shift;
  return ($self->{search_string_orig} =~ m([\w/]+)g);
}



#----------------------------------------------------------------------
sub log_search {
#----------------------------------------------------------------------
  my $self = shift;
  return if not $self->{logger};

  my $msg = "[$self->{search_string}] $self->{user}";
  $self->{logger}->info($msg);
}


#======================================================================
#                 REQUEST HANDLING : UPDATE METHODS                   #
#======================================================================


#----------------------------------------------------------------------
sub empty_record { # to be displayed in "modif" view (when adding)
#----------------------------------------------------------------------
  my ($self) = @_;

  $self->can_do("add") or
    die "no 'add' permission for $self->{user}";

  # build a record and insert default values
  my $record = $self->{data}->ht->new;
  my $defaults = $self->{cfg}->get("fields_default");
  if (my $auto_num = $self->{data}{autoNumField}) {
    $defaults->{$auto_num} ||= $self->{data}{autoNumChar};
  }
  $record->{$_} = $defaults->{$_} foreach $self->{data}->headers;

  $self->{results} = {count => 1, records => [$record], lineNumbers => [-1]};
}


#----------------------------------------------------------------------
sub update {
#----------------------------------------------------------------------
  my ($self) = @_;

  # check if there is one record to update
  my $found  = $self->{results};
  $found->{count} == 1 or die "unexpected number of records to update";

  # gather some info
  my $record     = $found->{records}[0];
  my $line_nb    = $found->{lineNumbers}[0];
  my $is_adding  = $line_nb == -1;
  my $permission = $is_adding ? 'add' : 'modif';

  # check if user has permission
  $self->can_do($permission, $record)
    or die "No permission '$permission' for $self->{user}";

  # if adding, must make sure to read all rows so that autonum gets updated
  if ($is_adding &&  $self->{cfg}->get('fields_autoNum')) {
    while ($self->{data}->fetchrow) {}
  }

  # call hook before update
  $self->before_update($record);

  # prepare message to user
  my @headers = $self->{data}->headers;
  my $data_line = join("|", @{$record}{@headers});
  my ($msg, $id) = $is_adding ? ("Created", $self->{data}{autoNum})
                              : ("Updated", $self->key($record));
  $self->{msg} .= "$msg:"
               .  "Record $id: $data_line";

  # do the update
  my $to_delete = $is_adding ? 0         # no previous line to delete
                             : 1;        # replace previous line
  eval {$self->{data}->splices($line_nb, $to_delete, $record)} or do {
    my $err = $@;
    $self->rollback_update($record);
    die $err;
  };

  # call hook after update
  $self->after_update($record);
}


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

  # copy defined params into record ..
  my $key_field = $self->param($self->key_field);
  foreach my $field ($self->{data}->headers) {
    my $val = $self->param($field);
    next if not defined $val;
    if ($field eq $key_field and $val ne $self->key($record)) {
      die "supplied key $val does not match record key";
    }
    $record->{$field} = $val;
  }

  # force username into user field (if any)
  my $user_field = $self->{app}{user_field};
  $record->{$user_field} = $self->{user} if $user_field;

  # force current time or date into time fields (if any)
  while (my ($k, $fmt) = each %{$self->{app}{time_fields}}) {
    $record->{$k} = strftime($fmt, localtime);
  }
}


sub after_update    {} # override in subclasses
sub rollback_update {} # override in subclasses


#======================================================================
#                 REQUEST HANDLING : DELETE METHODS                   #
#======================================================================

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

  # check if there is one record to update
  my $found = $self->{results};
  $found->{count} == 1 or die "unexpected number of records to delete";

  # gather some info
  my $record     = $found->{records}[0];
  my $line_nb    = $found->{lineNumbers}[0];

  # check if user has permission
  $self->can_do("delete", $record)
    or die "No permission 'delete' for $self->{user}";

  # call hook before delete
  $self->before_delete($record);

  # do the deletion
  $self->{data}->splices($line_nb, 1, undef);

  # message to user
  my @headers = $self->{data}->headers;
  my @values = @{$record}{@headers};
  $self->{msg} = "Deleted:" . join("|", @values);

  # call hook after delete
  $self->after_delete($record);
}


sub before_delete {} # override in subclasses
sub after_delete  {} # override in subclasses


#======================================================================
#                       MISCELLANEOUS METHODS                         #
#======================================================================



#----------------------------------------------------------------------
sub prepare_download {
#----------------------------------------------------------------------
  my ($self, $which) = @_;
  $self->can_do('download')
    or die "No permission 'download' for $self->{user}";
}


#----------------------------------------------------------------------
sub print_help {
#----------------------------------------------------------------------
  print "sorry, no help at the moment";
}



#----------------------------------------------------------------------
sub user_match {
#----------------------------------------------------------------------
  my ($self, $access_control_list) = @_;

  # success if the list contains '*' or the current username
  return ($access_control_list =~ /\*|\b\Q$self->{user}\E\b/i);
}


#----------------------------------------------------------------------
sub key_field {
#----------------------------------------------------------------------
  my ($self) = @_;
  return ($self->{data}->headers)[0];
}


#----------------------------------------------------------------------
sub key { # returns the value in the first field of the record
#----------------------------------------------------------------------
  my ($self, $record) = @_;

  # optimized version, breaking encapsulation of File::Tabular
  return (tied %$record)->[1];

  # going through official API would be : return $record->{$self->key_field};
}

1;


__END__