File Coverage

blib/lib/HTML/FromText.pm

Criterion	Covered	Total	%
statement	205	212	96.7
branch	80	90	88.8
condition	19	26	73.0
subroutine	39	41	95.1
pod	18	18	100.0
total	361	387	93.2

use strict;
use warnings;
package HTML::FromText;
{
  $HTML::FromText::VERSION = '2.07';
}
# ABSTRACT: converts plain text to HTML


use Email::Find::addrspec 0.09  qw[$Addr_spec_re];
use Exporter 5.58         qw[import];
use HTML::Entities 1.26   qw[encode_entities];
use Scalar::Util 1.12     qw[blessed];
use Text::Tabs 98.1128    qw[expand];

our @EXPORT     = qw[text2html];
our @DECORATORS = qw[urls email bold underline];
our $PROTOCOLS  = qr/
                 afs      | cid      | ftp      | gopher   |
                 http     | https    | mid      | news     |
                 nntp     | prospero | telnet   | wais
                /x;


sub new {
    my ($class, $options) = @_;
    $options ||= {};
    $class->_croak("Options must be a hash reference")
      if ref($options) ne 'HASH';

    my %options = (
                   metachars    => 1,
                   urls         => 0,
                   email        => 0,
                   bold         => 0,
                   underline    => 0,

                   pre          => 0,

                   lines        => 0,
                   spaces       => 0,

                   paras        => 0,
                   bullets      => 0,
                   numbers      => 0,
                   headings     => 0,
                   title        => 0,
                   blockparas   => 0,
                   blockquotes  => 0,
                   blockcode    => 0,
                   tables       => 0,

                   %{ $options },
                  );

    my %self    = (
                   options => \%options,
                   text    => '',
                   html    => '',
                  );

    return bless \%self, blessed($class) || $class;
}


sub parse {
    my ($self, $text) = @_;

    $text = join "\n", expand( split /\n/, $text );

    $self->{text}  = $text;
    $self->{html}  = $text;
    $self->{paras} = undef;

    my $options = $self->{options};

    $self->metachars if $options->{metachars};

       if ( $options->{pre}   ) { $self->pre   }
    elsif ( $options->{lines} ) { $self->lines }
    elsif ( $options->{paras} ) { $self->paras }

    $options->{$_} and $self->$_ foreach @DECORATORS;

    return $self->{html};
}


sub text2html {
    my ($text, %options) = @_;
    HTML::FromText->new(\%options)->parse($text);
}


sub pre {
    my ($self) = @_;
    $self->{html} = join $self->{html}, '', '';
}


sub lines {
    my ($self) = @_;
    $self->{html} =~ s[ ][ ]g if $self->{options}->{spaces};
    $self->{html} =~ s[$][]gm;
    $self->{html} =~ s[^][];
    $self->{html} =~ s[$][];
}


sub paras {
    my ($self) = @_;

    my $options = $self->{options};
    my @paras   = split /\n{2,}/, $self->{html};
    my %paras   = map { $_, { text => $paras[$_], html => undef } } 0 .. $#paras;
    $self->{paras} = \%paras;

    $self->{paras}->{0}->{html} = join(
                                       $self->{paras}->{0}->{text},
                                       q[], "\n"
                                      ) if $options->{title};

    $self->headings if $options->{headings};
    $self->bullets  if $options->{bullets};
    $self->numbers  if $options->{numbers};

    $self->tables   if $options->{tables};

       if ( $options->{blockparas}  ) { $self->blockparas  }
    elsif ( $options->{blockquotes} ) { $self->blockquotes }
    elsif ( $options->{blockcode}   ) { $self->blockcode   }

    $self->_manipulate_paras(sub { qq[$_[0]\n] });

    $self->{html} = join "\n", map $paras{$_}->{html},
      sort { $a <=> $b } keys %paras;
}


sub headings {
    my ($self) = @_;
    my $heading = qr/\d+\./;

    $self->_manipulate_paras(sub{
        my ($text) = @_;
        return unless $text =~ m[^((?:$heading)+)\s+];

        my $depth; $depth++ for split /\./, $1;

        qq[$text\n];
    });
}


sub bullets {
    my ($self) = @_;
    $self->_format_list( qr/[*]/, 'ul', 'hft-bullets' );
    $self->_format_list( qr/[-]/, 'ul', 'hft-bullets' );
}


sub numbers {
    my ($self) = @_;
    $self->_format_list( qr/[0-9]/, 'ol', 'hft-numbers');
}


sub tables {
    my ($self) = @_;

    $self->_manipulate_paras(sub{
        my ($text) =  $self->_remove_indent( $_[0] );

        my @lines   = split /\n/, $text;
        my $columns = $self->_table_find_columns(
                        $self->_table_initial_spaces( split //, $lines[0] ),
                        [ @lines[1 .. $#lines] ],
                      );

        return unless $columns;
        $self->_table_create( $columns, \@lines );
    });
}


sub blockparas {
    my ($self) = @_;
    my $paras = $self->{paras};

    $self->_manipulate_paras(sub{
        my ($text) = $self->_remove_indent( $_[0], 1 );
        my ($pnum, $paras) = @_[1,2];
        return unless $text;

        $self->_consolidate_blocks(
                                   ( exists $paras->{$pnum - 1} ? $paras->{$pnum -1} : undef ),
                                   'blockparas', 1,
                                   qq[$text\n],
                                  );
    });
}


sub blockquotes {
    my ($self) = @_;
    my $paras = $self->{paras};

    $self->_manipulate_paras(sub {
        my ($text) = $self->_remove_indent( $_[0], 1 );
        return unless $text;

        $text =~ s[\n|$][\n]g;

        qq[$text\n];
    });
}


sub blockcode {
    my ($self) = @_;
    my $paras = $self->{paras};

    $self->_manipulate_paras(sub {
        my ($text) = $self->_remove_indent( $_[0], 1 );
        my ($pnum, $paras) = @_[1,2];
        return unless $text;

        $text =~ s[^][];
        $text =~ s[$][];
        $self->_consolidate_blocks(
                                   ( exists $paras->{$pnum - 1} ? $paras->{$pnum -1} : undef ),
                                   'blockcode', 0,
                                   qq[$text\n],
                                  );
    });
}


sub urls {
    my ($self) = @_;
    $self->{html} =~ s[\b((?:$PROTOCOLS):[^\s<]+[\w/])]
                      [$1]og;
}


sub email {
    my ($self) = @_;
    $self->{html} =~ s[($Addr_spec_re)]
                      [$1]og;
}


sub underline {
    my ($self) = @_;
    $self->{html} =~ s[(?:^|(?<=\W))((_)([^\\_\n]*(?:\\.[^\\_\n]*)*)(_))(?:(?=\W)|$)]
                      [$3]g;
}


sub bold {
    my ($self) = @_;
    $self->{html} =~ s[(?:^|(?<=\W))((\*)([^\\\*\n]*(?:\\.[^\\\*\n]*)*)(\*))(?:(?=\W)|$)]
                      [$3]g;
}


sub metachars {
    my ($self) = @_;
    $self->{html} = encode_entities( $self->{html} );
}

# private

sub _croak {
    my ($class, @error) = @_;
    require Carp;
    Carp::croak(@error);
}

sub _carp {
    my ($class, @error) = @_;
    require Carp;
    Carp::carp(@error);
}

sub _format_list {
    my ($self, $identifier, $parent, $class) = @_;

    $self->_manipulate_paras(sub {
        my ($text) = @_;
        return unless $text =~ m[^\s*($identifier)\s+];

        my ($pos, $html, @open) = (-1, '');
        foreach my $line ( split /\n(?=\s*$identifier)/, $text ) {
            $line =~ s[(\s*)$identifier][];
            my $line_pos = length $1;
            if ($line_pos > $pos) {
                $html .= (' ' x $line_pos) . qq[<$parent class="$class">\n];
                push @open, $line_pos;
            } elsif ($line_pos < $pos) {
                until ( $open[-1] <= $line_pos ) {
                    $html .= (' ' x pop @open) . "\n";
                }
            }
            $html .= (' ' x ($pos = $line_pos)) . "$line\n";
        }
        $html .= "\n"x@open;
    });
}

sub _manipulate_paras {
    my ($self, $action) = @_;

    my  $paras = $self->{paras};

    foreach my $pnum ( sort { $a <=> $b } keys %{$paras}) {
        my $para = $paras->{$pnum};
        $para->{html} = $action->($para->{text}, $pnum,  $paras)
          unless $para->{html};
    }
}

sub _table_initial_spaces {
    my ($self, @chars) = @_;

    my %spaces;
    foreach ( 0 .. $#chars ) {
        my ($open_space) = grep { !defined( $_->{end} ) } values %spaces;
        if ( $chars[$_] eq ' ' ) {
            $spaces{$_} = {start => $_, end => undef} unless $open_space;
        } else {
            if ( $open_space && $_ - $open_space->{start} > 1 ) {
                $open_space->{end} = $_ - 1;
            } else {
                delete $spaces{$open_space->{start}} if $open_space;
            }
        }
    }
    return \%spaces;
}

sub _table_find_columns {
    my ($self, $spaces, $lines) = @_;
    return unless keys %{$spaces};
    my %spots;
    foreach my $line ( @{$lines} ) {
        foreach my $pos ( sort { $a <=> $b } keys %{$spaces} ) {
            my $key;
               $key = $spaces->{$pos}->{start}
                 if substr( $line, $spaces->{$pos}->{start}, 1 ) eq ' ';
               $key = $spaces->{$pos}->{end}
                 if substr( $line, $spaces->{$pos}->{end}, 1 )   eq ' ' && ! $key;
            if ( $key ) {
                $spots{$key}++;
                $spots{$spaces->{$pos}->{start}}++
                  if $spots{$spaces->{$pos}->{start}} && $key ne $spaces->{$pos}->{start};
                $spots{$spaces->{$pos}->{end}}++
                  if $key ne $spaces->{$pos}->{end};
            } else {
                delete $spaces->{$pos};
            }
        }
        foreach my $spot (sort {$b <=> $a} keys %spots) {
            if ( substr( $line, $spot, 1 ) ne ' ' ) {
                delete $spots{$spot};
            }
            if ( exists $spaces->{$spot}) {
                my $space = $spaces->{$spot};
                if ( exists $spots{$space->{start}} && $spots{$space->{end}}) {
                    delete $spots{$spot};
                }
            }
        }
    }


    my @spots = grep { $spots{$_} == @{$lines} } sort { $a <=> $b } keys %spots;
    return @spots ? join( '', (
                      map {
                          my $ret = 'A' . ( $spots[$_] - ( $_ == 0 ? 0 : $spots[$_ - 1] ) );
                          $ret eq 'A0' ? () : $ret;
                      } 0 .. $#spots
                    ), 'A*' ) : undef;
}

sub _table_create {
    my ($self, $columns, $lines) = @_;

    my $table = qq[\n]; \n", 




390




6





 





 





 





 





15



     foreach my $line ( @{$lines} ) { 




 




6





 





 





 





 





15



   




391




72





 





 





 





 





149



         $table .= join( '', 




392




 





 





 





 





 





 



                         '  ', 




393




 





 





 





 





 





 



                         join( 




394




 





 





 





 





 





 



                              '', 




395




27





 





 





 





 





84



                              map { s/^\s+//; s/\s$//; $_ } unpack $columns, $line 




 




72





 





 





 





 





117



   




 




72





 





 





 





 





208



   




396




 





 





 





 





 





 



                             ), 




397




 





 





 





 





 





 



                         "




398




 





 





 





 





 





 



                       ); 




399




 





 





 





 





 





 



     } 




400




6





 





 





 





 





52



     $table .= "\n";
    foreach my $line ( @{$lines} ) {
        $table .= join( '',
                        '
                        join(
                             '
                             map { s/^\s+//; s/\s$//; $_ } unpack $columns, $line
                            ),
                        "
                      );
    }
    $table .= "
}

sub _remove_indent {
    my ($self, $text, $strict) = @_;
    return if $text !~ m[^(\s+).+(?:\n\1.+)*$] && $strict;
    $text =~ s[^$1][]mg if $1;
    return $text;
}

sub _consolidate_blocks {
    my ($self, $prev_para, $class, $keep_inner, $html) = @_;
    if ( $prev_para && $prev_para->{html} =~ m[<(\w+)>] ) {
        my $inner_tag = $keep_inner ? '' : qr[];
        $prev_para->{html} =~ s[$inner_tag][];
        $html =~ s[$inner_tag][];
    }
    return $html;
}

1;

__END__