File Coverage

blib/lib/App/news.pm

Criterion	Covered	Total	%
statement	66	81	81.4
branch	17	22	77.2
condition	5	9	55.5
subroutine	5	5	100.0
pod	0	4	0.0
total	93	121	76.8

# Copyright (C) 2023  Alex Schroeder <[e-mail]>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

package App::news;

use Modern::Perl '2018';

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(wrap html_unwrap ranges sranges);

our $VERSION = 1.09;

=head1 NAME

App::news - a web front-end for a news server

=head1 DESCRIPTION

This is a collection of functions for F<script/news>, which see.

    use App::news qw(wrap);
    $body = wrap($body);

B<wrap> does text wrapping appropriate for plain text message bodies as used in
mail and news articles.

If a line is shorter than 50 characters, it is not wrapped.

Lines are wrapped to be 72 characters or shorter.

Quotes are handled as long as only ">" is used for quoting.

B<ranges> translates a list of message numbers into an array of numbers or
arrays suitable for XOVER.

B<sranges> translates the output of I<ranges> into a string for humans to read,
i.e. "1-2,4".

=head1 AUTHOR

Alex Schroeder

=head1 LICENSE

GNU Affero General Public License

=cut

# Some US-ASCII coded characters 00-1F and 7F hexadecimal are excluded; the
# space character and all whitespace is excluded; angle-bracket "<" and ">" and
# double-quote (") characters are excluded; and the "unwise" characters are
# excluded. This regular expression is case-sensitive, so the scheme most be
# lower-case!
my $iri_re = qr((\b[a-z]+:[^\x00-\x1F\x7F[:space:]<>"{}|\\^\[\]`]+));

sub wrap {
  my @lines = split(/\n/, shift);
  my @result;
  my $min = 50;
  my $max = 72;
  my $buffer;
  my $prefix = '';
  for (@lines) {
    my ($new_prefix) = /^([> ]*)/;
    my $no_wrap = (/^$prefix\s*$/ or length() < $min);
    # end old paragraph with the old prefix if the prefix changed or a short line
    # came up
    if ($buffer and ($new_prefix ne $prefix or $no_wrap)) {
      push(@result, $prefix . $buffer);
      $buffer = '';
    }
    # set new prefix
    $prefix = $new_prefix;
    # print short lines without stripping trailing whitespace
    if ($no_wrap) {
      push(@result, $_);
      next;
    }
    # continue old paragraph
    $buffer .= " " if $buffer;
    # strip the prefix
    $buffer .= substr($_, length($prefix));
    # wrap what we have
    while (length($buffer) > $max) {
      # if there's a word boundary at $max, break before
      if (substr($buffer, 0, $max - length($prefix) + 1) =~ /(\s+(\S+))\S$/) {
        push(@result, $prefix . substr($buffer, 0, $max - length($prefix) - length($1)));
        $buffer = substr($buffer, $max - length($prefix) - length($2));
      } else {
        my $line = substr($buffer, 0, $max - length($prefix));
        $line =~ s/\s+$//;
        push(@result, $prefix . $line);
        $buffer = substr($buffer, $max - length($prefix));
        $buffer =~ s/^\s+//;
      }
    }
  }
  push(@result, $prefix . $buffer) if $buffer;
  return join("\n", @result) . "\n";
}

sub html_unwrap {
  my @lines = split(/\n/, shift);
  my $result;
  my $depth = 0;
  my @escapes;
  for (@lines) {
    chomp;
    s!$iri_re!push(@escapes, qq(<a href="$1">$1</a>)); "\x1e$#escapes\x1e"!ge;
    my ($prefix) = /^([> ]*)/;
    my $new_depth = () = $prefix =~ />/g;
    s/^([> ]*)//;
    my $closed = 0;
    while ($new_depth < $depth) {
      $result .= "</blockquote>";
      $depth--;
      $closed = 1;
    }
    $result .= "\n" unless $closed; # closing blockquote already added a break
    while ($depth < $new_depth) {
      $result .= '<blockquote>';
      $depth++;
    }
    s/&/&amp;/g;
    s/</&lt;/g;
    s/>/&gt;/g;
    $result .= $_;
  }
  while ($depth > 0) {
    $result .= "</blockquote>";
    $depth--;
  }
  for my $i (0 .. $#escapes) {
    $result =~ s/\x1e$i\x1e/$escapes[$i]/;
  }
  return $result;
}

sub ranges {
  return [] unless @_;
  my $last = shift;
  my $curr = $last;
  my $ranges = [];
  for my $n (@_) {
    if ($n == $curr + 1) {
      $curr = $n;
    } elsif ($last == $curr) {
      push(@$ranges, $last);
      $last = $curr = $n;
    } else {
      push(@$ranges, [$last, $curr]);
      $last = $curr = $n;
    }
  }
  if ($curr > $last) {
    push(@$ranges, [$last, $curr]);
  } else {
    push(@$ranges, $curr);
  }
  return $ranges;
}

sub sranges {
  my $ranges = shift;
  join(",", map { ref ? join("-", @$_) : $_ } @$ranges);
}

1;