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