site/cgi-bin/modules/Util.pm

   1 package Util;
   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);
   8 use Constants qw($CONTENTBASE $GENERATE_BUTTON $SHOPID $AUTO_GENERATE);
   9 use Carp qw(confess);
  10 use BSE::WebUtil qw(refresh_to_admin);
  11
  12 # returns non-zero if the Regenerate button should work
  13 sub generate_button {
  14   if ($GENERATE_BUTTON) {
  15     if (my $ref = ref $GENERATE_BUTTON) {
  16       if ($ref eq 'CODE') {
  17         return $GENERATE_BUTTON->();
  18       }
  19       else {
  20         # assumed to be an object
  21         return $GENERATE_BUTTON->want_button();
  22       }
  23     }
  24     else {
  25       return 1;
  26     }
  27   }
  28   return 0;
  29 }
  30
  31 # regenerate an individual article
  32 sub generate_low {
  33   my ($articles, $article, $cfg) = @_;
  34
  35   $cfg ||= BSE::Cfg->new;
  36   my $genname = $article->{generator};
  37   eval "use $genname";
  38   $@ && die $@;
  39   my $gen = $genname->new(articles=>$articles, cfg=>$cfg, top=>$article);
  40
  41   my $outname = $article->{link};
  42   $outname =~ s!/\w*$!!;
  43   $outname =~ s{^\w+://[\w.-]+(?::\d+)?}{};
  44   $outname = $CONTENTBASE . $outname;
  45   $outname =~ s!//+!/!;
  46   my $content = $gen->generate($article, $articles);
  47   my $tempname = $outname . ".work";
  48   unlink $tempname;
  49   open OUT, "> $tempname" or die "Cannot create $tempname: $!";
  50   print OUT $content or die "Cannot write content to $outname: $!";
  51   close OUT or die "Cannot close $outname: $!";
  52   unlink $outname;
  53   rename($tempname, $outname)
  54     or die "Cannot rename $tempname to $outname: $!";
  55 }
  56
  57 sub generate_article {
  58   my ($articles, $article, $cfg) = @_;
  59
  60   while ($article) {
  61     generate_low($articles, $article, $cfg)
  62       if $article->{link} && $article->{template};
  63
  64     if ($article->{parentid} != -1) {
  65       $article = $articles->getByPkey($article->{parentid});
  66     }
  67     else {
  68       undef $article;
  69     }
  70   }
  71 }
  72
  73 # generates search.tmpl from search_base.tmpl
  74 sub generate_search {
  75   my ($articles, $cfg) = @_;
  76
  77   $cfg or confess "Call generate search with a config object";
  78
  79   # build a dummy article
  80   use Constants qw($SEARCH_TITLE $SEARCH_TITLE_IMAGE $CGI_URI);
  81   my %article = map { $_, '' } Article->columns;
  82   @article{qw(id parentid title titleImage displayOrder link level listed)} =
  83     (-1, -1, $SEARCH_TITLE, $SEARCH_TITLE_IMAGE, 0, $CGI_URI."/search.pl", 0, 1);
  84
  85   require 'Generate/Article.pm';
  86   my $gen = Generate::Article->new(cfg=>$cfg, top => \%article);
  87
  88   my %acts;
  89   %acts = $gen->baseActs($articles, \%acts, \%article);
  90   my $content = BSE::Template->get_page('search_base', $cfg, \%acts);
  91   my $tmpldir = $cfg->entryVar('paths', 'templates');
  92   my $outname = "$tmpldir/search.tmpl.work";
  93   my $finalname = "$tmpldir/search.tmpl";
  94   open OUT, "> $outname"
  95     or die "Cannot open $outname for write: $!";
  96   print OUT $content
  97     or die "Cannot write to $outname: $!";
  98   close OUT
  99     or die "Cannot close $outname: $!";
 100   rename $outname, $finalname
 101     or die "Cannot rename $outname to $finalname: $!";
 102 }
 103
 104 sub generate_shop {
 105   my ($articles) = @_;
 106   my @pages =
 107     (
 108      'cart', 'checkout', 'checkoutfinal', 'checkoutcard', 'checkoutconfirm',
 109     );
 110   require 'Generate/Article.pm';
 111   my $shop = $articles->getByPkey($SHOPID);
 112   my $cfg = BSE::Cfg->new;
 113   my $gen = Generate::Article->new(cfg=>$cfg, top=>$shop);
 114   for my $name (@pages) {
 115     my %acts;
 116     %acts = $gen->baseActs($articles, \%acts, $shop);
 117     # different url behaviour - point the user at the http version
 118     # of the site if the url contains no scheme
 119     my $oldurl = $acts{url};
 120     $acts{url} =
 121       sub {
 122         my $value = $oldurl->(@_);
 123         unless ($value =~ /^\w+:/) {
 124           # put in the base site url
 125           $value = $cfg->entryErr('site', 'url').$value;
 126         }
 127         return $value;
 128       };
 129     my $content = BSE::Template->get_page("${name}_base", $cfg, \%acts);
 130     my $tmpldir = $cfg->entryVar('paths', 'templates');
 131     my $outname = "$tmpldir/$name.tmpl.work";
 132     my $finalname = "$tmpldir/$name.tmpl";
 133     open OUT, "> $outname"
 134       or die "Cannot open $outname for write: $!";
 135     print OUT $content
 136       or die "Cannot write to $outname: $!";
 137     close OUT
 138       or die "Cannot close $outname: $!";
 139     unlink $finalname;
 140     rename $outname, $finalname
 141       or die "Cannot rename $outname to $finalname: $!";
 142   }
 143 }
 144
 145 sub generate_extras {
 146   my ($articles, $cfg, $callback) = @_;
 147
 148   use BSE::Cfg;
 149   $cfg ||= BSE::Cfg->new;
 150   my $template_dir = $cfg->entryVar('paths', 'templates');
 151
 152   open EXTRAS, "$template_dir/extras.txt"
 153     or return;
 154   my @extras;
 155   while (<EXTRAS>) {
 156     chomp;
 157     next if /^\s*#/;
 158     if (/^(\S+)\s+(\S+)/) {
 159       push(@extras, [ $1, $2 ]);
 160     }
 161   }
 162   close EXTRAS;
 163   use Generate;
 164   require BSE::Template;
 165   my $gen = Generate->new(cfg=>$cfg);
 166   for my $row (@extras) {
 167     my ($in, $out) = @$row;
 168     $callback->("$in to $out") if $callback;
 169     my %acts;
 170     %acts = $gen->baseActs($articles, \%acts);
 171     my $oldurl = $acts{url};
 172     $acts{url} =
 173       sub {
 174         my $value = $oldurl->(@_);
 175         unless ($value =~ /^\w+:/) {
 176           # put in the base site url
 177           $value = $cfg->entryErr('site', 'url').$value;
 178         }
 179         return $value;
 180       };
 181     my $content = BSE::Template->get_page($in, $cfg, \%acts);
 182     my $outname = $CONTENTBASE . $out . ".work";
 183     my $finalname = $CONTENTBASE . $out;
 184     open OUT, "> $outname"
 185       or die "Cannot open $outname for write: $!";
 186     print OUT $content
 187       or die "Cannot write content to $outname: $!";
 188     close OUT
 189       or die "Cannot close $outname: $!";
 190     unlink $finalname;
 191     rename $outname, $finalname
 192       or die "Cannot rename $outname to $finalname: $!";
 193   }
 194
 195   # more extras
 196   my %entries = $cfg->entries('pregenerate');
 197   if (keys %entries) {
 198     require 'Generate/Article.pm';
 199     for my $out (keys %entries) {
 200       my ($presets, $input) = split ',', $entries{$out}, 2;
 201       $callback->("$input to $out with $presets") if $callback;
 202       my %article = map { $_, '' } Article->columns;
 203       $article{displayOrder} = 1;
 204       $article{id} = -5;
 205       $article{parentid} = -1;
 206       $article{link} = $cfg->entryErr('site', 'url');
 207       for my $field (Article->columns) {
 208         if ($cfg->entry("$presets settings", $field)) {
 209           $article{$field} = $cfg->entryVar("$presets settings", $field);
 210         }
 211       }
 212       my %acts;
 213       my $gen = Generate::Article->new(cfg=>$cfg, top=>\%article);
 214       %acts = $gen->baseActs($articles, \%acts, \%article);
 215       my $oldurl = $acts{url};
 216       $acts{url} =
 217         sub {
 218           my $value = $oldurl->(@_);
 219           unless ($value =~ /^\w+:/) {
 220             # put in the base site url
 221             $value = $cfg->entryErr('site', 'url').$value;
 222           }
 223           return $value;
 224         };
 225       my $content = BSE::Template->get_page($input, $cfg, \%acts);
 226       my $outname = $template_dir .'/'.$out.'.work';
 227       my $finalname = $template_dir . '/'. $out;
 228       open OUT, "> $outname"
 229         or die "Cannot open $outname for write: $!";
 230       print OUT $content
 231         or die "Cannot write content to $outname: $!";
 232       close OUT
 233         or die "Cannot close $outname: $!";
 234       unlink $finalname;
 235       rename $outname, $finalname
 236         or die "Cannot rename $outname to $finalname: $!";
 237     }
 238   }
 239 }
 240
 241 sub generate_all {
 242   my ($articles, $cfg, $callback) = @_;
 243
 244   my @articleids = $articles->allids;
 245   my $pc = 0;
 246   $callback->("Generating articles (".scalar(@articleids)." to do)")
 247     if $callback;
 248   my $index;
 249   my $total = 0;
 250   Squirrel::Table->caching(1);
 251   my $allstart = time;
 252   for my $articleid (@articleids) {
 253     my $article = $articles->getByPkey($articleid);
 254     ++$index;
 255     if ($article->{link} && $article->{template}) {
 256       #$callback->("Article $articleid");
 257       generate_low($articles, $article, $cfg);
 258     }
 259     my $newpc = $index / @articleids * 100;
 260     my $now = time;
 261     if ($callback && $newpc >= $pc + 1 || abs($newpc-100) < 0.01) {
 262       $callback->(sprintf("%5d:  %.1f%% done - elapsed: %.1f", $articleid, $newpc, $now - $allstart)) if $callback;
 263       $pc = int $newpc;
 264     }
 265   }
 266
 267   $callback->("Generating search base") if $callback;
 268   generate_search($articles, $cfg);
 269
 270   $callback->("Generating shop base pages") if $callback;
 271   generate_shop($articles);
 272
 273   $callback->("Generating extra pages") if $callback;
 274   generate_extras($articles, $cfg, $callback);
 275
 276   $callback->("Total of ".(time()-$allstart)." seconds") if $callback;
 277 }
 278
 279 =item regen_and_refresh($articles, $article, $generate, $refreshto, $cfg, $progress)
 280
 281 An error checking wrapper around the page regeneration code.
 282
 283 In some cases IIS appears to lock the static pages, which was causing
 284 various problems.  Here we catch the error and let the user know what
 285 is going on.
 286
 287 If $article is set to undef then everything is regenerated.
 288
 289 $cfg should be an initialized BSE::Cfg object
 290
 291 $progress should be either missing, undef or a code reference.
 292
 293 $generate is typically 1 or $AUTO_GENERATE
 294
 295 Returns 1 if the regeneration was performed successfully.
 296
 297 =cut
 298
 299 sub regen_and_refresh {
 300   my ($articles, $article, $generate, $refreshto, $cfg, $progress) = @_;
 301
 302   if ($generate) {
 303     eval {
 304       if ($article) {
 305         if ($article eq 'extras') {
 306           $progress->("Generating search base") if $progress;
 307           generate_search($articles, $cfg);
 308
 309           $progress->("Generating shop base pages") if $progress  ;
 310           generate_shop($articles);
 311
 312           $progress->("Generating extra pages") if $progress;
 313           generate_extras($articles, $cfg, $progress);
 314         }
 315         else {
 316           generate_article($articles, $article, $cfg);
 317         }
 318       }
 319       else {
 320         generate_all($articles, $cfg, $progress);
 321       }
 322     };
 323     if ($@) {
 324       if ($progress) {
 325         $progress->($@);
 326       }
 327       else {
 328         my $error = $@;
 329         require 'BSE/Util/Tags.pm';
 330         require 'BSE/Template.pm';
 331         my %acts;
 332         %acts =
 333           (
 334            BSE::Util::Tags->basic(\%acts, undef, $cfg),
 335            ifArticle => sub { $article },
 336            article =>
 337            sub {
 338              if (ref $article) {
 339                return CGI::escapeHTML($article->{$_[0]});
 340              }
 341              else {
 342                return 'extras';
 343              }
 344            },
 345            error => sub { CGI::escapeHTML($error) },
 346           );
 347         BSE::Template->show_page('admin/regenerror', $cfg, \%acts);
 348
 349         return 0;
 350       }
 351     }
 352   }
 353
 354   unless ($progress) {
 355     refresh_to_admin($cfg, $refreshto);
 356   }
 357
 358   return 1;
 359 }
 360
 361 1;