File::Tabular::Web - turn a tabular file into a web application

  <LocationMatch "\.ftw$">
    SetHandler modperl
    PerlResponseHandler File::Tabular::Web
  </LocationMatch>

   #!/path/to/perl
   use File::Tabular::Web;
   File::Tabular::Web->handler;

  http://my.server/cgi-bin/ftw/path/to/my/app.ftw

  Action file-tabular-web /cgi-bin/ftw 
  AddHandler file-tabular-web .ftw

  http://my.server/cgi-bin/ftw/path/to/my/app.ftw

  http://my.server/path/to/my/app.ftw

  http://myServer/some/app.ftw?H

  http://myServer/some/app.ftw

  http://myServer/some/app.ftw?S=<criteria>

  word1 word2 word3                 # records containing these 3 words anywhere
  +word1 +word2 +word3              # idem
  word1 word2 -word3                # containing word1 and word2 but not word3
  word1 AND (word2 OR word3)        # obvious
  "word1 word2 word3"               # sequence
  word*                             # word completion
  field1:word1 field2:word2         # restricted by field
  field1 == val1  field2 > val2     # relational operators (will inspect the
                                    #   shape of supplied values to decide
                                    #   about string/numeric/date comparisons)
  field~regex                       # regex

  ?S=word&orderBy=birthdate:-d.m.y,lastname:alpha&count=20&start=40

  http://myServer/some/app.ftw?L=<key>

  http://myServer/some/app.ftw?M=key

  http://myServer/some/app.ftw?A

  http://myServer/some/app.ftw?D=<key>

  http://myServer/some/app.ftw?X

  http://myServer/some/app.ftw?S=<criteria>&V=print

  <a href="?H">Homepage</a>
  <a href="?S=*">See all records</a>
  <a href="?A">Add a new record</a>
  [% FOREACH record IN found.records %]
    <a href="?M=[% record.Id %]">Modify this record</a>
  [% END # FOREACH  %]

  <form method="POST">
   First Name <input name="firstname" value="[% record.firstname %]"><br>
   Last Name  <input name="lasttname" value="[% record.lastname %]">
   <input type="submit">
  </form>

  <form method="post">
    <input name="D" value="[% record.Id %]">
    <input type="submit" value="Delete this record">
  </form>

  <form method="POST" action="[% self.url %]">
     Search : 
       <select name="S">
         <option value="">--Choose in field1--</option>
         <option value="+field1:val1">val1</option>
         <option value="+field1:val2">val2</option>
         ...
       </select>
       Other : <input name="S">
   <input type="submit">
  </form>

   action="[% self.url %]"

  preMatch  {[
  postMatch ]}

    /path/to/http/htdocs/some/data.ftw

  [fixed]
  count=50
  [default]
  orderBy=lastname

  ?S=*&count=20

  ?S=*&count=50&orderBy=lastname

  [permissions]
   read   = * # the default, could have been omitted
   search = * # idem
   add    = andy bill 
   modif  = $last_author # username must match content of field 'last_author'
   delete = $last_author

  File::Tabular::Web->handler;

  preMatch  {[
  postMatch ]}

  <a href="/some/url?with=[% record.foo | unhighlight | uri %]">
      link to [% record.foo | html | highlight %]
  </a>

  [% self.param %]

  [% self.param(param_name) %]

  [% self.cgi.param(param_name) %]

  [% self.APR_request.param(param_name) %]

  [% self.can_do($action, [$record]) %]

  $self->user_match($access_control_list)

  my $key = $self->key($record);

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

our $VERSION = "0.19"; 

use strict;
use warnings;
no warnings 'uninitialized';
use locale;
use Carp;
use CGI;
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;


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


# Methods names starting with an '_' should not be overridden 
# in subclasses !


#======================================================================
#             MAIN ENTRY POINT (for modperl or cgi-bin)               #
#======================================================================


#----------------------------------------------------------------------
sub handler : method { 
#----------------------------------------------------------------------
  my $class = shift; # if under modperl, $_[0] will be the Apache2::RequestRec
  my $self;
  eval { $self = $class->_new(@_);  $self->_dispatch_request; 1;}
    or do {
      $self ||= bless {}, $class;  # fake object if the new() method failed
      $self->{msg} = "<b><font color='red'>ERROR</font></b> : $@";
      $self->{view} = 'msg';

      # try displaying through msg view..
      eval {$self->display}
        or do { # .. or else fallback with simple HTML page
          my $content = "<html>$self->{msg}</html>\n";
          if (ref($_[0]) =~ /^Apache2/) { # if under mod_perl
            $_[0]->print($content)
          }
          else {
            print "Content-type: text/html\n\n$content";
          }
        };
    };

  return 0; # Apache2::Const::OK;
}


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

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

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

  # read the config file
  $app->{cfg} = $class->_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
  $tmp = $app->{cfg}->get('application_class') and do {
    eval "require $tmp" or die $@; # dynamically load the requested code
    $tmp->isa($class) or die "$tmp is not a $class";
    $app->{class} = $tmp;
  };
  $app->{class} ||= $class; # default if not specified in config

  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<AppConfig::State>)
  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->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->{server_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][<span class="$HL_class">$1</span>]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 { # creates a new instance of a request object
#----------------------------------------------------------------------
  my $class = shift; # if under modperl, $_[0] will be the Apache2::RequestRec
  my $self = {};
  my $path;

  # if under mod_perl, we got an Apache2::RequestRec as second arg
  if (ref($_[0]) =~ /^Apache2/) {
    $self->{modperl}     = $_[0];
    $self->{server_root} = Apache2::ServerUtil::server_root();
    $self->{user}        = $self->{modperl}->user || "Anonymous";
    $self->{url}         = $self->{modperl}->uri;
    $self->{method}      = $self->{modperl}->method;
    $path                = $self->{modperl}->filename;

    require APR::Request::Apache2;
    $self->{APR_request} = APR::Request::Apache2->handle($self->{modperl});
  }
  else { # create the CGI instance
    $self->{cgi}         = CGI->new(@_);
    # server_root: no definite info. We guess it is one level above doc_root
    $self->{server_root} = ($ENV{DOCUMENT_ROOT} =~ m[(.*)[/\\]])[0];
    $self->{user}        = $self->{cgi}->remote_user || "Anonymous";
    $self->{url}         = $self->{cgi}->url(-path => 1);
    $self->{method}      = $self->{cgi}->request_method;
    $path                = $self->{cgi}->path_translated;
  }

  # get file last modification time
  my $mtime = (stat $path)[9] or die "couldn't stat $path";
  my $cache_entry = $app_cache{$path};
  my $app_initialized = $cache_entry && $cache_entry->{mtime} == $mtime;
  if (not $app_initialized) {
    $app_cache{$path} = {mtime   => $mtime, 
                         content => $class->_app_new($path)};
  }
  $self->{app} = $app_cache{$path}->{content};
  $self->{cfg} = $self->{app}{cfg}; # shortcut

  # bless the request obj into the application class, initialize and return
  bless $self, $self->{app}{class};
  $app_initialized or $self->app_initialize; # must happen after "bless"
  $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') {
    my ($target, $method) = 
      $self->{modperl} ? ($self->{APR_request}, "args"     )
                       : ($self->{cgi},         "url_param");
    for my $try_letter (qw/A M D/) {
      $letter_arg = $target->$method($try_letter);
      $letter = $try_letter and last 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 { 
#----------------------------------------------------------------------
  my ($self, $param_name) = @_; # $param_name might be undef

  # Unified way to get to param() method in the underlying layer.
  # On POST requests, CGI->param(..) only returns body params, while
  # APR::Request->param(..) returns both query string and body params;
  # here we only want body params, so we must call another method (body).
  my $target = $self->{modperl} ? $self->{APR_request} : $self->{cgi};
  my $param_method 
    = ($self->{modperl} && $self->{method} eq 'POST') ? 'body' : 'param';
  my @vals = defined($param_name) ? $target->$param_method($param_name)
                                  : $target->$param_method();

  # if no arg, just return the list of param names
  return @vals 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)
  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();

  $self->_emit_page(\$body);
}


#----------------------------------------------------------------------
sub _emit_page {
#----------------------------------------------------------------------
  my ($self, $body_ref) = @_;

  # print headers and body
  my $length   = length $$body_ref;
  my $modified = $self->{data}->stat->{mtime};
  if ($self->{modperl}) {
    $self->{modperl}->content_type('text/html');
    $self->{modperl}->set_last_modified($modified);
    $self->{modperl}->set_content_length($length);
    $self->{modperl}->headers_out->add(Expires => 0);
    $self->{modperl}->print($$body_ref);
  }
  else {
    my $CRLF = "\015\012";
    print "Content-type: text/html$CRLF"
        . "Content-length: $length$CRLF"
        . "Last-modified: $modified$CRLF"
        . "Expires: 0$CRLF"
        . "$CRLF"
        . $$body_ref;
  }
}



#======================================================================
#                 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->{APR_request} || $self->{cgi}; 

  my @params = ("S=$self->{search_string_orig}", "start=$start");
  push @params, "orderBy=$self->{orderBy}" if $req->param('orderBy');
  push @params, "count=$self->{count}"     if $req->param('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} .= "<br>$msg:<br>"
               .  "<a href='?S=K_E_Y:$id'>Record $id</a>: $data_line<br>";

  # 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:<br>" . 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__