File Coverage

blib/lib/Text/Autoformat.pm

Criterion	Covered	Total	%
statement	192	323	59.4
branch	88	198	44.4
condition	37	95	38.9
subroutine	19	23	82.6
pod	0	7	0.0
total	336	646	52.0

package Text::Autoformat;
$Text::Autoformat::VERSION = '1.74';
use 5.006;
use strict;
use warnings;
use Carp;

require Exporter;

use Text::Reform qw( form tag break_at break_with break_wrap break_TeX );
use Text::Autoformat::Hang;
use Text::Autoformat::NullHang;

our @ISA = qw(Exporter);
our @EXPORT = qw( autoformat );
our @EXPORT_OK =
    qw( form tag break_at break_with break_wrap break_TeX ignore_headers );


my %std_highlight_ignore = map {$_=>1} qw {
    a an at as and are
    but by
    ere
    for from
    in into is
    of on onto or over
    per
    the to that than
    until unto upon
    via
    with while whilst within without
};

my $STD_HIGHLIGHT_IGNORES = sub {
    my ($word) = @_;
    return $std_highlight_ignore{lc $word} ? recase($word,'lower') : recase($word,'title');
};

my @entities = qw {
    Á   á      Â    â        Æ    æ
    À   à      Α    α        Ã   ã
    Ä     ä        Β     β         Ç   ç
    Χ      χ         Δ    δ        É   é
    Ê    ê       È   è       Ε  ε
    Η      η         Ð      ð          Ë     ë
    Γ    γ       Í   í       Î    î
    Ì   ì      Ι     ι         Ï     ï
    Κ    κ       Λ   λ       Μ       μ
    Ñ   ñ      Ν       ν           Ó   ó
    Ô    ô       Œ    œ        Ò   ò
    Ω    ω       Ο  ο      Õ   õ
    Ö     ö        Φ      φ          Π       π
    ″    ′       Ψ      ψ          Ρ      ρ
    Š   š      Σ    σ        Τ      τ
    Θ    θ       Þ    þ        Ú   ú
    Û    û       Ù   ù       Υ  υ
    Ü     ü        Ξ       ξ           Ý   ý
    Ÿ     ÿ        Ζ     ζ
};

my %lower_entities = @entities;
my %upper_entities = reverse @entities;

my %casing = (
    lower => [ \%lower_entities,  \%lower_entities,
           sub { $_ = lc },   sub { $_ = lc } ],
    upper => [ \%upper_entities,  \%upper_entities,
           sub { $_ = uc },   sub { $_ = uc } ],
    title => [ \%upper_entities,  \%lower_entities,
           sub { $_ = ucfirst lc }, sub { $_ = lc } ],
);

my $default_margin = 72;
my $default_widow  = 10;

$Text::Autoformat::widow_slack = 0.1;


sub defn($)
{
    return $_[0] if defined $_[0];
    return "";
}

my $ignore_headers = qr/
    \A
    (?: From \b .* $)?
    (?: [^:\n]+ : .* \n
        (?: [ \t] .* \n)*
    )+
    \s*
    \Z
    /mx;
my $ignore_indent  = qr/^[^\S\n].*(\n[^\S\n].*)*$/;

sub ignore_headers { $_[0] && /$ignore_headers/ }

# BITS OF A TEXT LINE

my $quotechar = qq{[!#%=|:;]};
my $quotechunk = qq{(?:$quotechar(?![a-z])|(?:[a-z]\\w*)?>+)};
my $QUOTER = qq{(?:(?i)(?:$quotechunk(?:[ \\t]*$quotechunk)*))};

my $separator = q/(?:[-_]{2,}|[=#*]{3,}|[+~]{4,})/;

use overload;
sub autoformat  # ($text, %args)
{
    my ($text,%args,$toSTDOUT);

    foreach ( @_ )
    {
        if (ref eq 'HASH')
            { %args = (%args, %$_) }
        elsif (!defined($text) && !ref || overload::Method($_,'""'))
            { $text = "$_" }
        else {
            croak q{Usage: autoformat([text],[{options}])}
        }
    }

    unless (defined $text) {
        $text = join("",);
        $toSTDOUT = !defined wantarray();
    }

    return $text unless $text =~ /\S/;

    $args{right}   = $default_margin unless exists $args{right};
    $args{justify} = "" unless exists $args{justify};
    $args{widow}   = 0 if ($args{justify}||"") =~ /full/;
    $args{widow}   = $default_widow unless exists $args{widow};
    $args{case}    = '' unless exists $args{case};
    $args{lists}   = 1 unless exists $args{lists};
    $args{squeeze} = 1 unless exists $args{squeeze};
    $args{gap}     = 0 unless exists $args{gap};
    $args{break}  = break_at('-') unless exists $args{break};
    $args{impfill} = ! exists $args{fill};
    $args{expfill} = $args{fill};
    $args{tabspace} = 8 unless exists $args{tabspace};
    $args{renumber} = 1 unless exists $args{renumber};
    $args{autocentre} = 1 unless exists $args{autocentre};
    $args{_centred} = 1 if $args{justify} =~ /cent(er(ed)?|red?)/;
    $args{all} ||= $args{mail};

    # SPECIAL IGNORANCE...
    if ($args{ignore}) {
        $args{all} = 1;
        $args{ignore} = _build_ignore( $args{ignore} );
    }
    else {
        $args{ignore} = sub{0};
    }

    if ( $args{mail} ) {
        my $ignore = $args{ignore};
        $args{ignore} = sub { $ignore->(@_) || ignore_headers(@_) };
    }

    # DETABIFY
    my @rawlines = split /\n/, $text;
    use Text::Tabs; $tabstop = $args{tabspace};
    @rawlines = expand(@rawlines);

    # HANDLE QUOTING CHANGE
    my $quoter = exists $args{quoter} ? $args{quoter} : $QUOTER;
    $quoter =~ s//$QUOTER/g;

    # PARSE EACH LINE

    my $pre = 0;
    my @lines;
    foreach (@rawlines)
    {
            push @lines, { raw     => $_ };
            s/\A([ \t]*)($quoter?)([ \t]*)//
                or die "Internal Error ($@) on '$_'";
            $lines[-1]{presig} =  $lines[-1]{prespace}   = defn $1;
            $lines[-1]{presig} .= $lines[-1]{quoter}     = defn $2;
            $lines[-1]{presig} .= $lines[-1]{quotespace} = defn $3;

            $lines[-1]{hang} = Text::Autoformat::Hang->new($_, $args{lists});

            s/([ \t]*)(.*?)(\s*)$//
                or die "Internal Error ($@) on '$_'";
            $lines[-1]{hangspace} = defn $1;
            $lines[-1]{text} = defn $2;
            $lines[-1]{empty} = $lines[-1]{hang}->empty() && $2 !~ /\S/;
            $lines[-1]{separator} = $lines[-1]{text} =~ /^$separator$/;
    }

    # SUBDIVIDE DOCUMENT INTO COHERENT SUBSECTIONS

    my @chunks;
    push @chunks, [shift @lines];
    foreach my $line (@lines)
    {
        if ($line->{separator} ||
            $line->{quoter} ne $chunks[-1][-1]->{quoter} ||
            $line->{empty} ||
            @chunks && $chunks[-1][-1]->{empty})
        {
            push @chunks, [$line];
        }
        else
        {
            push @{$chunks[-1]}, $line;
        }
    }



 # DETECT CENTRED PARAS

    CHUNK: foreach my $chunk ( @chunks )
    {
        next CHUNK if !$args{autocentre} || @$chunk < 2 || $chunk->[0]{hang};
        my @length;
        my $ave = 0;
        foreach my $line (@$chunk)
        {
            my $prespace = $line->{quoter}  ? $line->{quotespace}
                            : $line->{prespace};
            my $pagewidth =
                2*length($prespace) + length($line->{text});
            push @length, [length $prespace,$pagewidth];
            $ave += $pagewidth;
        }
        $ave /= @length;
        my $diffpre = 0;
        foreach my $l (0..$#length)
        {
            next CHUNK unless abs($length[$l][1]-$ave) <= 2;
            $diffpre ||= $length[$l-1][0] != $length[$l][0]
                if $l > 0;
        }
        next CHUNK unless $diffpre;
        foreach my $line (@$chunk)
        {
            $line->{centred} = 1;
            ($line->{quoter} ? $line->{quotespace}
                     : $line->{prespace}) = "";
        }
    }

    # REDIVIDE INTO PARAGRAPHS

    my @paras;
    foreach my $chunk ( @chunks )
    {
        my $first = 1;
        my $firstfrom;
        foreach my $line ( @{$chunk} )
        {
            if ($first ||
                $line->{quoter} ne $paras[-1]->{quoter} ||
                $paras[-1]->{separator} ||
                !$line->{hang}->empty
               )
            {
                push @paras, $line;
                $first = 0;
                $firstfrom = length($line->{raw}) - length($line->{text});
            }
            else
            {
                my $extraspace = length($line->{raw}) - length($line->{text}) - $firstfrom;
                $extraspace = 0 if $extraspace < 0;
                $paras[-1]->{text} .= "\n" . q{ }x$extraspace . $line->{text};
                $paras[-1]->{raw} .= "\n" . $line->{raw};
            }
        }
    }

    # SELECT PARAS TO HANDLE

    my $remainder = "";
    if ($args{all}) { # STOP AT MAIL TERMINATOR IF $args{mail}
        my $lastignored = 1;
        for my $index (0..$#paras) {
            local $_ = $paras[$index]{raw} . "\n";
            $paras[$index]{ignore} = $args{ignore}($lastignored);
            $lastignored &&= $paras[$index]{ignore};
            next unless $args{mail} && /^--\s*$/;
            $remainder = join "\n", map { $_->{raw} } splice @paras, $index;
                $remainder .= "\n" unless $remainder =~ /\n\z/;
            last;
        }
    }
    else { # JUST THE FIRST PARA
        $remainder = join "\n", map { $_->{raw} } @paras[1..$#paras];
            $remainder .= "\n" unless $remainder =~ /\n\z/;
        @paras = ( $paras[0] );
    }

    # RE-CASE TEXT
    if ($args{case}) {
        foreach my $para ( @paras ) {
            next if $para->{ignore};
            if (ref $args{case} eq 'CODE') {
                $para->{text} = entitle($para->{text}, $args{case});
            }
            elsif ($args{case} =~ /upper/i) {
                $para->{text} = recase($para->{text}, 'upper');
            }
            elsif ($args{case} =~ /lower/i) {
                $para->{text} = recase($para->{text}, 'lower');
            }
            elsif ($args{case} =~ /title/i) {
                $para->{text} = entitle($para->{text}, 0);
            }
            elsif ($args{case} =~ /highlight/i) {
                $para->{text} = entitle($para->{text}, $STD_HIGHLIGHT_IGNORES);
            }
            elsif ($args{case} =~ /sentence(\s*)/i) {
                my $trailer = $1;
                $args{squeeze}=0 if $trailer && $trailer ne " ";
                ensentence();
                $para->{text} =~ s/(\S+(\s+|$))/ensentence($1, $trailer)/ge;
            }
            $para->{text} =~ s/\b([A-Z])[.]/\U$1./gi; # ABBREVS
        }
    }

    # ALIGN QUOTERS
    # DETERMINE HANGING MARKER TYPE (BULLET, ALPHA, ROMAN, ETC.)

    my %sigs;
    my $lastquoted = 0;
    my $lastprespace = 0;
    for my $i ( 0..$#paras )
    {
        my $para = $paras[$i];
        next if $para->{ignore};

     if ($para->{quoter})
        {
            if ($lastquoted) { $para->{prespace} = $lastprespace }
            else         { $lastquoted = 1; $lastprespace = $para->{prespace} }
        }
        else
        {
            $lastquoted = 0;
        }
    }

# RENUMBER PARAGRAPHS

    for my $para ( @paras ) {
        next if $para->{ignore};
        my $sig = $para->{presig} . $para->{hang}->signature();
        push @{$sigs{$sig}{hangref}}, $para;
        $sigs{$sig}{hangfields} = $para->{hang}->fields()-1
            unless defined $sigs{$sig}{hangfields};
    }

    while (my ($sig,$val) = each %sigs) {
        next unless $sig =~ /rom/;
        field: for my $field ( 0..$val->{hangfields} )
        {
            my $romlen = 0;
            foreach my $para ( @{$val->{hangref}} )
            {
                my $hang = $para->{hang};
                my $fieldtype = $hang->field($field);
                next field
                    unless $fieldtype && $fieldtype =~ /rom|let/;
                if ($fieldtype eq 'let') {
                    foreach my $para ( @{$val->{hangref}} ) {
                        $hang->field($field=>'let')
                    }
                }
                else {
                    $romlen += length $hang->val($field);
                }
            }
            # NO ROMAN LETTER > 1 CHAR -> ALPHABETICS
            if ($romlen <= @{$val->{hangref}}) {
                foreach my $para ( @{$val->{hangref}} ) {
                    $para->{hang}->field($field=>'let')
                }
            }
        }
    }

    my %prev;

    for my $para ( @paras ) {
        next if $para->{ignore};
        my $sig = $para->{presig} . $para->{hang}->signature();
        if ($args{renumber}) {
            unless ($para->{quoter}) {
                $para->{hang}->incr($prev{""}, $prev{$sig});
                $prev{""} = $prev{$sig} = $para->{hang}
                    unless $para->{hang}->empty;
            }
        }

        # COLLECT MAXIMAL HANG LENGTHS BY SIGNATURE

        my $siglen = $para->{hang}->length();
        $sigs{$sig}{hanglen} = $siglen
            if ! $sigs{$sig}{hanglen} ||
               $sigs{$sig}{hanglen} < $siglen;
    }

    # PROPAGATE MAXIMAL HANG LENGTH

    while (my ($sig,$val) = each %sigs)
    {
        foreach (@{$val->{hangref}}) {
            $_->{hanglen} = $val->{hanglen};
        }
    }

    # BUILD FORMAT FOR EACH PARA THEN FILL IT

    $text = "";
    my $gap = @paras && $paras[0]->{empty} ? 0 : $args{gap};
    for my $para ( @paras )
    {
        if ($para->{empty}) {
            $gap += 1 + ($para->{text} =~ tr/\n/\n/);
        }
        if ($para->{ignore}) {
            $text .= (!$para->{empty} ? "\n"x($args{gap}-$gap > 0 ? ($args{gap}-$gap) : 0) : "") ;
            $text .= $para->{raw};
            $text .= "\n" unless $para->{raw} =~ /\n\z/;
        }
        else {
            my $leftmargin = $args{left} ? " "x($args{left}-1)
                     : $para->{prespace};
            my $hlen = $para->{hanglen} || $para->{hang}->length;
            my $hfield = ($hlen==1 ? '~' : '>'x$hlen);
            my @hang;
            push @hang, $para->{hang}->stringify if $hlen;
            my $format = $leftmargin
               . quotemeta($para->{quoter})
               . $para->{quotespace}
               . $hfield
               . $para->{hangspace};
            my $rightslack = int (($args{right}-length $leftmargin)*$Text::Autoformat::widow_slack);
            my ($widow_okay, $rightindent, $firsttext, $newtext) = (0,0);
            do {
                my $tlen = $args{right}-$rightindent-length($leftmargin
                            . $para->{quoter}
                            . $para->{quotespace}
                            . $hfield
                            . $para->{hangspace});
                next if blockquote($text,$para, $format, $tlen, \@hang, \%args);
                my $tfield = ( $tlen==1                          ? '~'
                     : $para->{centred}||$args{_centred} ? '|'x$tlen
                     : $args{justify} eq 'right'         ? ']'x$tlen
                     : $args{justify} eq 'full'          ? '['x($tlen-2) . ']]'
                     : $para->{centred}||$args{_centred} ? '|'x$tlen
                     :                                     '['x$tlen
                         );
            my $tryformat = "$format$tfield";
            $newtext = (!$para->{empty} ? "\n"x($args{gap} > $gap ? ($args{gap}-$gap) : 0) : "")
                     . form( { squeeze=>$args{squeeze}, trim=>1,
                       break=>$args{break},
                       fill => !(!($args{expfill}
                        || $args{impfill} &&
                           !$para->{centred}))
                       },
                    $tryformat, @hang,
                    $para->{text});
            $firsttext ||= $newtext;
            (my $widow) = $newtext =~ /([^\n]*)$/;
            $widow =~ s/^\s+//;
            $widow_okay = $para->{empty} || length($widow) >= $args{widow};
            } until $widow_okay || ++$rightindent > $rightslack;

            $text .= $widow_okay ? $newtext : $firsttext;
        }
        $gap = 0 unless $para->{empty};
    }


    # RETURN FORMATTED TEXT

    if ($toSTDOUT) { print STDOUT $text . $remainder; return }
    return $text . $remainder;
}

sub _build_ignore {
    my $ignore_arg = shift;
    my $ig_type = ref $ignore_arg;
    my $ignore;
    if ($ig_type eq 'Regexp') {
        my $regex = $ignore_arg;
        $ignore = sub { /$regex/ };
    } elsif ($ig_type eq 'ARRAY') {
        my @elements = map { _build_ignore($_) } @$ignore_arg;
        $ignore = sub {
            for my $sub (@elements) { return 1 if $sub->(@_) }
            return 0;
        };
    }
    elsif ($ignore_arg =~ /^indent/i) {
        $ignore = sub { ignore_headers(@_) || /$ignore_indent/ };
    }
    else {
        $ignore = $ignore_arg;
    }
    croak "Expected suboutine reference as value for -ignore option"
        if ref $ignore ne 'CODE';
    return $ignore;
}

my $alpha = qr/[^\W\d_]/;
my $notalpha = qr/[\W\d_]/;
my $word = qr/\pL(?:\pL'?)*/;
my $upper = qr/[^\Wa-z\d_]/;
my $lower = qr/[^\WA-Z\d_]/;
my $mixed = qr/$alpha*?(?:$lower$upper|$upper$lower)$alpha*/;

sub recase {
    my ($origtext, $case) = @_;
    my ($entities, $other_entities, $first, $rest) = @{$casing{$case}};

    my $text = "";
    my @pieces = split /(&[a-z]+;)/i, $origtext;
    push @pieces, "" if @pieces % 2;
    return $text unless @pieces;
    local $_ = shift @pieces;
    if (length $_) {
        $entities = $other_entities;
        &$first;
        $text .= $_;
    }
    return $text unless @pieces;
    $_ = shift @pieces;
    $text .= $entities->{$_} || $_;
    while (@pieces) {
        $_ = shift @pieces; &$rest; $text .= $_;
        $_ = shift @pieces; $text .= $other_entities->{$_} || $_;
    }
    return $text;
}

my $alword = qr{(?:\pL|&[a-z]+;)(?:[\pL']|&[a-z]+;)*}i;

sub entitle {
    my ($text, $retitler_ref) = @_;

    # put into lowercase if on stop list, else titlecase
    $text =~ s{($alword)}
              { $retitler_ref ? $retitler_ref->($1) : recase($1,'title') }gex;

    if ($retitler_ref == $STD_HIGHLIGHT_IGNORES) {
        # First and final words always capitalized...
        $text =~ s/^($alword) /recase($1,'title')/ex;
        $text =~ s/ ($alword)$/recase($1,'title')/ex;

        # treat parethesized portion as a complete title
        $text =~ s/\( ($alword) /'('.recase($1,'title')/ex;
        $text =~ s/($alword) \) /recase($1,'title').')'/ex;

        # capitalize first word following colon or semi-colon
        $text =~ s/ ( [:;] \s+ ) ($alword) /$1 . recase($2,'title')/ex;
    }

    return $text;
}

my $gen_abbrev = join '|',
    qw{ etc[.]  pp[.]   ph[.]?d[.] },
    '(?:[A-Z][.])(?:[A-Z][.])+',
    '(^[^a-zA-Z]*([a-z][.])+)';

my $term = q{(?:[.]|[!?]+)};

my $eos = 1;
my $brsent = 0;

sub ensentence {
    do { $eos = 1; return } unless @_;
    my ($str, $trailer) = @_;
    if ($str =~ /^([^a-z]*)I[^a-z]*?($term?)[^a-z]*$/i) {
        $eos = $2;
        $brsent = $1 =~ /^[[(]/;
        return uc $str
    }
    unless ($str =~ /[a-z].*[A-Z]|[A-Z].*[a-z]/) {
        $str = lc $str;
    }
    if ($eos) {
        $str =~ s/([a-z])/uc $1/ie;
        $brsent = $str =~ /^[[(]/;
    }
    $eos = $str !~ /^($gen_abbrev)[^a-z]*\s/i
        && $str =~ /[a-z][^a-z]*$term([^a-z]*)\s/
        && !($1=~/[])]/ && !$brsent);
    $str =~ s/\s+$/$trailer/ if $eos && $trailer;
    return $str;
}

# blockquote($text,$para, $format, $tlen, \@hang, \%args);
sub blockquote {
    my ($dummy, $para, $format, $tlen, $hang, $args) = @_;

    $para->{text} =~
        / \A(\s*)       # $1 - leading whitespace (quotation)
       (["']|``)        # $2 - opening quotemark
       (.*)         # $3 - quotation
       (''|\2)      # $4 closing quotemark
       \s*?\n       # trailing whitespace
       (\1[ ]+)     # $5 - leading whitespace (attribution)
       (--|-)       # $6 - attribution introducer
       (.*?$)       # $7 - attribution line 1
       ((\5.*?$)*)      # $8 - attributions lines 2-N
       \s*\Z
     /xsm
     or return;

    #print "[$1][$2][$3][$4][$5][$6][$7]\n";
    my $indent = length $1;
    my $text = $2.$3.$4;
    my $qindent = length $2;
    my $aindent = length $5;
    my $attribintro = $6;
    my $attrib = $7.$8;
    $text =~ s/\n/ /g;

    $_[0] .=

                form {squeeze=>$args->{squeeze}, trim=>1,
          fill => $args->{expfill}
                   },
       $format . q{ }x$indent . q{<}x$tlen,
             @$hang, $text,
       $format . q{ }x($qindent) . q{[}x($tlen-$qindent),
             @$hang, $text,
       {squeeze=>0},
       $format . q{ } x $aindent . q{>> } . q{[}x($tlen-$aindent-3),
             @$hang, $attribintro, $attrib;
    return 1;
}

1;

__END__