HTML::FromText - Convert plain text to HTML.

    use HTML::FromText;
    text2html( $text, %options );

    # or

    use HTML::FromText ();
    my $t2h  = HTML::FromText->new( \%options );
    my $html = $t2h->parse( $html );

    my $t2h = HTML::FromText->new({
        paras      => 1,
        blockcode  => 1,
        tables     => 1,
        bullets    => 1,
        numbers    => 1,
        urls       => 1,
        email      => 1,
        bold       => 1,
        underline  => 1,
    });

  my $html = $t2h->parse( $text );

    my $html = text2html(
                         $text,
                         urls  => 1,
                         email => 1,
                        );

    require HTML::FromText;
    # or ...
    use HTML::FromText ();

    {
     options => {
                 option_name => $value,
                 ...
                },
     text    => $text, # as passed to parse(), with tabs expanded
     html    => $html, # the HTML that will be returned from parse()
    }

    paras => {
              0 => {
                    text => $text, # paragraph text
                    html => $html, # paragraph html
                   },
              ... # and so on for all paragraphs
             },

    text-decoration: none !important;

  Copyright (c) 2003 Casey West.  All rights reserved.
  This module is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.

package HTML::FromText;

use strict;
use Scalar::Util          qw[blessed];
use HTML::Entities        qw[encode_entities];
use Text::Tabs            qw[expand];
use Email::Find::addrspec qw[$Addr_spec_re];
use Exporter::Lite;

use vars qw[$VERSION @EXPORT @DECORATORS $PROTOCOLS];

$VERSION    = '2.05';
@EXPORT     = qw[text2html];
@DECORATORS = qw[urls email bold underline];
$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}, '<pre class="hft-pre">', '</pre>';
}

sub lines {
    my ($self) = @_;
    $self->{html} =~ s[ ][ ]g if $self->{options}->{spaces};
    $self->{html} =~ s[$][<br />]gm;
    $self->{html} =~ s[^][<div class="hft-lines">];
    $self->{html} =~ s[$][</div>];
}

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[<h1 class="hft-title">], "</h1>\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[<p class="hft-paras">$_[0]</p>\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[<h$depth class="hft-headings">$text</h$depth>\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[<blockquote class="hft-blockparas"><p>$text</p></blockquote>\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|$][<br />\n]g;

        qq[<blockquote class="hft-blockquotes"><div>$text</div></blockquote>\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[^][<pre>];
        $text =~ s[$][</pre>];
        $self->_consolidate_blocks(
                                   ( exists $paras->{$pnum - 1} ? $paras->{$pnum -1} : undef ),
                                   'blockcode', 0,
                                   qq[<blockquote class="hft-blockcode">$text</blockquote>\n],
                                  );
    });
}

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

sub email {
    my ($self) = @_;
    $self->{html} =~ s[($Addr_spec_re)]
                                            [<a href="mailto:$1" class="hft-email">$1</a>]og;
}

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

sub bold {
    my ($self) = @_;
    $self->{html} =~ s[(?:^|(?<=\W))((\*)([^\\\*\n]*(?:\\.[^\\\*\n]*)*)(\*))(?:(?=\W)|$)]
                                            [<strong class="hft-bold">$3</strong>]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) . "</$parent>\n";
                }
            }
            $html .= (' ' x ($pos = $line_pos)) . "<li>$line</li>\n";
        }
        $html .= "</$parent>\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[<table class="hft-tables">\n];
    foreach my $line ( @{$lines} ) {
        $table .= join( '',
                        '  <tr><td>',
                        join(
                             '</td><td>',
                             map { s/^\s+//; s/\s$//; $_ } unpack $columns, $line
                            ),
                        "</td></tr>\n",
                      );
    }
    $table .= "</table>\n";
}

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[<blockquote class="hft-$class"><(\w+)>] ) {
        my $inner_tag = $keep_inner ? '' : qr[</?$1>];
        $prev_para->{html} =~ s[$inner_tag</blockquote>][];
        $html =~ s[<blockquote class="hft-$class">$inner_tag][];
    }
    return $html;
}

1;

__END__