site/cgi-bin/modules/BSE/Regen.pm

   1 package BSE::Regen;
   2 use strict;
   3 use vars qw(@ISA @EXPORT_OK);
   4 require Exporter;
   5 @ISA = qw(Exporter);
   6 @EXPORT_OK = qw(generate_article generate_all generate_button
   7                 regen_and_refresh generate_extras pregenerate_list generate_one_extra generate_base content_one_extra response_one_extra);
   8 use Constants qw($GENERATE_BUTTON $SHOPID $AUTO_GENERATE);
   9 use Carp qw(confess);
  10 use BSE::WebUtil qw(refresh_to_admin);
  11 use BSE::Util::HTML;
  12 use BSE::DummyArticle;
  13
  14 our $VERSION = "1.015";
  15
  16 # returns non-zero if the Regenerate button should work
  17 sub generate_button {
  18   if ($GENERATE_BUTTON) {
  19     if (my $ref = ref $GENERATE_BUTTON) {
  20       if ($ref eq 'CODE') {
  21         return $GENERATE_BUTTON->();
  22       }
  23       else {
  24         # assumed to be an object
  25         return $GENERATE_BUTTON->want_button();
  26       }
  27     }
  28     else {
  29       return 1;
  30     }
  31   }
  32   return 0;
  33 }
  34
  35 # regenerate an individual article
  36 sub generate_low {
  37   my ($articles, $article, $cfg) = @_;
  38
  39   $cfg ||= BSE::Cfg->single;
  40
  41   my $outname;
  42   if ($article->is_dynamic) {
  43     my $debug_jit = $cfg->entry('debug', 'jit_dynamic_regen');
  44     $outname = $article->cached_filename($cfg);
  45     if ($article->{flags} !~ /R/ &&
  46         $cfg->entry('basic', 'jit_dynamic_pregen')) {
  47       $debug_jit and print STDERR "JIT: $article->{id} - deleting $outname\n";
  48       # just delete the file, page.pl will make it if needed
  49       unlink $outname;
  50       return;
  51     }
  52   }
  53   else {
  54     $outname = $article->link_to_filename($cfg)
  55       or return; # no output for this article
  56   }
  57
  58   if ($article->flags =~ /P/ && $article->{parentid} != -1) {
  59     # link to parent, remove the file
  60     unlink $outname;
  61     return;
  62   }
  63
  64   unless ($article->should_generate) {
  65     # don't generate unlisted pages and remove any old content
  66     unlink $outname;
  67     return;
  68   }
  69
  70   my $genname = $article->{generator};
  71   eval "use $genname";
  72   $@ && die $@;
  73   my $gen = $genname->new(articles=>$articles, cfg=>$cfg, top=>$article);
  74
  75   my $content = $gen->generate($article, $articles);
  76   my $tempname = $outname . ".work";
  77   unlink $tempname;
  78   _write_text($tempname, $content, $cfg);
  79   unlink $outname;
  80   rename($tempname, $outname)
  81     or die "Cannot rename $tempname to $outname: $!";
  82 }
  83
  84 sub generate_article {
  85   my ($articles, $article, $cfg) = @_;
  86
  87   while ($article) {
  88     generate_low($articles, $article, $cfg)
  89       if $article->{link} && $article->{template};
  90
  91     if ($article->{parentid} != -1) {
  92       $article = $articles->getByPkey($article->{parentid});
  93     }
  94     else {
  95       undef $article;
  96     }
  97   }
  98 }
  99
 100 sub _cfg_presets {
 101   my ($cfg, $article, $type) = @_;
 102
 103   my $section = "$type settings";
 104
 105   require BSE::TB::Articles;
 106   for my $field (BSE::TB::Article->columns) {
 107     if ($cfg->entry($section, $field)) {
 108       $article->{$field} = $cfg->entryVar($section, $field);
 109     }
 110   }
 111 }
 112
 113 sub _search_presets {
 114   my ($cfg) = @_;
 115
 116   # build a dummy article
 117   use Constants qw($SEARCH_TITLE $SEARCH_TITLE_IMAGE $CGI_URI);
 118   require BSE::TB::Articles;
 119   my %article = map { $_, '' } BSE::TB::Article->columns;
 120   @article{qw(id parentid title titleImage displayOrder link level listed force_dynamic)} =
 121     (-4, -1, $SEARCH_TITLE, $SEARCH_TITLE_IMAGE, 0, $CGI_URI."/search.pl", 0, 1, 1);
 122
 123   $article{link} = $cfg->entryErr('site', 'url') . $article{link};
 124
 125   _cfg_presets($cfg, \%article, "search");
 126
 127   return _dummy_article(\%article);
 128 }
 129
 130 sub _shop_presets {
 131   my ($cfg) = @_;
 132
 133   require BSE::TB::Articles;
 134   my $shop_base = BSE::TB::Articles->getByPkey($SHOPID);
 135   my $shop = { map { $_ => $shop_base->{$_} } $shop_base->columns };
 136   $shop->{link} =~ /^\w+:/
 137     or $shop->{link} = $cfg->entryErr('site', 'url') . $shop->{link};
 138   $shop->{id} = -3; # some random negative number
 139
 140   _cfg_presets($cfg, $shop, "shop");
 141
 142   return _dummy_article($shop);
 143 }
 144
 145 sub _extras_presets {
 146   my ($cfg, $presets) = @_;
 147
 148   require BSE::TB::Articles;
 149   my %article = map { $_, '' } BSE::TB::Article->columns;
 150   $article{displayOrder} = 1;
 151   $article{id} = -5;
 152   $article{parentid} = -1;
 153   $article{link} = $cfg->entryErr('site', 'url');
 154   _cfg_presets($cfg, \%article, $presets);
 155
 156   return _dummy_article(\%article);
 157 }
 158
 159 my %builtin_extras =
 160   (
 161    search => [ "search" ],
 162    shop =>
 163    [
 164     'cart', 'checkoutnew', 'checkoutfinal',
 165     'checkoutpay',
 166    ],
 167   );
 168
 169 my %abs_urls =
 170   (
 171    shop => 1,
 172    search => 0,
 173   );
 174
 175 my %builtin_lookup;
 176
 177 {
 178   for my $type (keys %builtin_extras) {
 179     for my $name (@{$builtin_extras{$type}}) {
 180       $builtin_lookup{$name} = $type;
 181     }
 182   }
 183 }
 184
 185 sub _extras_cfg {
 186   my ($cfg, $extra) = @_;
 187
 188   my %result;
 189   if ($builtin_extras{$extra->{set}}) {
 190     $result{abs_urls} = $abs_urls{$extra->{set}};
 191   }
 192   else {
 193     $result{abs_urls} = $cfg->entry("$extra->{type} settings", "abs_urls", 0);
 194   }
 195
 196   return \%result;
 197 }
 198
 199 sub pregenerate_list {
 200   my ($cfg) = @_;
 201
 202   my $template_dir = $cfg->entryVar('paths', 'templates');
 203
 204   # this will change to a directory that can be safely blown away
 205   my $pregen_path = $template_dir;
 206
 207   my @result =
 208     (
 209      (
 210       map
 211       +{
 212         name => "$_.tmpl",
 213         base => $_ . "_base.tmpl",
 214         type => $builtin_lookup{$_},
 215         set => $builtin_lookup{$_},
 216         sort => 0,
 217         outpath => $pregen_path,
 218         abs_urls => $abs_urls{$builtin_lookup{$_}},
 219         dynamic => 1,
 220        }, keys %builtin_lookup
 221      ),
 222     );
 223
 224   # cfg pregen
 225   my %pregen = $cfg->entries('pregenerate');
 226   for my $out (keys %pregen) {
 227     my ($type, $input) = split ',', $pregen{$out}, 2;
 228     push @result,
 229       +{
 230         name => $out,
 231         base => $input,
 232         type => $type,
 233         set => "pregen",
 234         sort => 1,
 235         outpath => $pregen_path,
 236         dynamic => 1,
 237        };
 238   }
 239
 240   # extras file
 241   if (open my $extras, "$template_dir/extras.txt") {
 242     while (<$extras>) {
 243       chomp;
 244       next if /^\s*#/;
 245       if (/^(\S+)\s+(\S+)/) {
 246         push @result,
 247           {
 248            name => $2,
 249            base => $1,
 250            type => "extras",
 251            set => "extras",
 252            sort => 2,
 253            outpath => $cfg->content_base_path,
 254            dynamic => 0,
 255           };
 256       }
 257     }
 258     close $extras;
 259   }
 260
 261   return sort {
 262     $a->{sort} <=> $b->{sort}
 263       || $a->{set} cmp $b->{set}
 264         || $a->{type} cmp $b->{type}
 265           || lc $a->{name} cmp lc $b->{name}
 266     } @result;
 267 }
 268
 269 sub _make_extra_art {
 270   my ($cfg, $extra) = @_;
 271
 272   if ($extra->{set} eq "shop") {
 273     return _shop_presets($cfg);
 274   }
 275   elsif ($extra->{set} eq "search") {
 276     return _search_presets($cfg);
 277   }
 278   elsif ($extra->{set} eq "pregen"
 279          || $extra->{set} eq "extras") {
 280     return _extras_presets($cfg, $extra->{type});
 281   }
 282   else {
 283     confess "Unknown extras set $extra->{set}";
 284   }
 285 }
 286
 287 sub _make_extra_gen {
 288   my ($cfg, $extra) = @_;
 289
 290   my $article = _make_extra_art($cfg, $extra);
 291   require BSE::Generate::Article;
 292   my %opts =
 293     (
 294      cfg => $cfg,
 295      top => $article,
 296     );
 297   if ($extra->{dynamic}) {
 298     $opts{force_dynamic} = 1;
 299   }
 300   require BSE::Generate::Article;
 301   my $gen = BSE::Generate::Article->new(%opts);
 302
 303   return ($article, $gen);
 304 }
 305
 306 sub _common_one_extra {
 307   my ($articles, $extra, $cfg) = @_;
 308
 309   my ($article, $gen) = _make_extra_gen($cfg, $extra);
 310   my %acts;
 311   %acts = $gen->baseActs($articles, \%acts, $article);
 312   if (_extras_cfg($cfg, $extra)->{abs_urls}) {
 313     my $oldurl = $acts{url};
 314     $acts{url} =
 315       sub {
 316         my $value = $oldurl->(@_);
 317         $value =~ /^<:/ and return $value;
 318         unless ($value =~ /^\w+:/) {
 319           # put in the base site url
 320           $value = $cfg->entryErr('site', 'url').$value;
 321         }
 322         return $value;
 323       };
 324   }
 325
 326   my $content = BSE::Template->get_page($extra->{base}, $cfg, \%acts,
 327                                         undef, undef, $gen->variables);
 328
 329   return wantarray ? ( $content, $article ) : $content;
 330 }
 331
 332 sub response_one_extra {
 333   my ($articles, $extra) = @_;
 334
 335   my $cfg = BSE::Cfg->single;
 336   my $content = _common_one_extra($articles, $extra, $cfg);
 337
 338   return BSE::Template->make_response($content, BSE::Template->get_type($cfg, $extra->{template}));
 339 }
 340
 341 sub content_one_extra {
 342   my ($articles, $extra) = @_;
 343
 344   my $cfg = BSE::Cfg->single;
 345   return _common_one_extra($articles, $extra, $cfg);
 346 }
 347
 348 sub generate_one_extra {
 349   my ($articles, $extra) = @_;
 350
 351   my $cfg = BSE::Cfg->single;
 352   my $content = _common_one_extra($articles, $extra, $cfg);
 353   my $outname = $extra->{outpath} . "/". $extra->{name};
 354   my $workname = $outname . ".work";
 355   _write_text($workname, $content, $cfg);
 356   unlink $outname;
 357   rename $workname, $outname
 358     or die "Cannot rename $workname to $outname: $!";
 359 }
 360
 361 sub generate_base {
 362   my %opts = @_;
 363
 364   my $cfg = delete $opts{cfg} || BSE::Cfg->single;
 365
 366   my $articles = delete $opts{articles} || "BSE::TB::Articles";
 367   my $extras = delete $opts{extras} || [ pregenerate_list($cfg) ];
 368
 369   my $progress = delete $opts{progress} || sub {};
 370
 371   my @extras = sort
 372     {
 373       $a->{sort} <=> $b->{sort}
 374         || $a->{type} cmp $b->{type}
 375           || lc $a->{name} cmp lc $b->{name}
 376     } @$extras;
 377
 378   my $count = @extras;
 379   $progress->({ type => "extras", count => $count, info => "count" }, "$count base pages");
 380   my $set = "";
 381   my $type = "";
 382   my ($gen, $article);
 383   my %acts;
 384   for my $extra (@extras) {
 385     if ($extra->{set} ne $set || $extra->{type} ne $type) {
 386       ($article, $gen) = _make_extra_gen($cfg, $extra);
 387       %acts = $gen->baseActs($articles, \%acts, $article);
 388       if (_extras_cfg($cfg, $extra)->{abs_urls}) {
 389         my $oldurl = $acts{url};
 390         $acts{url} =
 391           sub {
 392             my $value = $oldurl->(@_);
 393             $value =~ /^<:/ and return $value;
 394             unless ($value =~ /^\w+:/) {
 395               # put in the base site url
 396               $value = $cfg->entryErr('site', 'url').$value;
 397             }
 398             return $value;
 399           };
 400       }
 401       $progress->($extra, "Generating $extra->{name}");
 402       my $content = BSE::Template->get_page($extra->{base}, $cfg, \%acts,
 403                                             undef, undef, $gen->variables);
 404       my $outname = $extra->{outpath} . "/". $extra->{name};
 405       my $workname = $outname . ".work";
 406       _write_text($workname, $content, $cfg);
 407       unlink $outname;
 408       rename $workname, $outname
 409         or die "Cannot rename $workname to $outname: $!";
 410     }
 411   }
 412 }
 413
 414 sub generate_all {
 415   my ($articles, $cfg, $callback) = @_;
 416
 417   my @articleids = $articles->allids;
 418   my $pc = 0;
 419   $callback->("Generating articles (".scalar(@articleids)." to do)")
 420     if $callback;
 421   my $index;
 422   my $total = 0;
 423   Squirrel::Table->caching(1);
 424   my $allstart = time;
 425   for my $articleid (@articleids) {
 426     my $article = $articles->getByPkey($articleid);
 427     ++$index;
 428     my $newpc = $index / @articleids * 100;
 429     my $now = time;
 430     if ($callback && $newpc >= $pc + 1 || abs($newpc-100) < 0.01) {
 431       $callback->(sprintf("%5d:  %.1f%% done - elapsed: %.1f", $articleid, $newpc, $now - $allstart)) if $callback;
 432       $pc = int $newpc;
 433     }
 434     if ($article->{link} && $article->{template}) {
 435       #$callback->("Article $articleid");
 436       generate_low($articles, $article, $cfg);
 437     }
 438   }
 439
 440   my $last_section = "";
 441   my $progress = $callback ? sub {
 442     my $data = shift;
 443     if (!$data->{count} && $data->{set} ne $last_section) {
 444       $callback->("Regenerating $data->{set} pages");
 445       $last_section = $data->{set};
 446     }
 447     $callback->("  @_")
 448   } : undef;
 449   generate_base(cfg => $cfg, articles => $articles, progress => $progress);
 450
 451   $callback->("Total of ".(time()-$allstart)." seconds") if $callback;
 452 }
 453
 454 sub _write_text {
 455   my ($filename, $data, $cfg) = @_;
 456
 457   open my $fh, ">", $filename
 458     or die "Cannot create $filename: $!";
 459   if ($cfg->utf8) {
 460     my $charset = $cfg->charset;
 461     binmode $fh,  ":encoding($charset)";
 462   }
 463   print $fh $data
 464     or die "Cannot write $filename: $!";
 465   close $fh
 466     or die "Cannot close $filename: $!";
 467 }
 468
 469 sub _dummy_article {
 470   my ($data) = @_;
 471
 472   return bless $data, "BSE::DummyArticle";
 473 }
 474
 475 1;