allow metadata to be defined for new products
[bse.git] / site / cgi-bin / modules / BSE / Request / Base.pm
CommitLineData
70789617
TC
1package BSE::Request::Base;
2use strict;
3use CGI ();
4use BSE::Cfg;
3f9c8a96 5use BSE::Util::HTML;
61138170 6use Carp qw(cluck confess);
70789617 7
0bdcab3b 8our $VERSION = "1.032";
95442846
TC
9
10=head1 NAME
11
12BSE::Request::Base - base class for request objects
13
14=head1 SYNOPSIS
15
16 use BSE::Request;
17 my $req = BSE::Request->new;
18
19=head1 DESCRIPTION
20
21The BSE::Request::Base class provides most of the functionality of
22BSE::Request.
23
24=head1 CONSTRUCTOR
25
26=over
27
28=item new()
29
30Create a new request. Paramaters:
31
32=over
33
34=item *
35
36C<cgi> - provide a custom CGI object. Default: create a CGI.pm object.
37
38=item *
39
40C<cfg> - provide a custom config object. Default: create a BSE::Cfg
41object.
42
43=item *
44
45C<fastcgi> - set to true and supply cgi if this is a FastCGI request.
46
47=item *
48
49C<nodatabase> - skip database initialization.
50
51=item *
52
53C<nosession> - don't allow a session object to be initialized.
54
55=back
56
57=cut
cb7fd78d 58
70789617
TC
59sub new {
60 my ($class, %opts) = @_;
61
d2473dc2
TC
62 $opts{cfg} ||= BSE::Cfg->new;
63
b3dbf74b 64 unless ($opts{nodatabase}) {
f811b4b8 65 require BSE::DB;
b3dbf74b
TC
66 BSE::DB->init($opts{cfg});
67 BSE::DB->startup();
45dd6c96
TC
68 require Squirrel::Table;
69 Squirrel::Table->caching(0);
b3dbf74b 70 }
5ac2ad24 71
a93c4cb8
TC
72 my $self = bless \%opts, $class;
73
74 $opts{cgi} ||= $self->_make_cgi;
8062fbd7 75 $opts{fastcgi} ||= 0;
7c74b5f6 76 $opts{vars} = {};
70789617 77
3f9c8a96 78 return $self;
70789617
TC
79}
80
a93c4cb8
TC
81sub _tracking_uploads {
82 my ($self) = @_;
83 unless (defined $self->{_tracking_uploads}) {
84 my $want_track = $self->cfg->entry("basic", "track_uploads", 0);
85 my $will_track = $self->_cache_available && $want_track;
86 if ($want_track && !$will_track) {
87 print STDERR "** Upload tracking requested but no cache found\n";
88 }
89 $self->{_tracking_uploads} = $will_track;
90 }
91
92 return $self->{_tracking_uploads};
93}
94
95sub _cache_available {
96 my ($self) = @_;
97
98 unless (defined $self->{_cache_available}) {
99 my $cache_class = $self->cfg->entry("cache", "class");
100 $self->{_cache_available} = defined $cache_class;
101 }
102
103 return $self->{_cache_available};
104}
105
106sub _cache_object {
107 my ($self) = @_;
108
109 $self->_cache_available or return;
110 $self->{_cache} and return $self->{_cache};
111
ebc63b18 112 require BSE::Cache;
a93c4cb8 113
ebc63b18 114 $self->{_cache} = BSE::Cache->load($self->cfg);
a93c4cb8
TC
115
116 return $self->{_cache};
117}
118
95442846
TC
119=back
120
121=head1 METHODS
122
123=over
124
125=item cache_set($key, $value)
126
127Set the cache entry $key to $value.
128
129Does nothing if the cache is not configured.
130
131=cut
132
a93c4cb8
TC
133sub cache_set {
134 my ($self, $key, $value) = @_;
135
136 my $cache = $self->_cache_object
137 or return;
138
46a55e1e 139 $cache->set($key, $value);
a93c4cb8
TC
140}
141
95442846
TC
142=item cache_get($key)
143
144Retrieve the cache entry identified by $key.
145
146=cut
147
a93c4cb8
TC
148sub cache_get {
149 my ($self, $key) = @_;
150
151 my $cache = $self->_cache_object
152 or return;
153
46a55e1e 154 return $cache->get($key);
a93c4cb8
TC
155}
156
70789617 157sub _make_cgi {
a93c4cb8
TC
158 my ($self) = @_;
159
46a55e1e 160 my $cache;
a93c4cb8
TC
161 if ($self->_tracking_uploads
162 && $ENV{REQUEST_METHOD} eq 'POST'
78d982ee 163 && $ENV{CONTENT_TYPE}
46a55e1e 164 && $ENV{CONTENT_TYPE} =~ m(^multipart/form-data)
15f30f31 165 && $ENV{CONTENT_LENGTH}
3f9c8a96
TC
166 && $ENV{QUERY_STRING}
167 && $ENV{QUERY_STRING} =~ /^_upload=([a-zA-Z0-9_]+)$/
46a55e1e 168 && defined ($cache = $self->_cache_object)) {
a93c4cb8 169 # very hacky
3f9c8a96
TC
170 my $upload_key = $1;
171 my $fullkey = "upload-$upload_key";
a93c4cb8 172 my $q;
15f30f31 173 my $done = 0;
ec269d0f 174 my $last_set = time();
15f30f31
TC
175 my $complete = 0;
176 eval {
177 $q = CGI->new
178 (
179 sub {
180 my ($filename, $data, $size_so_far) = @_;
3f9c8a96 181
15f30f31
TC
182 $done += length $data;
183 my $now = time;
184 if ($last_set + 1 <= $now) { # just in case we end up loading Time::HiRes
185 $cache->set($fullkey,
186 {
187 done => $done,
188 total => $ENV{CONTENT_LENGTH},
189 filename => $filename,
190 complete => 0
191 });
192 $last_set = $now;
193 }
194 },
195 0, # data for upload hook
196 1, # continue to use temp files
197 {} # start out empty and don't read STDIN
198 );
199
200 $q->init(); # initialize for real cgi
201 $complete = 1;
202 };
203
3f9c8a96
TC
204 if ($complete) {
205 $cache->set($fullkey,
206 {
207 done => $ENV{CONTENT_LENGTH},
208 total => $ENV{CONTENT_LENGTH},
209 complete => 1,
210 });
211 }
212 else {
213 $cache->set($fullkey,
214 {
215 failed => 1,
216 });
217 die;
218 }
219
220 if ($self->utf8) {
221 require BSE::CGI;
222 return BSE::CGI->new($q, $self->charset);
15f30f31 223 }
a93c4cb8
TC
224
225 return $q;
226 }
227
6361fafb
TC
228 my $q = CGI->new;
229 my $error = $q->cgi_error;
230 if ($error) {
231 print STDERR "CGI ERROR: $error\n";
232 }
233
3f9c8a96
TC
234 if ($self->utf8) {
235 require BSE::CGI;
236 return BSE::CGI->new($q, $self->charset);
237 }
238
6361fafb 239 return $q;
70789617
TC
240}
241
95442846
TC
242=item cgi
243
244Return the request's CGI object.
245
246=cut
247
70789617
TC
248sub cgi {
249 return $_[0]{cgi};
250}
251
95442846
TC
252=item cfg
253
254Return the request's cfg object.
255
256=cut
257
70789617
TC
258sub cfg {
259 return $_[0]{cfg};
260}
261
95442846
TC
262=item session
263
264Return the request's session object.
265
266=cut
267
70789617 268sub session {
d37dd861 269 my $self = shift;
70789617 270
d37dd861
TC
271 $self->{session}
272 or $self->_make_session;
273
274 return $self->{session};
70789617
TC
275}
276
95442846
TC
277=item is_fastcgi
278
279return true for a fast CGI request.
280
281=cut
282
8062fbd7
TC
283sub is_fastcgi {
284 $_[0]{fastcgi};
285}
286
95442846
TC
287=item end_request
288
289End the current request.
290
291Must only be called by BSE itself.
292
293=cut
294
70789617
TC
295sub end_request {
296 delete $_[0]{session};
297}
298
95442846
TC
299=item user
300
301Return the currently logged in admin user.
302
303Only valid in administrative templates.
304
305=cut
306
70789617
TC
307sub user {
308 return $_[0]{adminuser};
309}
310
311sub setuser {
312 $_[0]{adminuser} = $_[1];
313}
314
315sub getuser {
316 $_[0]{adminuser};
317}
318
95442846
TC
319=item url($action, $params, $name)
320
321Equivalent to $req->cfg->admin_url($action, $params, $name)
322
323=cut
324
70789617
TC
325sub url {
326 my ($self, $action, $params, $name) = @_;
327
a5093f33 328 return $self->cfg->admin_url($action, $params, $name);
70789617
TC
329}
330
95442846
TC
331=item check_admin_logon()
332
333Used internally to check an admin user is logged on.
334
335=cut
336
70789617
TC
337sub check_admin_logon {
338 my ($self) = @_;
339
340 require BSE::Permissions;
341 return BSE::Permissions->check_logon($self);
342}
343
70789617
TC
344my $site_article =
345 {
346 id => -1,
347 title => "unknown",
348 parentid => 0,
39e87dbd 349 generator => 'BSE::Generate::Article',
70789617
TC
350 level => 0,
351 };
352
95442846
TC
353=item user_can($perm, $object, $msg)
354
355Check if the current admin user can perform action $perm on $object.
356
357$object is an article or an article id.
358
359=cut
360
70789617
TC
361sub user_can {
362 my ($self, $perm, $object, $rmsg) = @_;
363
364 require BSE::Permissions;
365 $object ||= $site_article;
366 $self->{perms} ||= BSE::Permissions->new($self->cfg);
367 if ($self->cfg->entry('basic', 'access_control', 0)) {
368 unless (ref $object) {
e0ed81d7
AO
369 require BSE::TB::Articles;
370 my $art = $object == -1 ? $site_article : BSE::TB::Articles->getByPkey($object);
70789617
TC
371 if ($art) {
372 $object = $art;
373 }
374 else {
375 print STDERR "** Cannot find article id $object\n";
376 require Carp;
377 Carp::cluck "Cannot find article id $object";
378 return 0;
379 }
380 }
381 return $self->{perms}->user_has_perm($self->user, $object, $perm, $rmsg);
382 }
383 else {
384 # some checks need to happen even if we don't want logons
385 return $self->{perms}->user_has_perm({ id=>-1 }, $object, $perm, $rmsg);
386 }
387}
388
389# a stub for now
390sub get_object {
391 return;
392}
393
95442846
TC
394=item access_control
395
396Return true if access control is enabled.
397
398=cut
399
70789617
TC
400sub access_control {
401 $_[0]->{cfg}->entry('basic', 'access_control', 0);
402}
403
95442846 404=item flash($msg, ...)
d2473dc2 405
95442846 406Flash a notice (backward compat).
70789617 407
95442846 408=cut
70789617 409
7c74b5f6
TC
410sub flash {
411 my ($self, @msg) = @_;
412
413 return $self->flash_notice(@msg);
414}
415
95442846
TC
416=item flash_error($msg, ...)
417
418Flash an error message.
419
420=cut
421
13a986ee
TC
422sub flash_error {
423 my ($self, @msg) = @_;
424
7c74b5f6 425 return $self->flashext({ class => "error" }, @msg);
13a986ee
TC
426}
427
95442846
TC
428=item flash_notice($msg, ...)
429
430Flash a notice.
431
432=cut
433
7c74b5f6 434sub flash_notice {
e63c3728
TC
435 my ($self, @msg) = @_;
436
7c74b5f6
TC
437 return $self->flashext({ class => "notice" }, @msg);
438}
439
95442846
TC
440=item flashext(\%opts, $msg, ...)
441
442Flash a message, with options.
443
444Possible options are:
445
446=over
447
448=item *
449
450class - defaults to "notice".
451
452=item *
453
454type - defaults to "text", can also be "html".
455
456=back
457
458The $msg parameter can also be a message id.
459
460=cut
461
7c74b5f6
TC
462sub flashext {
463 my ($self, $opts, @msg) = @_;
464
465 my %entry =
466 (
467 class => $opts->{class} || "notice",
468 type => "text",
469 );
f83119bf 470 if ($msg[0] =~ /^msg:/) {
7c74b5f6
TC
471 $entry{text} = $self->catmsg(@msg);
472 $entry{html} = $self->htmlmsg(@msg);
f83119bf
TC
473 }
474 else {
7c74b5f6
TC
475 $entry{text} = "@msg";
476 $entry{html} = escape_html($entry{text});
f83119bf
TC
477 }
478
e63c3728
TC
479 my @flash;
480 @flash = @{$self->session->{flash}} if $self->session->{flash};
7c74b5f6
TC
481 push @flash, \%entry;
482
e63c3728
TC
483 $self->session->{flash} = \@flash;
484}
485
13a986ee
TC
486sub _str_msg {
487 my ($req, $msg) = @_;
488
489 if ($msg =~ /^(msg:[\w-]+(?:\/[\w-]+)+)(?::(.*))?$/) {
490 my $id = $1;
491 my $params = $2;
492 my @params = defined $params ? split(/:/, $params) : ();
493 $msg = $req->catmsg($id, \@params);
494 }
495
496 return $msg;
497}
498
7c74b5f6
TC
499sub _str_msg_html {
500 my ($req, $msg) = @_;
501
502 if ($msg =~ /^(msg:[\w-]+(?:\/[\w-]+)+)(?::(.*))?$/) {
503 my $id = $1;
504 my $params = $2;
505 my @params = defined $params ? split(/:/, $params) : ();
506 $msg = $req->htmlmsg($id, \@params);
507 }
98e998de
TC
508 else {
509 $msg = escape_html($msg);
510 }
7c74b5f6
TC
511
512 return $msg;
513}
514
95442846
TC
515=item messages($errors)
516
517Retrieve the current set of messages, optionally setting them.
518
519Returns a list of message entries, each with:
520
521=over
522
523=item *
524
525class - error or notice.
526
527=item *
528
529type - the original content type of the message, either "text" or
530"html".
531
532=item *
533
534text - the message as text.
535
536=item *
537
538html - the message as html.
539
540=back
541
542=cut
543
7c74b5f6
TC
544sub messages {
545 my ($self, $errors) = @_;
70789617 546
7c74b5f6
TC
547 my @messages;
548 push @messages, @{$self->{messages}} if $self->{messages};
18aa1655 549 if ($errors and ref $errors && keys %$errors) {
ebc63b18
TC
550 # do any translation needed
551 for my $key (keys %$errors) {
552 my @msgs = ref $errors->{$key} ? @{$errors->{$key}} : $errors->{$key};
553
554 for my $msg (@msgs) {
7c74b5f6 555 $msg = $self->_str_msg($msg);
ebc63b18
TC
556 }
557 $errors->{$key} = ref $errors->{$key} ? \@msgs : $msgs[0];
558 }
559
7c74b5f6 560 my @fields = $self->cgi->param;
70789617 561 my %work = %$errors;
70789617
TC
562 for my $field (@fields) {
563 if (my $entry = delete $work{$field}) {
7c74b5f6
TC
564 push @messages,
565 map +{
566 type => "text",
567 text => $_,
568 class => "error",
569 html => escape_html($_),
570 }, ref($entry) ? grep $_, @$entry : $entry;
70789617
TC
571 }
572 }
573 for my $entry (values %work) {
574 if (ref $entry) {
7c74b5f6
TC
575 push @messages, map
576 +{
577 type => "text",
578 text => $_,
579 class => "error",
580 html => escape_html($_)
581 }, grep $_, @$entry;
70789617
TC
582 }
583 else {
7c74b5f6
TC
584 push @messages,
585 {
586 type => "text",
587 text => $entry,
588 class => "error",
589 html => escape_html($entry),
590 };
70789617
TC
591 }
592 }
59fca225 593 $self->{field_errors} = $errors;
70789617 594 }
18aa1655
TC
595 elsif ($errors && !ref $errors) {
596 push @messages,
597 {
598 type => "text",
599 text => $errors,
600 class => "error",
601 html => escape_html($errors),
602 };
603 }
7c74b5f6
TC
604 if (!$self->{nosession} && $self->session->{flash}) {
605 push @messages, @{$self->session->{flash}};
606 delete $self->session->{flash};
e63c3728 607 }
7c74b5f6
TC
608 if (!@messages && $self->cgi->param('m')) {
609 push @messages, map
610 +{
611 type => "text",
612 text => $self->_str_msg($_),
613 class => "unknown",
614 html => $self->_str_msg_html($_),
615 }, $self->cgi->param("m");
70789617
TC
616 }
617
7c74b5f6
TC
618 my %seen;
619 @messages = grep !$seen{$_->{html}}++, @messages; # don't need duplicates
620
621 $self->{messages} = \@messages;
622
623 return \@messages;
624}
625
95442846
TC
626=item message($errors)
627
628Return the current set of messages as a single string in HTML, with
629C<< <br /> >> separators.
630
631=cut
632
7c74b5f6
TC
633sub message {
634 my ($self, $errors) = @_;
635
636 my $messages = $self->messages($errors);
637
638 return join "<br />",
639 map { $_->{type} eq 'html' ? $_->{text} : escape_html($_->{text}) } @$messages
640}
641
59fca225
TC
642=item field_errors
643
644Return a hash of field errors that have been supplied to
645message()/messages().
646
647=cut
648
649sub field_errors {
650 my ($self) = @_;
651
652 return $self->{field_errors} || {};
653}
654
7c74b5f6
TC
655sub _set_vars {
656 my ($self) = @_;
657
658 require Scalar::Util;
659 $self->{vars}{request} = $self;
660 Scalar::Util::weaken($self->{vars}{request});
661 $self->set_variable(cgi => $self->cgi);
662 $self->set_variable(cfg => $self->cfg);
663 $self->set_variable(assert_dynamic => 1);
2814fdf7
TC
664 unless ($self->{vars}{bse}) {
665 require BSE::Variables;
666 $self->set_variable(bse => BSE::Variables->dyn_variables(request => $self));
667 }
70789617
TC
668}
669
95442846 670=item siteuser
70789617 671
95442846 672Get the currently logged in siteuser.
7c74b5f6 673
95442846 674=cut
70789617
TC
675
676# get the current site user if one is logged on
677sub siteuser {
678 my ($req) = @_;
679
680 ++$req->{siteuser_calls};
681 if (exists $req->{_siteuser}) {
682 ++$req->{siteuser_cached};
683 return $req->{_siteuser};
684 }
685
686 my $cfg = $req->cfg;
687 my $session = $req->session;
b7cadc84 688 require BSE::TB::SiteUsers;
70789617
TC
689 if ($cfg->entryBool('custom', 'user_auth')) {
690 require BSE::CfgInfo;
691 my $custom = BSE::CfgInfo::custom_class($cfg);
692
693 return $custom->siteuser_auth($session, $req->cgi, $cfg);
694 }
695 else {
696 $req->{_siteuser} = undef;
697
698 my $userid = $session->{userid}
699 or return;
b7cadc84 700 my $user = BSE::TB::SiteUsers->getByPkey($userid)
70789617
TC
701 or return;
702 $user->{disabled}
703 and return;
704
705 $req->{_siteuser} = $user;
706
707 return $user;
708 }
709}
710
95442846
TC
711=item validate()
712
713Perform data validation on the current CGI request. Parameters include:
714
715=over
716
717=item *
718
719errors
720
721=item *
722
723fields
724
725=item *
726
727rules
728
729=item *
730
731section
732
733=item *
734
735optional
736
737=back
738
739=cut
740
70789617
TC
741sub validate {
742 my ($req, %options) = @_;
743
744 $options{rules} ||= {};
745
746 require BSE::Validate;
9b3a5df0
TC
747 my %opts =
748 (
749 fields => $options{fields},
750 rules => $options{rules},
751 );
752 exists $options{optional} and $opts{optional} = $options{optional};
753 BSE::Validate::bse_validate
754 (
755 $req->cgi,
756 $options{errors},
757 \%opts,
758 $req->cfg,
759 $options{section}
760 );
70789617
TC
761}
762
95442846
TC
763=item validate_hash(%opts)
764
765Validate data stored in a hash.
766
767Takes an extra parameter over L</validate()>:
768
769=over
770
771=item *
772
773data - a hash reference with the data to validate.
774
775=back
776
777=cut
778
70789617
TC
779sub validate_hash {
780 my ($req, %options) = @_;
781
782 $options{rules} ||= {};
783
9b3a5df0
TC
784 my %opts =
785 (
786 fields => $options{fields},
787 rules => $options{rules},
788 );
789 exists $options{optional} and $opts{optional} = $options{optional};
70789617 790 require BSE::Validate;
9b3a5df0
TC
791 BSE::Validate::bse_validate_hash
792 (
793 $options{data},
794 $options{errors},
795 \%opts,
796 $req->cfg,
797 $options{section}
798 );
70789617
TC
799}
800
95442846
TC
801=item configure_fields(\%fields, $section)
802
803Configure a field hash.
804
805=cut
806
70789617
TC
807sub configure_fields {
808 my ($self, $fields, $section) = @_;
809
810 my $cfg = $self->cfg;
811 require BSE::Validate;
812 my $cfg_fields = BSE::Validate::bse_configure_fields($fields, $cfg, $section);
813
814 for my $name (keys %$fields) {
815 for my $cfg_name (qw/htmltype type width height size maxlength/) {
816 my $value = $cfg->entry($section, "${name}_${cfg_name}");
817 defined $value and $cfg_fields->{$name}{$cfg_name} = $value;
818 }
819 }
820
821 $cfg_fields;
822}
823
81aa5f57
TC
824sub _article_parent {
825 my ($self, $article) = @_;
826
827 my $id = $article->parentid;
828 $id > 0
829 or return;
830
831 $self->{_cached_article} ||= {};
832 my $cache = $self->{_cached_article};
833
834 $cache->{$id}
835 or $cache->{$id} = $article->parent;
836
837 return $cache->{$id};
838}
839
840sub _article_group_ids {
841 my ($self, $article) = @_;
842
843 my $id = $article->id;
844 $self->{_cached_groupids} ||= {};
845 my $cache = $self->{_cached_groupids};
846 $cache->{$id}
847 or $cache->{$id} = [ $article->group_ids ];
848
849 return @{$cache->{$id}};
850}
851
70789617
TC
852sub _have_group_access {
853 my ($req, $user, $group_ids, $membership) = @_;
854
855 if (grep $_ > 0, @$group_ids) {
856 $membership->{filled}
857 or %$membership = map { $_ => 1 } 'filled', $user->group_ids;
858 return 1
859 if grep $membership->{$_}, @$group_ids;
860 }
861 for my $query_id (grep $_ < 0, @$group_ids) {
862 require BSE::TB::SiteUserGroups;
863 my $group = BSE::TB::SiteUserGroups->getQueryGroup($req->cfg, $query_id)
864 or next;
865 my $rows = BSE::DB->single->dbh->selectall_arrayref($group->{sql}, { MaxRows=>1 }, $user->{id});
866 $rows && @$rows
867 and return 1;
868 }
869
870 return 0;
871}
872
873sub _siteuser_has_access {
874 my ($req, $article, $user, $default, $membership) = @_;
875
876 defined $default or $default = 1;
877 defined $membership or $membership = {};
878
1b73ea7e
TC
879 unless ($article) {
880 # this shouldn't happen
881 cluck("_siteuser_has_access() called without an article parameter!");
882 return 0;
883 }
884
81aa5f57 885 my @group_ids = $req->_article_group_ids($article);
70789617
TC
886 if ($article->{inherit_siteuser_rights}
887 && $article->{parentid} != -1) {
888 if (@group_ids) {
889 $user ||= $req->siteuser
890 or return 0;
891 if ($req->_have_group_access($user, \@group_ids, $membership)) {
892 return 1;
893 }
894 else {
81aa5f57 895 return $req->siteuser_has_access($req->_article_parent($article), $user, 0);
70789617
TC
896 }
897 }
898 else {
899 # ask parent
81aa5f57 900 return $req->siteuser_has_access($req->_article_parent($article), $user, $default);
70789617
TC
901 }
902 }
903 else {
904 if (@group_ids) {
905 $user ||= $req->siteuser
906 or return 0;
907 if ($req->_have_group_access($user, \@group_ids, $membership)) {
908 return 1;
909 }
910 else {
911 return 0;
912 }
913 }
914 else {
915 return $default;
916 }
917 }
918}
919
95442846
TC
920=item siteuser_has_access($article)
921
922=item siteuser_has_access($article, $user)
923
924Check if the current or supplied site user has access to the supplied article.
925
926=cut
927
70789617
TC
928sub siteuser_has_access {
929 my ($req, $article, $user, $default, $membership) = @_;
930
931 $user ||= $req->siteuser;
932
933 ++$req->{has_access_total};
934 if ($req->{_siteuser} && $user && $user->{id} == $req->{_siteuser}{id}
935 && exists $req->{_access_cache}{$article->{id}}) {
936 ++$req->{has_access_cached};
937 return $req->{_access_cache}{$article->{id}};
938 }
939
940 my $result = $req->_siteuser_has_access($article, $user, $default, $membership);
941
942 if ($user && $req->{_siteuser} && $user->{id} == $req->{_siteuser}{id}) {
943 $req->{_access_cache}{$article->{id}} = $result;
944 }
945
946 return $result;
947}
948
70789617
TC
949sub DESTROY {
950 my ($self) = @_;
951
952 if ($self->{cache_stats}) {
953 print STDERR "Siteuser cache: $self->{siteuser_calls} Total, $self->{siteuser_cached} Cached\n"
954 if $self->{siteuser_calls};
955 print STDERR "Access cache: $self->{has_access_total} Total, $self->{has_access_cached} Cached\n"
956 if $self->{has_access_total};
957 }
958
959 if ($self->{session}) {
960 undef $self->{session};
961 }
962}
963
964sub set_article {
965 my ($self, $name, $article) = @_;
966
7c74b5f6 967 $self->set_variable($name, $article);
70789617
TC
968 if ($article) {
969 $self->{articles}{$name} = $article;
970 }
971 else {
972 delete $self->{articles}{$name};
973 }
974}
975
976sub get_article {
977 my ($self, $name) = @_;
978
979 exists $self->{articles}{$name}
980 or return;
981
982 my $article = $self->{articles}{$name};
983 if (ref $article eq 'SCALAR') {
984 $article = $$article;
985 }
986 $article
987 or return;
988
989 $article;
990}
991
7c74b5f6
TC
992sub set_variable {
993 my ($self, $name, $value) = @_;
994
995 $self->{vars}{$name} = $value;
996}
997
542722f0
TC
998sub set_variable_class {
999 my ($self, $name, $class) = @_;
1000
1001 require Squirrel::Template;
1002 $self->set_variable($name => Squirrel::Template::Expr::WrapClass->new($class));
1003}
1004
70789617
TC
1005sub text {
1006 my ($self, $id, $default) = @_;
1007
56f87a80 1008 return $self->cfg->entry('messages', $id, $default);
70789617
TC
1009}
1010
1011sub _convert_utf8_cgi_to_charset {
1012 my ($self) = @_;
1013
1014 require Encode;
1015 my $cgi = $self->cgi;
1016 my $workset = $self->cfg->entry('html', 'charset', 'iso-8859-1');
1017 my $decoded = $self->cfg->entry('html', 'cgi_decoded', 1);
1018
1019 # avoids param decoding the data
1020 $cgi->charset($workset);
1021
1022 print STDERR "Converting parameters from UTF8 to $workset\n"
1023 if $self->cfg->entry('debug', 'convert_charset');
1024
1025 if ($decoded) {
1026 # CGI.pm has already converted it from utf8 to perl's internal encoding
1027 # so we just need to encode to the working encoding
1028 # I don't see a reliable way to detect this without configuring it
1029 for my $name ($cgi->param) {
1030 my @values = map Encode::encode($workset, $_), $cgi->param($name);
1031
1032 $cgi->param($name => @values);
1033 }
1034 }
1035 else {
1036 for my $name ($cgi->param) {
1037 my @values = $cgi->param($name);
1038 Encode::from_to($_, $workset, 'utf8') for @values;
1039 $cgi->param($name => @values);
1040 }
1041 }
1042}
1043
1044sub _encode_utf8 {
1045 my ($self) = @_;
1046
1047 my $cgi = $self->cgi;
1048
1049 require Encode;
1050 for my $name ($cgi->param) {
1051 my @values = map Encode::encode('utf8', $_), $cgi->param($name);
1052 $cgi->param($name => @values);
1053 }
1054}
1055
f5505b76
TC
1056sub user_url {
1057 my ($req, $script, $target, @options) = @_;
1058
13a986ee 1059 return $req->cfg->user_url($script, $target, @options);
f5505b76
TC
1060}
1061
95442846 1062=item is_ssl
61138170 1063
95442846 1064Return true if the current request is an SSL request.
61138170 1065
95442846 1066=cut
6bc5006a 1067
95442846
TC
1068sub is_ssl {
1069 exists $ENV{HTTPS} || exists $ENV{SSL_CIPHER};
1070}
6bc5006a 1071
95442846
TC
1072my %recaptcha_errors =
1073 (
1074 'incorrect-captcha-sol' => 'Incorrect CAPTCHA solution',
1075 'recaptcha-not-reachable' => "CAPTCHA server not reachable, please wait a moment and try again",
1076 );
6bc5006a 1077
95442846 1078=item test_recaptcha
6bc5006a 1079
95442846 1080Test if a valid reCAPTCHA response was received.
61138170 1081
95442846 1082=cut
c6fc339f
TC
1083
1084sub test_recaptcha {
1085 my ($self, %opts) = @_;
1086
1087 require Captcha::reCAPTCHA;
1088 my $apiprivkey = $self->cfg->entry('recaptcha', 'api_private_key');
1089 unless (defined $apiprivkey) {
1090 print STDERR "** No recaptcha api_private_key defined **\n";
1091 return;
1092 }
1093 my $msg;
1094 my $error = $opts{error} || \$msg;
1095 my $c = Captcha::reCAPTCHA->new;
1096 my $cgi = $self->cgi;
1097 my $challenge = $cgi->param('recaptcha_challenge_field');
1098 my $response = $cgi->param('recaptcha_response_field');
1099 delete $self->{recaptcha_error};
1100 if (!defined $challenge || $challenge !~ /\S/) {
1101 $$error = "No reCAPTCHA challenge found";
1102 return;
1103 }
1104 if (!defined $response || $response !~ /\S/) {
1105 $$error = "No reCAPTCHA response entered";
1106 return;
1107 }
1108
1109 my $result = $c->check_answer($apiprivkey, $ENV{REMOTE_ADDR},
1110 $challenge, $response);
1111 unless ($result->{is_valid}) {
1112 my $key = 'error_'.$result->{error};
1113 $key =~ tr/-/_/;
1114 $$error = $self->cfg->entry('recaptcha', $key)
1115 || $recaptcha_errors{$result->{error}}
1116 || $result->{error};
1117 }
1118 $self->{recaptcha_result} = $result;
1119
1120 return !!$result->{is_valid};
1121}
1122
1123sub recaptcha_result {
1124 $_[0]{recaptcha_result};
1125}
1126
58baa27b
TC
1127=item get_csrf_token($name)
1128
1129Generate a csrf token for the given name.
1130
1131=cut
1132
1133my $sequence = 0;
1134
1135sub get_csrf_token {
1136 my ($req, $name) = @_;
1137
1138 my $cache = $req->session->{csrfp};
1139 my $max_age = $req->cfg->entry('basic', 'csrfp_max_age', 3600);
1140 my $now = time;
1141
1142 my $entry = $cache->{$name};
1143 if (!$entry || $entry->{time} + $max_age < $now) {
1144 if ($entry) {
1145 $entry->{oldtoken} = $entry->{token};
1146 $entry->{oldtime} = $entry->{time};
1147 }
1148 else {
1149 $entry = {};
1150 }
1151
1152 # this doesn't need to be so perfectly secure that we drain the
1153 # entropy pool and it'll be called fairly often
1154 require Digest::MD5;
1155 $entry->{token} =
1156 Digest::MD5::md5_hex($now . $$ . rand() . $sequence++ . $name);
1157 $entry->{time} = $now;
1158 }
1159 $cache->{$name} = $entry;
1160 $req->session->{csrfp} = $cache;
1161
1162 return $entry->{token};
1163}
1164
1165=item check_csrf($name)
1166
1167Check if the CSRF token supplied by the form is valid.
1168
1169$name should be the name supplied to the csrfp token.
1170
1171=cut
1172
1173sub check_csrf {
1174 my ($self, $name) = @_;
1175
1176 defined $name
1177 or confess "No CSRF token name supplied";
1178
8f42c1c2
TC
1179 $self->is_ajax
1180 and return 1;
1181
58baa27b
TC
1182 my $debug = $self->cfg->entry('debug', 'csrf', 0);
1183
1184 # the form might have multiple submit buttons, each initiating a
1185 # different function, so the the form should supply tokens for every
1186 # function for the form
1187 my @tokens = $self->cgi->param('_csrfp');
1188 unless (@tokens) {
1189 $self->_csrf_error("No _csrfp token supplied");
1190 return;
1191 }
1192
1193 my $entry = $self->session->{csrfp}{$name};
1194 unless ($entry) {
1195 $self->_csrf_error("No token entry found for $name");
1196 return;
1197 }
1198
1199 my $max_age = $self->cfg->entry('basic', 'csrfp_max_age', 3600);
1200 my $now = time;
1201 for my $token (@tokens) {
1202 if ($entry->{token}
1203 && $entry->{token} eq $token
1204 && $entry->{time} + 2*$max_age >= $now) {
1205 $debug
1206 and print STDERR "CSRF: match current token\n";
1207 return 1;
1208 }
1209
1210 if ($entry->{oldtoken}
1211 && $entry->{oldtoken} eq $token
1212 && $entry->{oldtime} + 2*$max_age >= $now) {
1213 return 1;
1214 }
1215 }
1216
1217 $self->_csrf_error("No tokens matched the $name entry");
1218 return;
1219}
1220
1221sub _csrf_error {
1222 my ($self, $message) = @_;
1223
1224 $self->cfg->entry('debug', 'csrf', 0)
1225 and print STDERR "csrf error: $message\n";
1226 $self->{csrf_error} = $message;
1227
1228 return;
1229}
1230
1231sub csrf_error {
1232 $_[0]{csrf_error};
1233}
1234
a0edb02e
TC
1235=item audit(object => $object, action => $action)
1236
1237Simple audit logging.
1238
c925a6af 1239See BSE::TB::AuditLog.
a0edb02e 1240
c925a6af 1241object, component, msg are required.
a0edb02e
TC
1242
1243=cut
1244
1245sub audit {
1246 my ($self, %opts) = @_;
1247
c925a6af 1248 require BSE::TB::AuditLog;
a0edb02e 1249
080fc207 1250 $opts{actor} ||= $self->user || "U";
a0edb02e 1251
c925a6af 1252 return BSE::TB::AuditLog->log(%opts);
a0edb02e
TC
1253}
1254
3f9c8a96
TC
1255sub utf8 {
1256 my $self = shift;
1257 return $self->cfg->utf8;
1258}
1259
1260sub charset {
1261 my $self = shift;
1262 return $self->cfg->charset;
1263}
1264
ebc63b18
TC
1265=item message_catalog
1266
1267Retrieve the message catalog.
1268
1269=cut
1270
1271sub message_catalog {
1272 my ($self) = @_;
1273
1274 unless ($self->{message_catalog}) {
1275 require BSE::Message;
1276 my %opts;
1277 $self->_cache_available and $opts{cache} = $self->_cache_object;
1278 $self->{message_catalog} = BSE::Message->new(%opts);
1279 }
1280
1281 return $self->{message_catalog};
1282}
1283
1284=item catmsg($id)
1285
1286=item catmsg($id, \@params)
1287
1288=item catmsg($id, \@params, $default)
1289
1290=item catmsg($id, \@params, $default, $lang)
1291
1292Retrieve a message from the message catalog, performing substitution.
1293
1294This retrieves the text version of the message only.
1295
1296=cut
1297
1298sub catmsg {
1299 my ($self, $id, $params, $default, $lang) = @_;
1300
1301 defined $lang or $lang = $self->language;
1302 defined $params or $params = [];
1303
1304 $id =~ s/^msg://
1305 or return "* bad message id - missing leading msg: *";
1306
1307 my $result = $self->message_catalog->text($lang, $id, $params, $default);
1308 unless ($result) {
1309 $result = "Unknown message id $id";
1310 }
1311
1312 return $result;
1313}
1314
7c74b5f6
TC
1315=item htmlmsg($id)
1316
1317=item htmlmsg($id, \@params)
1318
1319=item htmlmsg($id, \@params, $default)
1320
1321=item htmlmsg($id, \@params, $default, $lang)
1322
1323Retrieve a message from the message catalog, performing substitution.
1324
1325This retrieves the html version of the message only.
1326
1327=cut
1328
1329sub htmlmsg {
1330 my ($self, $id, $params, $default, $lang) = @_;
1331
1332 defined $lang or $lang = $self->language;
1333 defined $params or $params = [];
1334
1335 $id =~ s/^msg://
1336 or return "* bad message id - missing leading msg: *";
1337
1338 my $result = $self->message_catalog->html($lang, $id, $params, $default);
1339 unless ($result) {
1340 $result = "Unknown message id $id";
1341 }
1342
1343 return $result;
1344}
1345
ebc63b18
TC
1346=item language
1347
1348Fetch the language for the current system/user.
1349
1350Warning: this currently fetches a system configured default, in the
1351future it will use a user default and/or a browser set default.
1352
1353=cut
1354
1355sub language {
1356 my ($self) = @_;
1357
1358 return $self->cfg->entry("basic", "language_code", "en");
1359}
1360
b4b37b81
TC
1361=item ip_address
1362
1363The IP address of the broswer.
1364
1365=cut
1366
a74330a2
TC
1367sub ip_address {
1368 return $ENV{REMOTE_ADDR};
1369}
1370
b4b37b81
TC
1371=item method
1372
1373The request method (post, get etc) in lower case
1374
1375=cut
1376
1377sub method {
1378 return lc $ENV{REQUEST_METHOD};
1379}
1380
2caa9dbc
TC
1381=item user_agent
1382
1383The browser user agent string.
1384
1385=cut
1386
1387sub user_agent {
1388 return $ENV{HTTP_USER_AGENT} || "";
1389}
1390
074f470e
TC
1391=item referer
1392
1393The referer if any.
1394
1395=cut
1396
1397sub referer {
1398 return $ENV{HTTP_REFERER} || "";
1399}
1400
b4b37b81
TC
1401=item cart
1402
1403The user's shopping cart as a L<BSE::Cart> object.
1404
1405=cut
1406
240fb6b6
TC
1407sub cart {
1408 my ($self, $stage) = @_;
1409
1410 require BSE::Cart;
1411 $self->{cart} ||= BSE::Cart->new($self, $stage);
1412
1413 return $self->{cart};
1414}
1415
95442846
TC
1416=back
1417
1418=head2 Page Generation
1419
1420These aren't suitable for use in a template.
1421
1422=over
1423
1424=item template_sets()
1425
1426Return a list of template sets for the current admin user.
1427
1428=cut
1429
1430sub template_sets {
1431 my ($self) = @_;
1432
1433 return () unless $self->access_control;
1434
1435 my $user = $self->user
1436 or return;
1437
1438 return grep $_ ne '', map $_->{template_set}, $user->groups;
1439}
1440
1441=item get_refresh($url)
1442
1443Fetch a refresh result for the given url.
1444
1445=cut
1446
1447sub get_refresh {
1448 my ($req, $url) = @_;
1449
1450 require BSE::Template;
1451 BSE::Template->get_refresh($url, $req->cfg);
1452}
1453
37cc8ef7
TC
1454=item get_def_refresh($url)
1455
1456Fetch a refresh based on the C<r> cgi parameter or the provided url if
1457C<r> isn't set.
1458
1459=cut
1460
1461sub get_def_refresh {
1462 my ($req, $url) = @_;
1463
1464 my $r = $req->cgi->param("r");
1465 $r ||= $url;
1466
1467 return $req->get_refresh($r);
1468}
1469
95442846
TC
1470=item output_result($result)
1471
1472Output a page result.
1473
1474=cut
1475
1476sub output_result {
1477 my ($req, $result) = @_;
1478
1479 require BSE::Template;
1480 BSE::Template->output_result($req, $result);
1481}
1482
1483=item dyn_response($template, $acts, $modifier)
1484
1485=item dyn_response($template, $acts)
1486
1487Generate a page result from template with the given tags.
1488
1489Allows _t or t to specify an alternate template.
1490
1491=cut
1492
1493sub dyn_response {
1494 my ($req, $template, $acts, $modifier) = @_;
1495
1496 my @search = $template;
1497 my $base_template = $template;
1498 my $t = $req->cgi->param('t');
1499 $t or $t = $req->cgi->param('_t');
1500 $t or $t = $modifier;
1501 if ($t && $t =~ /^\w+$/) {
1502 $template .= "_$t";
1503 unshift @search, $template;
1504 }
1505
1506 $req->set_variable(template => $template);
1507 $req->_set_vars();
1508
1509 require BSE::Template;
1510 my @sets;
1511 if ($template =~ m!^admin/!) {
1512 @sets = $req->template_sets;
1513 }
1514
1515 return BSE::Template->get_response($template, $req->cfg, $acts,
329b4e30
TC
1516 $base_template, \@sets, $req->{vars},
1517 dynamic => 1);
95442846
TC
1518}
1519
1520=item response($template, $acts)
1521
1522Return a page response generated from $template and the tags in $acts.
1523
1524=cut
1525
1526sub response {
1527 my ($req, $template, $acts) = @_;
1528
1529 require BSE::Template;
1530 my @sets;
1531 if ($template =~ m!^admin/!) {
1532 @sets = $req->template_sets;
1533 }
1534
1535 $req->set_variable(template => $template);
1536 $req->_set_vars();
1537
1538 return BSE::Template->get_response($template, $req->cfg, $acts,
d31f7436
TC
1539 $template, \@sets, $req->{vars},
1540 dynamic => 1);
95442846
TC
1541}
1542
1543=item dyn_user_tags()
1544
1545Return the standard dynamic page tags.
1546
1547=cut
1548
1549sub dyn_user_tags {
1550 my ($self) = @_;
1551
1552 require BSE::Util::DynamicTags;
1553 return BSE::Util::DynamicTags->new($self)->tags;
1554}
1555
1556=item admin_tags()
1557
1558Return the standard admin page tags.
1559
1560=cut
1561
1562sub admin_tags {
1563 my ($req) = @_;
1564
74b3689a
TC
1565 $req->set_variable
1566 (
1567 auditlog =>
1568 sub {
1569 require BSE::TB::AuditLog;
1570 Squirrel::Template::Expr::WrapClass->new("BSE::TB::AuditLog")
1571 });
1572
95442846
TC
1573 require BSE::Util::Tags;
1574 return
1575 (
1576 BSE::Util::Tags->common($req),
1577 BSE::Util::Tags->admin(undef, $req->cfg),
1578 BSE::Util::Tags->secure($req),
1579 $req->custom_admin_tags,
1580 );
1581}
1582
1583sub custom_admin_tags {
1584 my ($req) = @_;
1585
1586 $req->cfg->entry("custom", "admin_tags")
1587 or return;
1588
1589 require BSE::CfgInfo;
1590
1591 return BSE::CfgInfo::custom_class($req->cfg)->admin_tags($req);
1592}
1593
1594=item is_ajax
1595
1596Return true if the current request is an Ajax request.
1597
1598Warning: changing this code has security concerns, it should only
1599match where the request can only be an Ajax request - if the request
1600can be produced by a normal form/link POST or GET this method must NOT
1601return true.
1602
1603=cut
1604
1605sub is_ajax {
1606 my ($self) = @_;
1607
1608 defined $ENV{HTTP_X_REQUESTED_WITH}
1609 && $ENV{HTTP_X_REQUESTED_WITH} =~ /XMLHttpRequest/
1610 and return 1;
1611
1612 return;
1613}
1614
1615=item want_json_response
1616
1617Return true if the caller has indicated they want a JSON response.
1618
1619In practice, returns true if is_ajax() is true or a _ parameter was
1620supplied.
1621
1622=cut
1623
1624sub want_json_response {
1625 my ($self) = @_;
1626
1627 $self->is_ajax and return 1;
1628
1629 $self->cgi->param("_") and return 1;
1630
1631 return;
1632}
1633
1634=item send_email
1635
1636Send a simple email.
1637
1638=cut
1639
1640sub send_email {
1641 my ($self, %opts) = @_;
1642
1643 my $acts = $opts{acts} || {};
1644 my %acts =
1645 (
1646 $self->dyn_user_tags,
1647 %$acts,
1648 );
1649 if ($opts{extraacts}) {
1650 %acts = ( %acts, %{$opts{extraacts}} );
1651 }
1652 require BSE::ComposeMail;
1653 return BSE::ComposeMail->send_simple
1654 (
1655 %opts,
1656 acts => \%acts
1657 );
1658}
1659
1660=item json_content
1661
1662Generate a hash suitable for output_result() as JSON.
1663
1664=cut
1665
1666sub json_content {
1667 my ($self, @values) = @_;
1668
1669 require JSON;
1670
1671 my $json = JSON->new;
1672
1673 if ($self->utf8) {
1674 $json->utf8;
1675 }
1676
1677 my $value = @values > 1 ? +{ @values } : $values[0];
1678 my ($context) = $self->cgi->param("_context");
1679 if (defined $context) {
1680 $value->{context} = $context;
1681 }
1682
1683 my $json_result =
1684 +{
1685 type => "application/json",
1686 content => $json->encode($value),
1687 };
1688
1689 if (!exists $ENV{HTTP_X_REQUESTED_WITH}
1690 || $ENV{HTTP_X_REQUESTED_WITH} !~ /XMLHttpRequest/) {
1691 $json_result->{type} = "text/plain";
1692 }
1693
1694 return $json_result;
1695}
1696
1697sub field_error {
1698 my ($self, $errors) = @_;
1699
1700 my %errors = %$errors;
1701 for my $key (keys %errors) {
1702 if ($errors{$key} =~ /^msg:/) {
1703 $errors{$key} = $self->_str_msg($errors{$key});
1704 }
1705 }
1706
1707 return $self->json_content
1708 (
1709 success => 0,
1710 error_code => "FIELD",
1711 errors => \%errors,
1712 message => "Fields failed validation",
1713 );
1714}
1715
1716=item logon_error
1717
1718Standard structure of an "admin user not logged on" error returned as
1719JSON content.
1720
1721=cut
1722
1723sub logon_error {
1724 my ($self) = @_;
1725 return $self->json_content
1726 (
1727 success => 0,
1728 error_code => "LOGON",
1729 message => "Access forbidden: user not logged on",
1730 errors => {},
1731 );
1732}
1733
542722f0
TC
1734=item cgi_fields
1735
1736Extract values for the fields specified by the fields parameter.
1737
91edcbb8
TC
1738Field information expected or supported:
1739
1740=over
1741
1742=item *
1743
1744C<htmltype> - if this is checkbox, C<type> is consulted, if C<"int">
1745then set the value based on whether the field is present, otherwise
1746return a concatenation of the values of the checkboxes of that name.
1747
1748=item *
1749
1750C<type> - if C<date> then parse the content as a date.
1751
1752=item *
1753
1754C<api> - if true, don't convert dates from d/m/y to y-m-d, since they
1755should already be that format.
1756
1757=item *
1758
1759C<trim> - for plain text fields, trim leading and trailing whitespace.
1760
2ced88e0
TC
1761=item *
1762
1763C<readonly> - no values are stored.
1764
91edcbb8
TC
1765=back
1766
542722f0
TC
1767=cut
1768
1769sub cgi_fields {
1770 my ($self, %opts) = @_;
1771
1772 my %values;
1773 my $fields = $opts{fields}
1774 or confess "Missing fields parameter";
1775
1776 my $cgi = $self->cgi;
2ced88e0 1777 FIELD:
542722f0
TC
1778 for my $name (keys %$fields) {
1779 my $field = $fields->{$name};
2ced88e0
TC
1780 $field->{readonly}
1781 and next FIELD;
542722f0 1782 my $value;
c29434c9
TC
1783 if ($field->{htmltype} eq "file") {
1784 my $fh = $cgi->upload($name);
1785 my $filename = $cgi->param($name);
1786 if ($fh) {
1787 $value = { fh => $fh, filename => "".$filename };
1788 }
1789 }
1790 elsif ($field->{htmltype} eq "checkbox") {
542722f0
TC
1791 if ($field->{type} eq "int") {
1792 $value = $cgi->param($name) ? 1 : 0;
1793 }
1794 else {
1795 $value = join("", $cgi->param($name));
1796 }
1797 }
023761bd
TC
1798 elsif ($field->{htmltype} eq "multicheck") {
1799 $value = [ $cgi->param($name) ];
1800 }
218b8b70
TC
1801 elsif ($field->{type} && $field->{type} eq "date" && !$opts{api}) {
1802 ($value) = $cgi->param($name);
1803 require DevHelp::Date;
1804 my $msg;
0bdcab3b
TC
1805 if (my ($year, $month, $day) = DevHelp::Date::dh_parse_date($value, \$msg)) {
1806 $value = sprintf("%04d-%02d-%02d", $year, $month, $day);
1807 }
218b8b70 1808 }
cbbdf29f
TC
1809 elsif ($field->{type} && $field->{type} eq "time" && !$opts{api}) {
1810 ($value) = $cgi->param($name);
1811 require DevHelp::Date;
1812 my $msg;
1813 my ($hour, $minute, $sec) = DevHelp::Date::dh_parse_time($value, \$msg);
1814 $value = sprintf("%02d:%02d:%02d", $hour, $minute, $sec);
1815 }
542722f0
TC
1816 else {
1817 ($value) = $cgi->param($name);
1818 defined $name or $value = "";
91edcbb8
TC
1819 if ($field->{trim}) {
1820 $value =~ s/^\s+//;
1821 $value =~ s/\s+\z//;
1822 }
542722f0
TC
1823 }
1824 $values{$name} = $value;
1825 }
1826
1827 return \%values;
1828}
1829
74b3689a
TC
1830=item ip_locked_out
1831
1832Return true if there's an active IP address lockout of the current IP
1833address.
1834
1835=cut
1836
1837sub ip_locked_out {
1838 my ($self, $type) = @_;
1839
1840 require BSE::TB::IPLockouts;
1841 return BSE::TB::IPLockouts->active($self->ip_address, $type);
1842}
1843
70789617 18441;
95442846
TC
1845
1846=back
1847
1848=head1 AUTHOR
1849
1850Tony Cook <tony@develop-help.com>
1851
1852=cut