the metadata fetcher
[bse.git] / site / cgi-bin / modules / BSE / Variables.pm
1 package BSE::Variables;
2 use strict;
3 use Scalar::Util qw(blessed);
4 use BSE::TB::Site;
5 use BSE::Util::HTML;
6
7 our $VERSION = "1.022";
8
9 sub _base_variables {
10   my ($self, %opts) = @_;
11
12   return
13     (
14      site => BSE::TB::Site->new,
15      articles => \&_articles,
16      products => \&_products,
17      url => 
18      ($opts{admin} || $opts{admin_links}
19       ? sub { _url_common($_[0]->admin, $_[1]) }
20       : sub { _url_common($_[0]->link, $_[1]) }
21      ),
22      abs_url => sub {
23        my ($url) = @_;
24
25        $url =~ /^\w+:/ and return $url;
26
27        return  BSE::Cfg->single->entryErr("site", "url") . $url;
28      },
29      admin => $opts{admin},
30      admin_links => $opts{admin_links},
31      dumper => sub {
32        require Data::Dumper;
33        return escape_html(Data::Dumper::Dumper(shift));
34      },
35      categorize_tags => \&_categorize_tags,
36      date => \&_date_format,
37      now => \&_date_now,
38      number => sub {
39        require BSE::Util::Format;
40        return BSE::Util::Format::bse_number(@_);
41      },
42      debug => sub {
43        print STDERR @_, "\n";
44        return "";
45      },
46      json => sub {
47        require JSON;
48        return JSON->new->allow_nonref->encode($_[0]);
49      },
50      decode_json => sub {
51        require JSON;
52        my $json = JSON->new->utf8;
53        return eval { $json->decode($_[0]) };
54      },
55      report_data => \&_report_data,
56     );
57 }
58
59 sub variables {
60   my ($self, %opts) = @_;
61
62   return
63     +{
64       $self->_base_variables(%opts),
65      };
66 }
67
68 sub dyn_variables {
69   my ($self, %opts) = @_;
70
71   my $req = $opts{request} or die "No request parameter";
72   my $cgi = $req->cgi;
73   return
74     +{
75       $self->_base_variables(%opts),
76       paged => sub { return _paged($cgi, @_) },
77      };
78 }
79
80 sub _url_common {
81   my ($base, $extras) = @_;
82
83   if ($extras && ref $extras) {
84     my @extras;
85     for my $key (keys %$extras) {
86       my $value = $extras->{$key};
87       if (ref $value) {
88         push @extras, map { "$key=" . escape_uri($_) } @$value;
89       }
90       else {
91         push @extras, "$key=" . escape_uri($value);
92       }
93     }
94
95     if (@extras) {
96       $base .= $base =~ /\?/ ? "&" : "?";
97       $base .= join("&", @extras);
98     }
99   }
100
101   return $base;
102 }
103
104 sub _categorize_tags {
105   my ($tags, $selected_tags, $opts) = @_;
106
107   require BSE::TB::Articles;
108
109   if ($opts && $opts->{members} && !$opts->{counts}) {
110     my %counts;
111     my %tags = map { $_->id => $_->name } @$tags;
112     for my $entry (@{$opts->{members}}) {
113       ++$counts{$tags{$entry->tag_id}};
114     }
115     $opts->{counts} = \%counts;
116   }
117
118   return BSE::TB::Articles->categorize_tags($tags, $selected_tags, $opts);
119 }
120
121 sub _paged {
122   my ($cgi, $list, $opts) = @_;
123
124   $opts ||= {};
125   my $ppname = $opts->{ppname} || "pp";
126   my $pp = $cgi->param($ppname) || $opts->{pp} || 20;
127   my $pname = $opts->{pname} || "p";
128   my $p = $cgi->param($pname) || 1;
129   $p =~ /\A[0-9]+\z/ or $p = 1;
130
131   my $pcount = @$list ? int((@$list + $pp - 1) / $pp) : 1;
132
133   $p > $pcount and $p = $pcount;
134   my $startindex = ($p - 1 ) * $pp;
135   my $endindex = $startindex + $pp - 1;
136   $endindex > $#$list and $endindex = $#$list;
137
138   my @pages;
139   my $gap_name = $opts->{gap} || "...";
140   my $gap = { page => $gap_name, link => 0, gap => 1 };
141   my $pages_size = $opts->{pages_size} || 20;
142   my $bcount = int(($pages_size - 1) * 2 / 3);
143   if ($pcount <= $pages_size) {
144     @pages = map +{ page => $_, gap => 0, link => $_ != $p }, 1 .. $pcount;
145   }
146   elsif ($p < $bcount) {
147     @pages =
148       (
149        ( map +{ page => $_, gap => 0, link => $_ != $p }, 1 .. $bcount ),
150        $gap,
151        ( map +{ page => $_, gap => 0, link => 1 },
152          ($pcount - ($pages_size - $bcount) + 1) .. $pcount ),
153       );
154   }
155   elsif ($p > $pcount - int($pages_size * 2 / 3)) {
156     @pages =
157       (
158        ( map +{ page => $_, gap => 0, link => 1 },
159          1 .. ($pages_size - 1 - $bcount)),
160        $gap,
161        ( map +{ page => $_, gap => 0, link => $_ != $p },
162          ( $pcount - $bcount + 1 ) .. $pcount )
163       );
164   }
165   else {
166     my $ends = int(($pages_size - 2) / 4);
167     my $mid_size = $pages_size - 2 - $ends * 2;
168     my $mid_start = $p - int($mid_size / 2);
169     my $mid_end = $mid_start + $mid_size - 1;
170     @pages = 
171       (
172        ( map +{ page => $_, gap => 0, link => 1 }, 1 .. $ends ),
173        $gap,
174        ( map +{ page => $_, gap => 0, link => $_ != $p },
175          $mid_start .. $mid_end ),
176        $gap,
177        ( map +{ page => $_, gap => 0, link => 1 },
178          $pcount - $ends + 1 .. $pcount ),
179       );
180   }
181
182   return
183     {
184      page => $p,
185      pp => $pp,
186      pagecount => $pcount,
187      start => $startindex,
188      end => $endindex,
189      startnum => $startindex + 1,
190      items => [ @{$list}[$startindex .. $endindex ] ],
191      is_first_page => $p == 1,
192      is_last_page => $p == $pcount,
193      next_page => ( $p < $pcount ? $p + 1 : 0 ),
194      previous_page => ($p > 1 ? $p - 1 : 0 ),
195      pages => \@pages,
196      pname => $pname,
197      ppname => $ppname,
198     };
199 }
200
201 sub _variable_class {
202   my ($class) = @_;
203
204   require Squirrel::Template;
205   return Squirrel::Template::Expr::WrapClass->new($class);
206 }
207
208 {
209   my $articles;
210   sub _articles {
211     unless ($articles) {
212       require BSE::TB::Articles;
213       $articles = _variable_class("BSE::TB::Articles");
214     }
215
216     return $articles;
217   }
218 }
219
220 {
221   my $products;
222   sub _products {
223     unless ($products) {
224       require BSE::TB::Products;
225       $products = _variable_class("BSE::TB::Products");
226     }
227
228     return $products;
229   }
230 }
231
232 # format an SQL format date
233 sub _date_format {
234   my ($format, $date) = @_;
235
236   my ($year, $month, $day, $hour, $min, $sec) = 
237     $date =~ /^\s*(\d+)-(\d+)\D+(\d+)(?:\D+(\d+)\D+(\d+)\D+(\d+))?/;
238   unless (defined $year) {
239     ($hour, $min, $sec) = $date =~ /^(\d+)\D+(\d+)\D+(\d+)/;
240
241     # values that won't make strftime crazy
242     ($year, $month, $day) = ( 2000, 1, 1 );
243   }
244   $hour = $min = $sec = 0 unless defined $sec;
245   $year -= 1900;
246   --$month;
247   # passing the isdst as 0 seems to provide a more accurate result than
248   # -1 on glibc.
249   require DevHelp::Date;
250   return DevHelp::Date::dh_strftime($format, $sec, $min, $hour, $day, $month, $year, -1, -1, -1);
251 }
252
253 sub _date_now {
254   my ($fmt) = @_;
255
256   $fmt ||= "%d-%b-%Y";
257   require DevHelp::Date;
258   return DevHelp::Date::dh_strftime($fmt, localtime);
259 }
260
261 sub _report_data {
262   my ($report_name, $params, $opts) = @_;
263
264   $params ||= [];
265   $opts ||= {};
266   require BSE::Report;
267   my $reports = BSE::Report->new(BSE::Cfg->single);
268   my $msg;
269   my $result = $reports->report_data
270     (
271      $report_name,
272      BSE::DB->single,
273      \$msg,
274      $params,
275      %$opts
276     )
277       or return $msg;
278
279   return $result;
280 }
281
282 1;
283
284 =head1 NAME
285
286 BSE::Variables - commonly set variables
287
288 =head1 SYNOPSIS
289
290   # in perl code
291   require BSE::Variables;
292   $foo->set_variable(bse => BSE::Variables->variables(%opts));
293
294   # in templates
295   <:.set level1 = bse.site.children :>
296   <:= bse.url(article) | html :>
297   <:= tagcats = bse.categorize_tags(article.tag_objects) :>
298   <:.if bse.admin:>...
299   <:= bse.dumper(somevar) :> lots of noise
300
301 =head1 DESCRIPTION
302
303 Common BSE functionality for use from the new template tags.
304
305 =head1 COMMON VALUES
306
307 =over
308
309 =item bse.site
310
311 a BSE::TB::Site object, behaves like an article in owning files and
312 images, and having children.
313
314 =item bse.url(somearticle)
315
316 =item bse.url(somearticle, extraargs)
317
318 Return the article admin link in admin (or admin_links) mode,
319 otherwise the normal article link.
320
321 If supplied, C<extraargs> should be a hash containing extra arguments.
322
323 =item bse.abs_url(url)
324
325 Return an absolute form of C<url>.  This is always relative to the main site url.
326
327 =item bse.admin
328
329 Return true in admin mode.
330
331 =item bse.admin_links
332
333 Return true in admin_links mode
334
335 =item bse.json(data)
336
337 Return C<data> as JSON.  This will fail for perl objects.
338
339 =item bse.decode_json(data)
340
341 Decode JSON into a data structure.  This requires binary data.
342
343 =item dumper(value)
344
345 Dump the value in perl syntax using L<Data::Dumper>.
346
347 =item categorize_tags(tags)
348
349 Returns the given tags as a list of tag categories, each category has
350 a name (of the category) and a list of tags in that category.
351
352 =item articles
353
354 =item products
355
356 The article and product collections.
357
358 =item date(format, when)
359
360 Format an SQL date/time.
361
362 =item now(format)
363
364 Format the current date/time.
365
366 =item number(format, value)
367
368 Format I<value> according to the rules defied by I<format> in the
369 config file.  See L<BSE::Util::Format/bse_number> for details.
370
371 =back
372
373 =head1 DYNAMIC ONLY VARIABLES
374
375 =over
376
377 =item bse.pages(list)
378
379 =item bse.pages(list, options)
380
381 Paginate the contents of C<list>.
382
383 If C<options> is supplied it should be a hash optionally containing
384 any of the following keys:
385
386 =over
387
388 =item *
389
390 C<ppname> - the name of the items per page CGI parameter.  Default:
391 "pp".
392
393 =item *
394
395 C<pp> - the default number of items per page.  Default: 20.
396
397 =item *
398
399 C<p> - the name of the page number CGI parameter.  Default: "p".
400
401 =item *
402
403 C<gap> - the text for the C<page> value in the page list for gap
404 entries.  Default: "...".
405
406 =item *
407
408 C<pages_size> - the desired maximum number of entries in the pages
409 list.  Default: 20.  This should be at least 10.
410
411 =back
412
413 Returns a hash with the following keys:
414
415 =over
416
417 =item *
418
419 page - the current page number
420
421 =item *
422
423 pagecount - the number of pages.
424
425 =item *
426
427 pp - the number of items per page.
428
429 =item *
430
431 start - the start index within the original list for the items list.
432
433 =item *
434
435 end - the end index within the original list for the items list.
436
437 =item *
438
439 startnum - the starting number within the list for the items list.
440 Always C<startindex>+1.
441
442 =item *
443
444 items - a list of items for the current page.
445
446 =item *
447
448 is_first_page - true for the first page.
449
450 =item *
451
452 is_last_page - true for the last page.
453
454 =item *
455
456 next_page - the page number of the next page, 0 if none.
457
458 =item *
459
460 previous_page - the page number of the previous page, 0 if none.
461
462 =item *
463
464 pages - a list of pages, each with the keys:
465
466 =over
467
468 =item *
469
470 page - the page number or the gap value if this entry represents a
471 gap.
472
473 =item *
474
475 gap - true if this entry is a gap.
476
477 =item *
478
479 link - true if this entry should be a link.  false for gaps and the
480 current page.
481
482 =back
483
484 =item *
485
486 pname - the name of the page number parameter
487
488 =item *
489
490 ppname - the name of the items per page parameter
491
492 =back
493
494 =back
495
496 =head1 AUTHOR
497
498 Tony Cook <tony@develop-help.com>
499
500 =cut