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

   1 package BSE::SubscriptionType;
   2 use strict;
   3 # represents a subscription type from the database
   4 use Squirrel::Row;
   5 use vars qw/@ISA/;
   6 @ISA = qw/Squirrel::Row/;
   7
   8 our $VERSION = "1.008";
   9
  10 sub columns {
  11   return qw/id name title description frequency keyword archive
  12             article_template html_template text_template parentId lastSent
  13             visible/;
  14 }
  15
  16 sub _build_article {
  17   my ($sub, $article, $opts) = @_;
  18
  19   my @cols = BSE::TB::Article->columns;
  20   shift @cols;
  21   @$article{@cols} = ('') x @cols;
  22   my $parent_id = $opts->{parentId} || $sub->{parentId} || -1;
  23   my $parent;
  24   if ($parent_id > 0) {
  25     $parent = BSE::TB::Articles->getByPkey($parent_id);
  26     unless ($parent) {
  27       $parent_id = -1;
  28     }
  29   }
  30   use BSE::Util::SQL qw(now_datetime now_sqldate);
  31   $article->{body} = $opts->{body} || '';
  32   $article->{title} = defined($opts->{title}) ? $opts->{title} : $sub->{title};
  33   $article->{parentid} = $parent_id;
  34   $article->{displayOrder} = time;
  35   $article->{imagePos} = 'tr';
  36   $article->{release} = now_sqldate;
  37   $article->{expire} = $Constants::D_99;
  38   $article->{keyword} =
  39     exists($opts->{keyword}) ? $opts->{keyword} : $sub->{keyword};
  40   $article->{generator} = 'BSE::Generate::Article';
  41   $article->{level} = $parent ? $parent->{level} + 1 : 1;
  42   $article->{listed} = 1;
  43   $article->{lastModified} = now_datetime;
  44   $article->{link} = '';
  45
  46   my $template = $opts->{html_template};
  47   $template = $sub->{html_template} unless defined $template;
  48   $article->{template} = $template;
  49   $article->{generator} = 'BSE::Generate::Subscription';
  50   $article->{id} = -5;
  51
  52   $article->{threshold} = $parent->{threshold};
  53   $article->{inherit_siteuser_rights} = 1;
  54   $article->{summaryLength} = $parent->{summaryLength};
  55   $article->{created} = now_datetime;
  56   $article->{inherit_siteuser_rights} = 1;
  57   $article->{force_dynamic} = 0;
  58   $article->{cached_dynamic} = 0;
  59   $article->{menu} = 0;
  60
  61   # for field value neatness
  62   $article->{customDate1} = undef;
  63   $article->{customDate2} = undef;
  64   $article->{customStr1} = undef;
  65   $article->{customStr2} = undef;
  66   $article->{customInt1} = undef;
  67   $article->{customInt2} = undef;
  68   $article->{customInt3} = undef;
  69   $article->{customInt4} = undef;
  70
  71 #    $article->{titleImage} = '';
  72 #    $article->{thumbImage} = '';
  73 #    $article->{thumbWidth} = $article->{thumbHeight} = 0;
  74
  75 #    $article->{admin} = '';
  76 #    $article->{link} = '';
  77 }
  78
  79 sub _word_wrap {
  80   my ($text) = @_;
  81
  82   my $out = '';
  83   while (length $text > 72) {
  84     $text =~ s/^(.{1,72}\s+)(?=\S)//
  85       or $text =~ s/^(\S+\s+)(?=\S)//
  86         or last;
  87     $out .= "$1\n";
  88   }
  89   $out .= $text;
  90
  91   return $out;
  92   #$text =~ s/(.{1,72}\s+)(?=\S)/$1\n/g;
  93
  94   #$text;
  95 }
  96
  97 sub _format_link {
  98   my ($cfg, $url, $title, $index) = @_;
  99
 100   my $fmt = $cfg->entry('subscriptions', 'text_link_inline',
 101                         '$1 [$3]');
 102   my %replace =
 103     (
 104      1 => $title,
 105      2 => $url,
 106      3 => $index,
 107      '$' => '$',
 108     );
 109
 110   $fmt =~ s/\$([123\$])/$replace{$1}/g;
 111
 112   $fmt;
 113 }
 114
 115 sub _body_link {
 116   my ($cfg, $urls, $url, $title, $rindex) = @_;
 117
 118   push @$urls, [ $url, $title ];
 119
 120   return _format_link($cfg, $url, $title, $$rindex++);
 121 }
 122
 123 sub _doclink {
 124   my ($cfg, $urls, $id, $title, $rindex) = @_;
 125
 126   my $dispid;
 127   if ($id =~ /^\d+$/) {
 128     $dispid = $id;
 129   }
 130   else {
 131     # try to find it in the config
 132     my $work = $cfg->entry('articles', $id);
 133     unless ($work) {
 134       return ">> No article name '$id' in the [articles] section of bse.cfg <<";
 135     }
 136     $dispid = "$id ($work)";
 137     $id = $work;
 138   }
 139   require BSE::TB::Articles;
 140   my $art = BSE::TB::Articles->getByPkey($id);
 141   unless ($art) {
 142     return ">> Cannot find article id $dispid <<";
 143   }
 144
 145   # make the URL absolute
 146   my $url = $art->{link};
 147   $url = $cfg->entryErr('site', 'url') . $url
 148     unless $url =~ /^\w+:/;
 149
 150   unless ($title) {
 151     $title = $art->{title};
 152   }
 153
 154   push @$urls, [ $url, $title ];
 155
 156   return _format_link($cfg, $url, $title, $$rindex++);
 157 }
 158
 159 sub _any_link {
 160   my ($cfg, $urls, $type, $content, $rindex) = @_;
 161
 162   if (lc $type eq 'link') {
 163     if ($content =~ /^([^|]+)\|(.*)$/) {
 164       return _body_link($cfg, $urls, $1, $2, $rindex);
 165     }
 166     else {
 167       return $content;
 168     }
 169   }
 170   else { # must be doclink
 171     if ($content =~ /^([^|]+)\|(.*)$/) {
 172       return _doclink($cfg, $urls, $1, $2, $rindex);
 173     }
 174     else {
 175       return _doclink($cfg, $urls, $content, undef, $rindex);
 176     }
 177   }
 178 }
 179
 180 sub _url_list {
 181   my ($cfg, $urls) = @_;
 182
 183   my $url_fmt = $cfg->entry('subscriptions', 'text_link_list',
 184                             '[$3] $2');
 185   my $body = '';
 186   length $url_fmt
 187     or return $body;
 188   my $sep = $cfg->entry('subscriptions', 'text_link_list_prefix',
 189                         '-----');
 190   $sep =~ s/\$n/\n/g;
 191   $body .= $sep . "\n" if length $sep;
 192   my $url_index = 1;
 193   for my $url (@$urls) {
 194     my %replace =
 195       (
 196        1 => $url->[1],
 197        2 => $url->[0],
 198        3 => $url_index,
 199        '$' => '$',
 200        'n' => "\n",
 201       );
 202     (my $work = $url_fmt) =~ s/\$([123\$n])/$replace{$1}/g;
 203     $body .= "$work\n";
 204     ++$url_index;
 205   }
 206
 207   return $body;
 208 }
 209
 210 sub _format_body {
 211   my ($cfg, $article) = @_;
 212   require BSE::Generate;
 213   my $gen = BSE::Generate->new(cfg=>$cfg, top => $article);
 214   my $body = $article->{body};
 215   my @urls;
 216   my $url_index = 1;
 217   while ($body =~ s#(?:pop)?(doclink|link)\[([^\]\[]+)\]#_any_link($cfg, \@urls, $1, $2, \$url_index)#ie) {
 218   }
 219
 220   $gen->remove_block('BSE::TB::Articles', [], \$body);
 221   while (1) {
 222     $body =~ s/[bi]\[([^\[\]]+)\]/$1/g
 223        and next;
 224     $body =~ s#(?<=\W)\[([^\]\[]+)\]#\003$1\004#g
 225       and next;
 226
 227     last;
 228   }
 229   $body =~ tr/\003\004/[]/;
 230   $body =~ tr/\r//d; # in case
 231   $body =~ s/(^(?:[ \t]*\n)?|\n[ \t]*\n)([^\n]{73,})(?=\n[ \t]*\n|\n?\z)/
 232     $1 . _word_wrap($2)/ge;
 233
 234   if (@urls) {
 235     $body .= "\n" unless $body =~ /\n$/;
 236     $body .= _url_list($cfg, \@urls);
 237   }
 238
 239   $body;
 240 }
 241
 242 sub _text_format_low {
 243   my ($sub, $cfg, $user, $opts, $article) = @_;
 244
 245   my $template = $opts->{text_template} || $sub->{text_template};
 246   $article->{generator} = 'BSE::Generate::Subscription';
 247   $article->{id} = -5;
 248   my %acts;
 249   %acts =
 250     (
 251      BSE::Util::Tags->static(\%acts, $cfg),
 252      article=>sub { $article->{$_[0]} },
 253      ifUser =>
 254      sub {
 255        my ($args) = @_;
 256        $user or return '';
 257        defined $user->{$args} or return '';
 258        $user->{$args};
 259      },
 260      user =>
 261      sub {
 262        $user or return '';
 263        defined $user->{$_[0]} or return '';
 264        $user->{$_[0]}
 265      },
 266      body =>
 267      sub {
 268        _format_body($cfg, $article);
 269      },
 270      sub => sub { $sub->{$_[0]} },
 271     );
 272
 273   require BSE::Template;
 274   return BSE::Template->get_page($template, $cfg, \%acts);
 275 }
 276
 277 sub text_format {
 278   my ($sub, $cfg, $user, $opts) = @_;
 279
 280   my %article;
 281   $sub->_build_article(\%article, $opts);
 282   require BSE::DummyArticle;
 283   bless \%article, "BSE::DummyArticle";
 284   return $sub->_text_format_low($cfg, $user, $opts, \%article);
 285 }
 286
 287 sub html_format {
 288   my ($sub, $cfg, $user, $opts) = @_;
 289
 290   my %article;
 291   $sub->_build_article(\%article, $opts);
 292   require BSE::Generate::Subscription;
 293   require BSE::DummyArticle;
 294   bless \%article, "BSE::DummyArticle";
 295   my $gen = BSE::Generate::Subscription->new(cfg=>$cfg, top => \%article);
 296   $gen->set_user($user);
 297   $gen->set_sub($sub);
 298
 299   return $gen->generate(\%article, 'BSE::TB::Articles');
 300 }
 301
 302 sub recipients {
 303   my ($sub) = @_;
 304
 305   require BSE::TB::SiteUsers;
 306   BSE::TB::SiteUsers->getSpecial('subRecipients', $sub->{id});
 307 }
 308
 309 sub recipient_count {
 310   my ($sub) = @_;
 311
 312   my @rows = BSE::DB->query(subRecipientCount => $sub->{id});
 313   $rows[0]{count};
 314 }
 315
 316 sub _send {
 317   my ($sub, $cfg, $opts, $callback, $recipients, $article) = @_;
 318
 319   $callback->('general', undef, scalar(@$recipients)." recipients to process");
 320   require 'BSE/Mail.pm';
 321   my $mailer = BSE::Mail->new(cfg=>$cfg);
 322   $sub->_build_article($article, $opts);
 323   require BSE::DummyArticle;
 324   bless $article, "BSE::DummyArticle";
 325   my $gen;
 326   if ($article->{template}) {
 327     #print STDERR "Making generator\n";
 328     require BSE::Generate::Subscription;
 329     $gen = BSE::Generate::Subscription->new(cfg=>$cfg, top=>$article);
 330     $gen->set_sub($sub);
 331   }
 332   my $from = $cfg->entryIfVar('subscriptions', 'from');
 333   unless ($from) {
 334     $from = $cfg->entry('shop', 'from', $Constants::SHOP_FROM);
 335   }
 336   unless ($from) {
 337     $callback->('error', undef, "Configuration error: No from address configured, please set from in the subscriptions section of the config file, or \$SHOP_FROM in Constants.pm");
 338     return;
 339   }
 340   my $charset = $cfg->charset;
 341   my $index = 0;
 342   for my $user (@$recipients) {
 343     $callback->('user', $user) if $callback;
 344     my $text = $sub->_text_format_low($cfg, $user, $opts, $article);
 345       if ($cfg->utf8) {
 346         require Encode;
 347         $text = Encode::encode($cfg->charset, $text);
 348       }
 349     my $html;
 350     if ($gen && !$user->{textOnlyMail}) {
 351       #print STDERR "Making HTML\n";
 352       $gen->set_user($user);
 353       my %acts;
 354       %acts = $gen->baseActs("BSE::TB::Articles", \%acts, $article);
 355       $html = BSE::Template->get_page($article->template, $cfg, \%acts,
 356                                       undef, undef, $gen->variables);
 357       if ($cfg->utf8) {
 358         require Encode;
 359         $html = Encode::encode($cfg->charset, $html);
 360       }
 361     }
 362     my @headers;
 363     my $content;
 364     push(@headers, "MIME-Version: 1.0");
 365     if ($html) {
 366       $html =~ tr/\cM/\cJ/;
 367       my $boundary = "====" . time . "=_=" .int(rand(10000))."=";
 368       push(@headers, qq!Content-Type: multipart/alternative; boundary="$boundary"!);
 369       $content = "This is a multi-part message in MIME format\n\n"
 370         . "--$boundary\n";
 371       $content .= qq!Content-Type: text/plain; charset="$charset"\n\n!
 372         . $text . "\n\n";
 373       $content .= "--$boundary\n";
 374       $content .= qq!Content-Type: text/html; charset="$charset"\n\n!
 375         . $html . "\n\n";
 376       $content .= "--$boundary--\n";
 377     }
 378     else {
 379       push(@headers, qq!Content-Type: text/plain; charset="$charset"!);
 380       $content = $text;
 381       $content .= "\n" unless $content =~ /\n$/;
 382     }
 383     unless ($mailer->send(from    =>$from,
 384                           to      =>$user->{email},
 385                           subject =>$article->{title},
 386                           headers =>join("\n", @headers, ""),
 387                           body    =>$content)) {
 388       $callback->('error', $user, scalar($mailer->errstr));
 389     }
 390     ++$index;
 391   }
 392 }
 393
 394 # filter is an optional array ref of permitted subscriber ids
 395 sub send {
 396   my ($sub, $cfg, $opts, $callback, $filter) = @_;
 397
 398   my @recipients = $sub->recipients;
 399
 400   unless (@recipients) {
 401     $callback->('error', undef, 'This subscription has no recipients, no action taken');
 402     return;
 403   }
 404
 405   # filter the recipients
 406   if ($filter) {
 407     my %filter = map { $_=>1 } @$filter;
 408     @recipients = grep $filter{$_->{id}}, @recipients;
 409
 410     unless (@recipients) {
 411       $callback->('error', undef, 'This subscription has no recipients after filters, no action taken');
 412       return;
 413     }
 414   }
 415
 416   my %article;
 417   $sub->_send($cfg, $opts, $callback, \@recipients, \%article);
 418
 419   if (exists $opts->{archive} ? $opts->{archive} : $sub->{archive}) {
 420     $callback->('general', undef, "Archiving article");
 421     require BSE::TB::Articles;
 422     $article{template} = $opts->{article_template} || $sub->{article_template};
 423     $article{generator} = 'BSE::Generate::Article';
 424     $article{parentid} = $opts->{parentId} || $sub->{parentId};
 425     my @cols = BSE::TB::Article->columns;
 426     shift @cols;
 427     my $article = BSE::TB::Articles->add(@article{@cols});
 428     use Constants qw(:edit $CGI_URI $ARTICLE_URI $LINK_TITLES);
 429     my $link = "$ARTICLE_URI/$article->{id}.html";
 430     if ($LINK_TITLES) {
 431       (my $extra = lc $article->{title}) =~ tr/a-z0-9/_/sc;
 432       $link .= "/".$extra;
 433     }
 434     $article->{link} = $link;
 435     $article->setAdmin("$CGI_URI/admin/admin.pl?id=$article->{id}");
 436     $article->save;
 437     require BSE::Regen;
 438
 439     $callback->('general', undef, "Generating article");
 440     BSE::Regen::generate_article('BSE::TB::Articles', $article, $cfg);
 441   }
 442
 443   use BSE::Util::SQL qw/now_datetime/;
 444   $sub->{lastSent} = now_datetime;
 445   $sub->save;
 446 }
 447
 448 sub send_test {
 449   my ($sub, $cfg, $opts, $callback, $recipient) = @_;
 450
 451   my @recipients = ( $recipient );
 452
 453   my %article;
 454   $sub->_send($cfg, $opts, $callback, \@recipients, \%article);
 455 }
 456
 457 1;