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


line stmt bran cond sub pod time code
1             package File::Tabular::Web; # documentation at bottom of file
2              
3             our $VERSION = "0.24";
4              
5 2     2   107223 use strict;
  2         11  
  2         53  
6 2     2   10 use warnings;
  2         5  
  2         55  
7 2     2   10 no warnings 'uninitialized';
  2         5  
  2         65  
8 2     2   905 use locale;
  2         1141  
  2         10  
9 2     2   986 use Template;
  2         40651  
  2         74  
10 2     2   990 use POSIX 'strftime';
  2         11758  
  2         14  
11 2     2   2386 use List::Util qw/min/;
  2         17  
  2         183  
12 2     2   856 use List::MoreUtils qw/uniq any all/;
  2         19817  
  2         15  
13 2     2   3228 use AppConfig qw/:argcount/;
  2         7883  
  2         165  
14 2     2   909 use File::Tabular 0.71;
  2         44930  
  2         56  
15 2     2   13 use Search::QueryParser;
  2         4  
  2         30  
16 2     2   756 use Try::Tiny;
  2         2894  
  2         90  
17              
18 2     2   11 use parent 'Plack::Component';
  2         4  
  2         10  
19 2     2   7075 use Plack::Request;
  2         81340  
  2         62  
20 2     2   821 use Plack::Response;
  2         2748  
  2         8706  
21              
22             my %app_cache;
23             my %datafile_cache; # persistent data private to _cached_content
24              
25             #======================================================================
26             # MAIN ENTRY POINT
27             #======================================================================
28              
29             #----------------------------------------------------------------------
30             sub call { # Plack request dispatcher (see L)
31             #----------------------------------------------------------------------
32 9     9 1 42555 my ($self, $env) = @_;
33              
34             try {
35             # regular response
36 9     9   344 $self->_new($env);
37 9         28 $self->_dispatch_request;
38             }
39             # in case of an exception
40             catch {
41             # try displaying through msg view..
42 0     0   0 $self->{msg} = "ERROR : $_";
43 0         0 $self->{view} = 'msg';
44 0         0 try {$self->display}
45             catch {
46             # .. or else fallback with simple HTML page
47 0         0 my $res = Plack::Response->new(500);
48 0         0 $res->body("$self->{msg}");
49 0         0 $res->content_type('text/html');
50 0         0 return $res->finalize;
51 0         0 };
52 9         70 };
53             }
54              
55              
56              
57             #----------------------------------------------------------------------
58             sub handler : method { # for backwards compatibility : can be called
59             # as a modperl handler or from a CGI script.
60             # New apps should rather use the Plack interface.
61             #----------------------------------------------------------------------
62 0     0 1 0 my ($class, $request) = @_;
63              
64 0         0 my $self = $class->new;
65 0         0 my $app = $self->to_app;
66              
67 0 0 0     0 if ($request && ref($request) =~ /^Apache2/) {
68 0         0 require Plack::Handler::Apache2;
69 0         0 Plack::Handler::Apache2->call_app($request, $app);
70             }
71             else {
72 0         0 require Plack::Handler::CGI;
73 0 0       0 $ENV{QUERY_STRING} = $request if $request;
74 0         0 Plack::Handler::CGI->new->run($app);
75             }
76             }
77              
78              
79             #======================================================================
80             # METHODS FOR CREATING / INITIALIZING "APPLICATION" HASHREFS #
81             #======================================================================
82              
83             #----------------------------------------------------------------------
84             sub _app_new { # creates a new application hashref (not an object)
85             #----------------------------------------------------------------------
86 1     1   5 my ($self, $config_file) = @_;
87 1         3 my $app = {};
88              
89             # application name and directory : defaults from the name of config file
90 1         9 @{$app}{qw(dir name)} = ($config_file =~ m[^(.+[/\\])(.+?)(?:\.[^.]*)$]);
  1         6  
91              
92             # read the config file
93 1         5 $app->{cfg} = $self->_app_read_config($config_file);
94              
95 1         3 my $tmp; # predeclare $tmp so that it can be used in "and" clauses
96              
97             # application directory
98 1 50       18 $tmp = $app->{cfg}->get('application_dir') and do {
99 0         0 $tmp =~ s{[^/\\]$}{/}; # add trailing "/" to dir if necessary
100 0         0 $app->{dir} = $tmp;
101             };
102              
103             # application name
104 1 50       14 $tmp = $app->{cfg}->get('application_name') and $app->{name} = $tmp;
105              
106             # data file
107 1         12 $tmp = $app->{cfg}->get('application_data');
108 1   33     16 $app->{data_file} = $app->{dir} . ($tmp || "$app->{name}.txt");
109              
110             # application class
111 1         6 $app->{class} = ref $self; # initial value, may be overridden
112 1 50       7 $tmp = $app->{cfg}->get('application_class') and do {
113 0 0       0 eval "require $tmp" or die $@; # dynamically load the requested code
114 0 0       0 $tmp->isa($app->{class}) or die "$tmp is not a $app->{class}";
115 0         0 $app->{class} = $tmp;
116             };
117              
118 1         16 return $app;
119             }
120              
121             #----------------------------------------------------------------------
122             sub _app_read_config { # read configuration file through Appconfig
123             #----------------------------------------------------------------------
124 1     1   4 my ($class, $config_file) = @_;
125              
126             # error handler : die for all errors except "no such variable"
127             my $error_func = sub {
128 187     187   6159 my $fmt = shift;
129 187 50       568 die sprintf("AppConfig : $fmt\n", @_)
130             unless $fmt =~ /no such variable/;
131 1         17 };
132              
133             # create AppConfig object (options documented in L)
134 1         17 my $cfg = AppConfig->new({
135             CASE => 1, # case-sensitive
136             CREATE => 1, # accept dynamic creation of variables
137             ERROR => $error_func, # specific error handler
138             GLOBAL => {ARGCOUNT => ARGCOUNT_ONE},# default option for undefined vars
139             });
140              
141             # define specific options for some variables
142             # NOTE: fields_upload is not used here, but by F::T::Attachments
143 1         207 foreach my $hash_var (qw/fields_default fields_time fields_upload/) {
144 3         238 $cfg->define($hash_var => {ARGCOUNT => ARGCOUNT_HASH});
145             }
146 1         95 $cfg->define(fieldSep => {DEFAULT => "|"});
147              
148             # read the configuration file
149 1         96 $cfg->file($config_file); # or croak "AppConfig: open $config_file: $^E";
150             # BUG : AppConfig does not return any error code if ->file(..) fails !!
151              
152 1         9411 return $cfg;
153             }
154              
155              
156              
157             #----------------------------------------------------------------------
158             sub app_initialize {
159             #----------------------------------------------------------------------
160             # NOTE: this method is called after instance creation and therefore
161             # takes into account the subclass which may have been given in the
162             # config file.
163              
164 1     1 1 3 my ($self) = @_;
165 1         4 my $app = $self->{app};
166 1         9 my ($last_subdir) = ($app->{dir} =~ m[^.*[/\\](.+)[/\\]?$]);
167             my $default = $self->{template_root}
168 1   33     9 || $self->app_tmpl_default_dir;
169              
170             # directories to search for Templates
171 5         81 my @tmpl_dirs = grep {-d} ($app->{cfg}->get("template_dir"),
172             $app->{dir},
173 1         8 "$default/$last_subdir",
174             $default,
175             "$default/default",
176             );
177              
178             # initialize template toolkit object
179 1 50       13 $app->{tmpl} = Template->new({
180             INCLUDE_PATH => \@tmpl_dirs,
181             FILTERS => $self->app_tmpl_filters,
182             EVAL_PERL => 1,
183             })
184             or die Template->error;
185              
186             # special fields : time of last modif, author of last modif
187 1         23585 $app->{time_fields} = $app->{cfg}->get('fields_time');
188 1         74 $app->{user_field} = $app->{cfg}->get('fields_user');
189             }
190              
191              
192             #----------------------------------------------------------------------
193             sub app_tmpl_default_dir { # default; override in subclasses
194             #----------------------------------------------------------------------
195 1     1 1 3 my ($self) = @_;
196              
197 1         7 return "$self->{app_root}/../lib/tmpl/ftw";
198             }
199              
200              
201             #----------------------------------------------------------------------
202             sub app_tmpl_filters { # default; override in subclasses
203             #----------------------------------------------------------------------
204 1     1 1 4 my ($self) = @_;
205 1         4 my $cfg = $self->{app}{cfg};
206 1         7 my $ini_marker = $cfg->get('preMatch');
207 1         10 my $end_marker = $cfg->get('postMatch');
208              
209             # no highlight filters without pre/postMatch
210 1 50 33     40 $ini_marker && $end_marker or return {};
211              
212 0   0     0 my $HL_class = $cfg->get('highlightClass') || "HL";
213 0         0 my $regex = qr/\Q$ini_marker\E(.*?)\Q$end_marker\E/s;
214              
215             my $filters = {
216             highlight => sub {
217 0     0   0 my $text = shift;
218 0         0 $text =~ s[$regex][$1]g;
219 0         0 return $text;
220             },
221             unhighlight => sub {
222 0     0   0 my $text = shift;
223 0         0 $text =~ s[$regex][$1]g;
224 0         0 return $text;
225             }
226 0         0 };
227 0         0 return $filters;
228             }
229              
230              
231              
232              
233             #----------------------------------------------------------------------
234             sub app_phases_definitions {
235             #----------------------------------------------------------------------
236 9     9 0 13 my $class = shift;
237              
238             # PHASES DEFINITIONS TABLE : each single letter is expanded into
239             # optional methods for data preparation, data operation, and view.
240             # It is also possible to differentiate between GET and POST requests.
241             return (
242              
243 9         198 A => # prepare a new record for adding
244             {GET => {pre => 'empty_record', view => 'modif'},
245             POST => {pre => 'empty_record', op => 'update' } },
246              
247             D => # delete record
248             {pre => 'search_key', op => 'delete' },
249              
250             H => # display home page
251             { view => 'home' },
252              
253             L => # display "long" view of one single record
254             {pre => 'search_key', view => 'long' },
255              
256             M => # modif: GET displays the form, POST performs the update
257             {GET => {pre => 'search_key', view => 'modif'},
258             POST => {pre => 'search_key', op => 'update' } },
259              
260             S => # search and display "short" view
261             {pre => 'search', op => 'sort_and_slice', view => 'short' },
262              
263             X => # display all records in "download view" (mnemonic: eXtract)
264             {pre => 'prepare_download', view => 'download'},
265              
266             );
267             }
268              
269              
270              
271             #======================================================================
272             # METHODS FOR INSTANCE CREATION / INITIALIZATION #
273             #======================================================================
274              
275              
276              
277             #----------------------------------------------------------------------
278             sub _new { # expands and re-blesses the File::Tabular::Web instance
279             #----------------------------------------------------------------------
280 9     9   22 my ($self, $env) = @_;
281              
282 9         70 my $req = Plack::Request->new($env);
283 9 50       121 my $path_info = $req->path_info
284             or die __PACKAGE__ . ": no application (PATH_INFO is empty)";
285              
286             # add some fields within object
287 9         195 $self->{req} = $req;
288 9   50     257 $self->{user} = $req->user || "Anonymous";
289 9         84 $self->{url} = $req->base . $path_info;
290 9         1606 $self->{method} = $req->method;
291 9         63 $self->{msg} = "";
292              
293             # are we running under mod_perl ? if so, have a handle to the Rec object.
294 9         14 my $mod_perl = do {my $input = $self->{req}->env->{'psgi.input'};
  9         23  
295 9 50       83 $input->isa('Apache2::RequestRec') && $input};
296              
297             # find the app root, by default equal to server document root
298             $self->{app_root}
299             ||= $mod_perl && $mod_perl->document_root
300             || $env->{CONTEXT_DOCUMENT_ROOT} # new in Apache2.4
301 9   33     46 || $env->{DOCUMENT_ROOT}; # standard CGI protocol
      66        
302              
303             # find application file
304             my $app_file = $mod_perl && $mod_perl->filename
305             || $env->{SCRIPT_FILENAME}
306             || $env->{PATH_TRANSLATED}
307 9   33     118 || $self->{app_root} . $req->script_name . $path_info;
308              
309             # compare modification time with cache; load app if necessary
310 9 50       286 my $mtime = (stat $app_file)[9]
311             or die "couldn't stat app file for $path_info";
312 9         42 my $cache_entry = $app_cache{$app_file};
313 9   66     42 my $app_initialized = $cache_entry && $cache_entry->{mtime} == $mtime;
314 9 100       23 if (not $app_initialized) {
315 1         6 $app_cache{$app_file} = {mtime => $mtime,
316             content => $self->_app_new($app_file)};
317             }
318 9         29 $self->{app} = $app_cache{$app_file}->{content};
319 9         24 $self->{cfg} = $self->{app}{cfg}; # shortcut
320              
321             # rebless the request obj into the application class, initialize and return
322 9         45 bless $self, $self->{app}{class};
323              
324             # now that we have the proper class, initialize the app if needed
325 9 100       33 $self->app_initialize unless $app_initialized;
326              
327             # initialize the request obj
328 9         45 $self->initialize;
329              
330 9         25 return $self;
331             }
332              
333              
334             #----------------------------------------------------------------------
335             sub initialize { # setup params from config and/or CGI params
336             #----------------------------------------------------------------------
337 9     9 1 18 my $self = shift;
338              
339             # default values
340 9   50     30 $self->{max} = $self->param('max') || 500;
341 9   50     27 $self->{count} = $self->param('count') || 50;
342 9   33     284 $self->{orderBy} = $self->param('orderBy')
343             || $self->param('sortBy'); # for backwards compatibility
344              
345 9         55 return $self;
346             }
347              
348              
349             #----------------------------------------------------------------------
350             sub _setup_phases { # decide about next phases
351             #----------------------------------------------------------------------
352 9     9   14 my $self = shift;
353              
354             # get all phases definitions (expansions of single-letter param)
355 9         32 my %request_phases = $self->app_phases_definitions;
356              
357             # find out which single-letter was requested
358 9         33 my @letters = grep {defined $request_phases{$_}} uniq $self->param;
  8         32  
359              
360             # cannot ask for several operations at once
361 9 50       33 @letters <= 1 or die "conflict in request: " . join(" / ", @letters);
362              
363             # by default : homepage
364 9   100     58 my $letter = $letters[0] || "H";
365              
366             # argument passed to operation
367 9         31 my $letter_arg = $self->param($letters[0]);
368              
369             # special case : with POST requests, we want to also consider the ?A or ?M=..
370             # or ?D=.. from the query string
371 9 50 66     34 if (not @letters and $self->{method} eq 'POST') {
372             LETTER:
373 0         0 for my $try_letter (qw/A M D/) {
374 0         0 $letter_arg = $self->{req}->query_parameters->get($try_letter);
375 0 0 0     0 $letter = $try_letter and last LETTER if defined($letter_arg);
376             }
377             }
378              
379             # setup info in $self according to the chosen letter
380 9         19 my $entry = $request_phases{$letter};
381 9   66     42 my $phases = $entry->{$self->{method}} || $entry;
382 9   66     21 $self->{view} = $self->param('V') || $phases->{view};
383 9         74 $self->{pre} = $phases->{pre};
384 9         21 $self->{op} = $phases->{op};
385              
386 9         57 return $letter_arg;
387             }
388              
389              
390             #----------------------------------------------------------------------
391             sub open_data { # open File::Tabular object on data file
392             #----------------------------------------------------------------------
393 9     9 1 15 my $self = shift;
394              
395             # parameters for opening the file
396 9         28 my $open_src = $self->{app}{data_file};
397 9 50       169 my $mtime = (stat $open_src)[9] or die "couldn't stat $open_src";
398              
399             # text version of modified time for templates
400 9 50       70 if (my $fmt = $self->{cfg}->get('application_mtime')) {
401 0         0 $self->{mtime} = strftime($fmt, localtime($mtime));
402             }
403              
404 9 100       77 my $open_mode = ($self->{op} =~ /delete|update/) ? "+<" : "<";
405              
406             # application option : use in-memory cache only for read operations
407 9 50 33     70 if ($self->{cfg}->get('application_useFileCache')
408             && $open_mode eq '<') {
409 0         0 my $cache_entry = $datafile_cache{$open_src};
410 0 0 0     0 unless ($cache_entry && $cache_entry->{mtime} == $mtime) {
411 0 0       0 open my $fh, $open_src or die "open $open_src : $^E";
412 0         0 local $/ = undef;
413 0         0 my $content = <$fh>; # slurps the whole file into memory
414 0         0 close $fh;
415 0         0 $datafile_cache{$open_src} = {mtime => $mtime,
416             content => \$content };
417             }
418 0         0 $open_src = $cache_entry->{content}; # ref to in-memory content
419             }
420              
421             # set up options for creating File::Tabular object
422 9         50 my %options;
423 9         27 foreach (qw/preMatch postMatch avoidMatchKey fieldSep recordSep/) {
424 45         457 $options{$_} = $self->{cfg}->get($_);
425             }
426 9         74 $options{autoNumField} = $self->{cfg}->get('fields_autoNum');
427 9         278 my $jFile = $self->{cfg}->get('journal');
428 9 50       52 $options{journal} = "$self->{app}{dir}$jFile" if $jFile;
429              
430             # create File::Tabular object
431 9         76 $self->{data} = new File::Tabular($open_mode, $open_src, \%options);
432             }
433              
434              
435             #======================================================================
436             # PUBLIC METHODS CALLABLE FROM TEMPLATES #
437             #======================================================================
438              
439              
440             #----------------------------------------------------------------------
441             sub param { # Encapsulates access to the lower layer param() method, and
442             # merge with config information.
443             #----------------------------------------------------------------------
444 71     71 1 183 my ($self, $param_name) = @_; # $param_name might be undef
445              
446             # Like old CGI->param(), we only return body parameters on POST
447             # requests (ignoring query parameters).
448             my $params = $self->{method} eq 'POST' ? $self->{req}->body_parameters
449 71 100       260 : $self->{req}->parameters;
450              
451             # if no arg, just return the list of param names
452 71 100       2230 return keys %$params if not defined $param_name;
453              
454             # otherwise, first check in "fixed" section in config
455 61         311 my $val = $self->{cfg}->get("fixed_$param_name");
456 61 100       616 return $val if $val;
457              
458             # then check in parameters to this request (flattened into a scalar)
459 52         108 my @vals = $params->get_all($param_name);
460 52 100       646 if (@vals) {
461 8         17 $val = join(' ', @vals); # join multiple values
462 8         29 $val =~ s/^\s+//; # remove initial spaces
463 8         24 $val =~ s/\s+$//; # remove final spaces
464 8         21 return $val;
465             }
466              
467             # finally check in "default" section in config
468 44         202 return $self->{cfg}->get("default_$param_name");
469             }
470              
471              
472             #----------------------------------------------------------------------
473             sub can_do { # can be called from templates; $record is optional
474             #----------------------------------------------------------------------
475 13     13 1 34 my ($self, $action, $record) = @_;
476              
477 13         74 my $allow = $self->{cfg}->get("permissions_$action");
478 13         187 my $deny = $self->{cfg}->get("permissions_no_$action");
479              
480             # some permissions are granted by default to everybody
481 13 100 50     158 $allow ||= "*" if $action =~ /^(read|search|download)$/;
482              
483 13         29 for ($allow, $deny) {
484 26 100       65 $_ or next; # no acl list => nothing to do
485             $_ = $self->user_match($_) # if acl list matches user name
486             ||( /\$(\S+)\b/i # or if acl list contains a field name ...
487             && defined($record) # ... and got a specific record
488             && defined($record->{$1}) # ... and field is defined
489 13   33     39 && $self->user_match($record->{$1})); # ... and field content matches
490             }
491              
492 13   33     66 return $allow && !$deny;
493             }
494              
495              
496              
497             #======================================================================
498             # REQUEST HANDLING : GENERAL METHODS #
499             #======================================================================
500              
501              
502             #----------------------------------------------------------------------
503             sub _dispatch_request { # go through phases and choose appropriate handling
504             #----------------------------------------------------------------------
505 9     9   18 my $self = shift;
506 9         11 my $method;
507              
508             # determine phases from single-letter param; keep arg value from that letter
509 9         24 my $letter_arg = $self->_setup_phases;
510              
511             # data access
512 9         34 $self->open_data;
513              
514             # data preparation : invoke method if any, passing the arg saved above
515 9 100       3874 $method = $self->{pre} and $self->$method($letter_arg);
516              
517             # data manipulation : invoke method if any
518 9 100       60 $method = $self->{op} and $self->$method;
519              
520             # force message view if there is a message
521 9 100       72 $self->{view} = 'msg' if $self->{msg};
522              
523             # print the output
524 9         31 $self->display;
525             }
526              
527              
528             #----------------------------------------------------------------------
529             sub display { # display results in the requested view
530             #----------------------------------------------------------------------
531 9     9 1 20 my ($self) = @_;
532 9 50       49 my $view = $self->{view} or die "display : no view";
533              
534              
535             # name of the template for this view
536 9 50       53 my $default_tmpl = $view eq 'download' ? "download.tt"
537             : "$self->{app}{name}_$view.tt";
538 9   33     60 my $tmpl_name = $self->{cfg}->get("template_$view") || $default_tmpl;
539              
540             # override template toolkit's failsafe counter for while loops
541             # in case of download action
542 9 50       381 local $Template::Directive::WHILE_MAX = 50000 if $view eq 'download';
543              
544             # call that template
545 9         15 my $body;
546 9         38 my $vars = {self => $self, found => $self->{results}};
547             $self->{app}{tmpl}->process($tmpl_name, $vars, \$body)
548 9 50       60 or die $self->{app}{tmpl}->error();
549              
550             # generate Plack response
551 9         84896 my $res = Plack::Response->new(200);
552             $res->headers({"Content-type" => "text/html",
553             "Content-length" => length($body),
554             "Last-modified" => $self->{data}->stat->{mtime},
555 9         245 "Expires" => 0});
556 9         1752 $res->body($body);
557              
558 9         71 return $res->finalize;
559             }
560              
561              
562             #======================================================================
563             # REQUEST HANDLING : SEARCH METHODS #
564             #======================================================================
565              
566              
567             #----------------------------------------------------------------------
568             sub search_key { # search by record key
569             #----------------------------------------------------------------------
570 4     4 1 14 my ($self, $key) = @_;
571 4 50       13 $self->can_do("read") or
572             die "no 'read' permission for $self->{user}";
573 4 50       13 $key or die "search_key : no key!";
574 4         8 $key =~ s/<.*?>//g; # remove any markup (maybe inserted by pre/postMatch)
575              
576 4         10 my $query = "K_E_Y:$key";
577              
578 4         21 my ($records, $lineNumbers) = $self->{data}->fetchall(where => $query);
579 4         10238 my $count = @$records;
580 4         15 $self->{results}{count} = $count;
581 4         32 $self->{results}{records} = $records;
582 4         15 $self->{results}{lineNumbers} = $lineNumbers;
583             }
584              
585              
586              
587             #----------------------------------------------------------------------
588             sub search { # search records and display results
589             #----------------------------------------------------------------------
590 3     3 1 10 my ($self, $search_string) = @_;
591              
592             # check permissions
593 3 50       12 $self->can_do('search') or
594             die "no 'search' permission for $self->{user}";
595              
596 3         10 $self->{search_string_orig} = $search_string;
597 3         9 $self->before_search;
598 3         11 $self->log_search;
599              
600 3         7 $self->{results}{count} = 0;
601 3         35 $self->{results}{records} = [];
602 3         9 $self->{results}{lineNumbers} = [];
603              
604 3 50       14 return if $self->{search_string} =~ /^\s*$/; # no query, no results
605              
606 3         25 my $qp = new Search::QueryParser;
607              
608             # compile query with an implicit '+' prefix in front of every item
609 3 50       76 my $parsedQ = $qp->parse($self->{search_string}, '+') or
610             die "error parsing query : $self->{search_string}";
611              
612 3         469 my $filter;
613              
614 3 50       7 eval {$filter = $self->{data}->compileFilter($parsedQ);} or
  3         18  
615             die("error in query : $@ ," . $qp->unparse($parsedQ)
616             . " ($self->{search_string})");
617              
618             # perform the search
619 3         9457 @{$self->{results}}{qw(records lineNumbers)} =
620 3         697 $self->{data}->fetchall(where => $filter);
621 3         6 $self->{results}{count} = @{$self->{results}{records}};
  3         8  
622              
623             # VERY CHEAP way of generating regex for highlighting results
624 3         13 my @words_queried = uniq(grep {length($_)>2} $self->words_queried);
  2         15  
625 3         34 $self->{results}{wordsQueried} = join "|", @words_queried;
626             }
627              
628              
629             #----------------------------------------------------------------------
630             sub before_search {
631             #----------------------------------------------------------------------
632 3     3 1 7 my ($self) = @_;
633 3   50     16 $self->{search_string} = $self->{search_string_orig} || "";
634 3         6 return $self;
635             }
636              
637              
638              
639             #----------------------------------------------------------------------
640             sub sort_and_slice { # sort results, then just keep the desired slice
641             #----------------------------------------------------------------------
642 3     3 1 6 my $self = shift;
643              
644 3         8 delete $self->{results}{lineNumbers}; # not going to use those
645              
646             # sort results
647 3 50       8 if ($self->{orderBy}) {
648 0 0       0 eval {
649 0         0 my $cmpfunc = $self->{data}->ht->cmp($self->{orderBy});
650 0         0 $self->{results}{records} = [sort $cmpfunc @{$self->{results}{records}}];
  0         0  
651             }
652             or die "orderBy : $@";
653             }
654              
655             # restrict to the desired slice
656 3   66     9 my $start_record = $self->param('start') || ($self->{results}{count} ? 1 : 0);
657             my $end_record = min($start_record + $self->{count} - 1,
658 3         42 $self->{results}{count});
659 3 50       9 die "illegal start value : $start_record" if $start_record > $end_record;
660             $self->{results}{records} = $self->{results}{count}
661 3 100       13 ? [ @{$self->{results}{records}}[$start_record-1 ... $end_record-1] ]
  2         8  
662             : [];
663              
664             # check read permission on records (looping over records only if necessary)
665             my $must_loop_on_records # true if permission depends on record fields
666             = (($self->{cfg}->get("permissions_read") || "") =~ /\$/)
667 3   33     27 || (($self->{cfg}->get("permissions_no_read") || "") =~ /\$/);
668 3 50       20 if ($must_loop_on_records) {
669 0         0 foreach my $record (@{$self->{results}{records}}) {
  0         0  
670 0 0       0 $self->can_do('read', $record)
671             or die "no 'read' permission for $self->{user}";
672             }
673             }
674             else { # no need for a loop
675 3 50       8 $self->can_do('read')
676             or die "no 'read' permission for $self->{user}";
677             }
678              
679             # for user display : record numbers start with 1, not 0
680 3         10 $self->{results}{start} = $start_record;
681 3         7 $self->{results}{end} = $end_record;
682              
683              
684             # links to previous/next slice
685 3         6 my $prev_idx = $start_record - $self->{count};
686 3 50       15 $prev_idx = 1 if $prev_idx < 1;
687 3 50       8 $self->{results}{prev_link} = $self->_url_for_next_slice($prev_idx)
688             if $start_record > 1;
689 3         6 my $next_idx = $start_record + $self->{count};
690             $self->{results}{next_link} = $self->_url_for_next_slice($next_idx)
691 3 100       56 if $next_idx <= $self->{results}{count};
692             }
693              
694              
695             #----------------------------------------------------------------------
696             sub _url_for_next_slice {
697             #----------------------------------------------------------------------
698 1     1   3 my ($self, $start) = @_;
699              
700 1         3 my $url = "?" . join "&", $self->params_for_next_slice($start);
701              
702             # uri encoding
703 1         3 $url =~ s/([^;\/?:@&=\$,A-Z0-9\-_.!~*'() ])/sprintf("%%%02X", ord($1))/ige;
  0         0  
704              
705 1         3 return $url;
706             }
707              
708              
709             #----------------------------------------------------------------------
710             sub params_for_next_slice {
711             #----------------------------------------------------------------------
712 1     1 1 3 my ($self, $start) = @_;
713              
714             # need request object to invoke native param() method
715 1         3 my $req = $self->{req};
716              
717 1         5 my @params = ("S=$self->{search_string_orig}", "start=$start");
718 1 50       4 push @params, "orderBy=$self->{orderBy}" if $req->parameters->{orderBy};
719 1 50       9 push @params, "count=$self->{count}" if $req->parameters->{count};
720              
721 1         8 return @params;
722             }
723              
724              
725             #----------------------------------------------------------------------
726             sub words_queried {
727             #----------------------------------------------------------------------
728 3     3 1 6 my $self = shift;
729 3         17 return ($self->{search_string_orig} =~ m([\w/]+)g);
730             }
731              
732              
733              
734             #----------------------------------------------------------------------
735             sub log_search {
736             #----------------------------------------------------------------------
737 3     3 0 5 my $self = shift;
738 3 50       8 return if not $self->{logger};
739              
740 0         0 my $msg = "[$self->{search_string}] $self->{user}";
741 0         0 $self->{logger}->info($msg);
742             }
743              
744              
745             #======================================================================
746             # REQUEST HANDLING : UPDATE METHODS #
747             #======================================================================
748              
749              
750             #----------------------------------------------------------------------
751             sub empty_record { # to be displayed in "modif" view (when adding)
752             #----------------------------------------------------------------------
753 1     1 1 4 my ($self) = @_;
754              
755 1 50       3 $self->can_do("add") or
756             die "no 'add' permission for $self->{user}";
757              
758             # build a record and insert default values
759 1         6 my $record = $self->{data}->ht->new;
760 1         19 my $defaults = $self->{cfg}->get("fields_default");
761 1 50       26 if (my $auto_num = $self->{data}{autoNumField}) {
762 1   33     3 $defaults->{$auto_num} ||= $self->{data}{autoNumChar};
763             }
764 1         4 $record->{$_} = $defaults->{$_} foreach $self->{data}->headers;
765              
766 1         40 $self->{results} = {count => 1, records => [$record], lineNumbers => [-1]};
767             }
768              
769              
770             #----------------------------------------------------------------------
771             sub update {
772             #----------------------------------------------------------------------
773 1     1 1 4 my ($self) = @_;
774              
775             # check if there is one record to update
776 1         4 my $found = $self->{results};
777 1 50       5 $found->{count} == 1 or die "unexpected number of records to update";
778              
779             # gather some info
780 1         5 my $record = $found->{records}[0];
781 1         3 my $line_nb = $found->{lineNumbers}[0];
782 1         4 my $is_adding = $line_nb == -1;
783 1 50       6 my $permission = $is_adding ? 'add' : 'modif';
784              
785             # check if user has permission
786 1 50       5 $self->can_do($permission, $record)
787             or die "No permission '$permission' for $self->{user}";
788              
789             # if adding, must make sure to read all rows so that autonum gets updated
790 1 50 33     7 if ($is_adding && $self->{cfg}->get('fields_autoNum')) {
791 0         0 while ($self->{data}->fetchrow) {}
792             }
793              
794             # call hook before update
795 1         6 $self->before_update($record);
796              
797             # prepare message to user
798 1         6 my @headers = $self->{data}->headers;
799 1         18 my $data_line = join("|", @{$record}{@headers});
  1         10  
800             my ($msg, $id) = $is_adding ? ("Created", $self->{data}{autoNum})
801 1 50       29 : ("Updated", $self->key($record));
802 1         11 $self->{msg} .= "
$msg:
"
803             . "Record $id: $data_line
";
804              
805             # do the update
806 1 50       4 my $to_delete = $is_adding ? 0 # no previous line to delete
807             : 1; # replace previous line
808 1 50       3 eval {$self->{data}->splices($line_nb, $to_delete, $record)} or do {
  1         8  
809 0         0 my $err = $@;
810 0         0 $self->rollback_update($record);
811 0         0 die $err;
812             };
813              
814             # call hook after update
815 1         1785 $self->after_update($record);
816             }
817              
818              
819             #----------------------------------------------------------------------
820             sub before_update { #
821             #----------------------------------------------------------------------
822 1     1 1 4 my ($self, $record) = @_;
823              
824             # copy defined params into record ..
825 1         6 my $key_field = $self->param($self->key_field);
826 1         11 foreach my $field ($self->{data}->headers) {
827 4         26 my $val = $self->param($field);
828 4 50       30 next if not defined $val;
829 0 0 0     0 if ($field eq $key_field and $val ne $self->key($record)) {
830 0         0 die "supplied key $val does not match record key";
831             }
832 0         0 $record->{$field} = $val;
833             }
834              
835             # force username into user field (if any)
836 1         5 my $user_field = $self->{app}{user_field};
837 1 50       4 $record->{$user_field} = $self->{user} if $user_field;
838              
839             # force current time or date into time fields (if any)
840 1         3 while (my ($k, $fmt) = each %{$self->{app}{time_fields}}) {
  1         10  
841 0         0 $record->{$k} = strftime($fmt, localtime);
842             }
843             }
844              
845              
846       1 1   sub after_update {} # override in subclasses
847       0 1   sub rollback_update {} # override in subclasses
848              
849              
850             #======================================================================
851             # REQUEST HANDLING : DELETE METHODS #
852             #======================================================================
853              
854             #----------------------------------------------------------------------
855             sub delete {
856             #----------------------------------------------------------------------
857 1     1 1 2 my $self = shift;
858              
859             # check if there is one record to update
860 1         3 my $found = $self->{results};
861 1 50       5 $found->{count} == 1 or die "unexpected number of records to delete";
862              
863             # gather some info
864 1         2 my $record = $found->{records}[0];
865 1         2 my $line_nb = $found->{lineNumbers}[0];
866              
867             # check if user has permission
868 1 50       3 $self->can_do("delete", $record)
869             or die "No permission 'delete' for $self->{user}";
870              
871             # call hook before delete
872 1         5 $self->before_delete($record);
873              
874             # do the deletion
875 1         5 $self->{data}->splices($line_nb, 1, undef);
876              
877             # message to user
878 1         1044 my @headers = $self->{data}->headers;
879 1         26 my @values = @{$record}{@headers};
  1         10  
880 1         24 $self->{msg} = "Deleted:
" . join("|", @values);
881              
882             # call hook after delete
883 1         4 $self->after_delete($record);
884             }
885              
886              
887       1 1   sub before_delete {} # override in subclasses
888       1 1   sub after_delete {} # override in subclasses
889              
890              
891             #======================================================================
892             # MISCELLANEOUS METHODS #
893             #======================================================================
894              
895              
896              
897             #----------------------------------------------------------------------
898             sub prepare_download {
899             #----------------------------------------------------------------------
900 0     0 1 0 my ($self, $which) = @_;
901 0 0       0 $self->can_do('download')
902             or die "No permission 'download' for $self->{user}";
903             }
904              
905              
906             #----------------------------------------------------------------------
907             sub print_help {
908             #----------------------------------------------------------------------
909 0     0 1 0 print "sorry, no help at the moment";
910             }
911              
912              
913              
914             #----------------------------------------------------------------------
915             sub user_match {
916             #----------------------------------------------------------------------
917 13     13 1 37 my ($self, $access_control_list) = @_;
918              
919             # success if the list contains '*' or the current username
920 13         114 return ($access_control_list =~ /\*|\b\Q$self->{user}\E\b/i);
921             }
922              
923              
924             #----------------------------------------------------------------------
925             sub key_field {
926             #----------------------------------------------------------------------
927 1     1 1 4 my ($self) = @_;
928 1         16 return ($self->{data}->headers)[0];
929             }
930              
931              
932             #----------------------------------------------------------------------
933             sub key { # returns the value in the first field of the record
934             #----------------------------------------------------------------------
935 1     1 1 3 my ($self, $record) = @_;
936              
937             # optimized version, breaking encapsulation of File::Tabular
938 1         6 return (tied %$record)->[1];
939              
940             # going through official API would be : return $record->{$self->key_field};
941             }
942              
943             1;
944              
945              
946             __END__