File Coverage

blib/lib/CGI/Application/MailPage.pm

Criterion	Covered	Total	%
statement	313	382	81.9
branch	121	194	62.3
condition	33	51	64.7
subroutine	28	30	93.3
pod	1	7	14.2
total	496	664	74.7

package CGI::Application::MailPage;
use base 'CGI::Application';
use strict;
use CGI::Application;
use File::Spec;
use HTML::Template;
use HTML::TreeBuilder;
use HTTP::Date;
use MIME::Entity;
use Mail::Header;
use Mail::Internet;
use Email::Valid;
use Net::SMTP;
use Text::Format;
use URI;
use Data::FormValidator;
use Fcntl qw(:flock);

$CGI::Application::MailPage::VERSION = '1.7';

sub setup {
    my $self = shift;
    $self->start_mode('show_form');
    $self->mode_param('rm');
    $self->run_modes(
                   show_form => \&show_form,
                   send_mail => \&send_mail,
    );

    # make sure we have required params
    die "You must set either 'document_root' or 'remote_fetch' in PARAMS!"
        unless defined $self->param('document_root') || $self->param('remote_fetch');

    die "You must set 'your.smtp.server' in PARAMS!"
        unless defined $self->param('smtp_server');

    # default custom validation_profile is an empty hash
    $self->param(validation_profile => {} )
        unless defined($self->param('validation_profile'));
}

sub show_form {
    my ($self, $err_msgs) = @_;
    my $query = $self->query;

    my $page = $query->param('page');
    if (not defined $page) {
        unless($self->param('use_page_param')) {
            $page = $query->referer();
            return $self->error(
                "Sorry, I can't tell what page you want to send. " .
                "You need to be using either Netscape 4 or Internet Explorer 4 (or newer) " .
                "to use this feature. Please upgrade your browser and try again!"
            )
                unless defined $page;
        } else {
            return $self->error("no value for page param!")
                unless defined $page;
        }
    }

    my $template;
    if ($self->param('form_template')) {
        $template = $self->load_tmpl($self->param('form_template'),
                                    die_on_bad_params   => 0,
                                    cache               => 1,
                                    associate           => $query
        );

    } else {
        my @path = $self->tmpl_path;
        @path = @{ $self->tmpl_path} if(ref($path[0]) eq 'ARRAY');
        $template = $self->load_tmpl('CGI/Application/MailPage/templates/form.tmpl',
                                    die_on_bad_params   => 0,
                                    path                => [@path, @INC],
                                    cache               => 1,
                                    associate           => $query,
        );
    }

    my %formats = (
        both_attachment => 'Both Text and Full HTML as Attachments',
        html            => 'Full HTML',
        html_attachment => 'Full HTML as an Attachment',
        text            => 'Plain Text',
        text_attachment => 'Plain Text as an Attachment',
        url             => 'Just A Link',
    );
    #create the default dropdown menu
    $template->param(FORMAT_SELECTOR =>
                   $query->popup_menu(-name => 'format',
                                      '-values' => [ sort(keys %formats) ],
                                      -labels => \%formats,
                                      -default => 'both_attachment',
                   )
    );
    #create a loop that the user can use as they wish
    my @format_loop = ();
    foreach my $key (sort(keys(%formats))) {
        push(@format_loop, { value => $key, label => $formats{$key}});
    }
    $template->param(FORMAT_OPTIONS => \@format_loop);

    # set the default 'subject' as the email subject
    $query->param('subject' => $self->param('email_subject'))
        unless($query->param('subject'));
    # if we have any alerts or error messages
    if( $err_msgs && ref $err_msgs eq 'HASH' ) {
        $template->param(%$err_msgs);
    }
    $template->param(%{$self->param('extra_tmpl_params')})
        if($self->param('extra_tmpl_params'));
    return $template->output();
}

sub send_mail {
    my $self = shift;
    my $query = $self->query;

    # the default validation profile
    my %validation_profile = (
        required    => [qw(
            name from_email to_emails format page subject
        )],
        optional    => [qw(note)],
        constraints => {
            name          => qr/^[\w '-\(\),\.]{1,50}$/,
            from_email    => 'email',
            to_emails     => sub {
                my @emails = split(/\s*,\s*|\s+/, shift);
                # make sure there aren't too many
                # if we have 'max_emails_per_request'
                if(
                    $self->param('max_emails_per_request')
                    && scalar @emails > $self->param('max_emails_per_request')
                ) {
                    return;
                }
                # check for valid email addresses
                foreach my $email (@emails) {
                    if(! Email::Valid->address($email) ) {
                        return;
                    }
                }
                return \@emails;
            },
            subject       => qr/^[\w '-\(\),\.\?\!]{1,50}$/,
            note          => qr/^[^\0]{1,250}$/,
            format        => sub {
                my $val = shift;
                my @valid_formats = qw(
                    both_attachment html html_attachment
                    text text_attachment url
                );
                if( grep { $val eq $_ } @valid_formats ) {
                    return $val;
                }
                return;
            },
            page        => qr/^[^\n\0]{1,256}$/, # TODO - what should this be?
        },
        untaint_all_constraints => 1,
    );

    # merge this default with the custom profile
    # first merge the 'constraints'
    if( $self->param('validation_profile')->{constraints} ) {
        $validation_profile{constraints} = {
            %{$validation_profile{constraints}},
            %{ $self->param('validation_profile')->{constraints} }
        };
    }
    delete $self->param('validation_profile')->{constraints};
    # now merge the rest
    %validation_profile = (
        %validation_profile,
        %{ $self->param('validation_profile') },
    );

    # now validate the data
    my $results = Data::FormValidator->check($query, \%validation_profile);

    # create any error messages if necessary.
    if( $results->has_invalid || $results->has_missing ) {
        my %err_msgs = ();
        # look at each invalid
        foreach my $invalid ($results->invalid) {
            $err_msgs{"error_$invalid"} = 1;
            $err_msgs{"invalid_$invalid"} = 1;
            $err_msgs{"any_errors"} = 1;
            $err_msgs{"any_invalid"} = 1;
        }
        # look at each missing
        foreach my $missing ($results->missing) {
            $err_msgs{"error_$missing"} = 1;
            $err_msgs{"missing_$missing"} = 1;
            $err_msgs{"any_errors"} = 1;
            $err_msgs{"any_missing"} = 1;
        }

        # for backwards compatability, add an 'alert' parameter
        # for older templates that hold's the first error message we encounter
        if( $err_msgs{error_name} ) {
            $err_msgs{alert} = "Please fill in your name in the form below.";
        } elsif( $err_msgs{invalid_from_email} ) {
            $err_msgs{alert} = "Your email address is invalid - it should look like name\@host.com.";
        } elsif( $err_msgs{missing_from_email} ) {
            $err_msgs{alert} = "Please fill in your email address in the form below.";
        } elsif( $err_msgs{invalid_to_emails} ) {
            $err_msgs{alert} = "One of your friend's email addresses is invalid - it should look like name\@host.com.";
        } elsif( $err_msgs{missing_to_emails} ) {
            $err_msgs{alert} = "Please fill in your friends' email addresses in the form below.";
        } elsif( $err_msgs{error_subject} ) {
            $err_msgs{alert} = "Please enter a Subject for the email in the form below.";
        }

        # show these errors
        return $self->show_form(\%err_msgs);
    }

    # get the valid data
    my $valid_data = $results->valid();
    my ($to_emails, $from_email, $name, $subject, $page, $note, $format) =
        map { $valid_data->{$_} } qw(to_emails from_email name subject page note format);

    #make sure this page is either relative or within the acceptable_domains
    if(
        $self->param('acceptable_domains')  #if we have any domains
        && (ref($self->param('acceptable_domains')) eq 'ARRAY')   #if it's an array ref
        && $page =~ m#^https?://([^/:]+)#               #if the path's not relative
    )
    {
        my $domain = $1;
        return $self->error("The domain for that desired page is not acceptable!")
            unless( grep { lc($domain) eq lc($_) } @{$self->param('acceptable_domains')});
    }

    # make sure we haven't exceeded our hourly limit
    if( $self->param('max_emails_per_hour') ) {
        my $file = $self->param('max_emails_per_hour_file');
        unless( $file ) {
            die "max_emails_per_hour_file ($file) must exist and be writable"
                . " in order to use max_emails_per_hour!";
        }
        my ($error, $count, $last_time);
        my $current_time = time();
        # if already exists then open it and read the data
        if( -e $file ) {
            open(my $IN, $file) or die "Could not open $file for reading! $!";
            ($last_time, $count) = split(qr/:/, <$IN>);
            close($IN) or die "Could not close $file! $!";
            $last_time ||= 0;
            $count ||= 0;
            # find out if we've done this within the hour
            # if the difference is less than 1 hour, increase the count
            # and make sure it's less than the hourly total
            if( $current_time - $last_time < ( 60 * 60 ) ) {
                $count += scalar(@$to_emails);
                if( $count > $self->param('max_emails_per_hour') ) {
                    $error = "Hourly limit on emails exceeded!";
                }
                # keep the last recorded time.
                $current_time = $last_time;
            } else {
                $count = scalar(@$to_emails);
            }
        # else the file doesn't exist
        } else {
            $count = scalar(@$to_emails);
        }

        # now save the time and count
        open(my $OUT, ">", $file) or die "Could not open $file for writing! $!";
        flock($OUT, LOCK_EX) or die "Could not obtain lock on $file! $!";
        print $OUT "$current_time:$count";
        close($OUT) or die "Could not close $file! $!";

        # if we have an error then return it
        return $self->error($error) if( $error );
    }

    # find the HTML file to open (if it's not a remote fetch)
    my ($filename, $base_url, $base);
    unless( $self->param('remote_fetch') && ($page =~ m!^https?://!) ) {
        $filename = $self->_find_html_file($page);
        return $self->error("Unable to find file $filename for page $page (might be empty or unreadable): $!")
            unless -e $filename and -r _ and -s _;
        my ($vol, $dir, $file) = File::Spec->splitpath($filename);

        $base_url = $page;
        $base_url =~ s/\Q$file\E//;

        # if file is empty, assume index.html
        if (not defined $file or not length $file) {
            $file = 'index.html';
            $filename .= '/index.html';
        }

        my $ext;
        ($base, $ext) = $file =~ /(.*)\.([^\.]+)$/;
    } else {
        $base_url = URI->new($page);
        $base_url = $base_url->scheme . '://' . $base_url->authority . '/' . $base_url->path;
    }

    # open the email template
    my $template;
    if ($self->param('email_template')) {
        $template = $self->load_tmpl($self->param('email_template'),
                                    die_on_bad_params   => 0,
                                    cache               => 1,
        );
    } else {
        my @path = $self->tmpl_path;
        @path = @{ $self->tmpl_path} if(ref($path[0]) eq 'ARRAY');
        $template = $self->load_tmpl('CGI/Application/MailPage/templates/email.tmpl',
                                    die_on_bad_params   => 0,
                                    path                => [@path, @INC],
                                    cache               => 1,
        );
    }
    $template->param(%$valid_data);
    $template->param(%{$self->param('extra_tmpl_params')})
        if($self->param('extra_tmpl_params'));

    # get the IP address of the original sender
    my $sender_ip = $ENV{HTTP_X_FORWARDED_FOR} || $ENV{REMOTE_ADDR} || '';
    # $msg will end up with either a Mail::Internet or MIME::Entity object.
    my $msg;

    # are we doing attachments?
    if (index($format, '_attachment') != -1) {
        # open up a MIME::Entity for our msg
        $msg = MIME::Entity->build(
            'Type'             => "multipart/mixed",
            'From'             => "$name <$from_email>",
            'Reply-To'         => "$name <$from_email>",
            'To'               => $to_emails,
            'Subject'          => $subject,
            'Date'             => HTTP::Date::time2str(time()),
            'X-Originating-Ip' => $sender_ip,
        );

        $msg->attach(Data => $template->output);

        # attach the straight HTML if requested
        if ($format =~ /^(both|html)/) {
            my $buffer = "";
            if ($self->param('read_file_callback')) {
                my $callback = $self->param('read_file_callback');
                $buffer = $callback->($filename);
            } elsif( $self->param('remote_fetch') && ($page =~ /^https?:\/\//) ) {
                #fetch this page with LWP
                require LWP::UserAgent;
                require HTTP::Request;
                my $agent = LWP::UserAgent->new();
                my $response = $agent->request(HTTP::Request->new(GET => $page));
                if( $response->is_success ) {
                    $buffer = $response->content();
                } else {
                    return $self->error("Unable to retrieve remote page $page");
                }
            } else {
                open(HTML, $filename) or return $self->error("Can't open $filename : $!");
                while(read(HTML, $buffer, 10240, length($buffer))) {}
                close(HTML);
            }

            # add  tag in
            $buffer =~ s/(<\s*[Hh][Ee][Aa][Dd].*?>)/$1\n\n/
                if( $base_url );

            my $attached_filename = $base ? "$base.html" : $page;
            $msg->attach(
                    Data        => $buffer,
                    Type        => 'text/html',
                    Filename    => $attached_filename,
            );
        }

        # attach text translation
        if ($format =~ /^(both|text)/) {
            my $new_filename = $base ? "$base.txt" : "$page.txt";
            $msg->attach(
                    Data        => $self->_html2text($filename, $page),
                    Type        => 'text/plain',
                    Filename    => $new_filename,
            );
        }

    } else {
        # non attachment mail
        my $header = Mail::Header->new();
        $header->add(From => "$name <$from_email>");
        $header->add('Reply-To' => "$name <$from_email>");
        $header->add(To => join(', ', @$to_emails));
        $header->add(Subject  => $subject);
        $header->add(Date => HTTP::Date::time2str(time()));
        $header->add('X-Originating-Ip' => $sender_ip)
            if( $sender_ip );

        my @lines;
        push(@lines, $template->output());

        if ($format =~ /^(both|text)/) {
            push(@lines, "\n---\n\n");
            push(@lines, $self->_html2text($filename, $page));
        }

        if ($format =~ /^(both|html)/) {
            push(@lines, "\n---\n\n");
            if ($self->param('read_file_callback')) {
                my $callback = $self->param('read_file_callback');
                my $buffer = $callback->($filename);
                push(@lines, split("\n", $buffer));
            } elsif( $self->param('remote_fetch') && ($page =~ /^https?:\/\//) ) {
                #fetch this page with LWP
                require LWP::UserAgent;
                require HTTP::Request;
                my $agent = LWP::UserAgent->new();
                my $response = $agent->request(HTTP::Request->new(GET => $page));
                if( $response->is_success ) {
                    my $buffer = $response->content();
                    @lines = split(/\r?\n/, $buffer);
                } else {
                    return $self->error("Unable to retrieve remote page $page");
                }
            } else {
                open(HTML, $filename) or return $self->error("Can't open $filename : $!");
                push(@lines, );
                close(HTML);
            }
        }

        if ($format =~ /url/) {
            push(@lines, "\n$page");
        }

        $msg = Mail::Internet->new([], Header => $header, Body => \@lines);
        return $self->error("Unable to create Mail::Internet object!")
            unless defined $msg;
    }

    # send the message using SMTP - other methods can be added later
    unless($self->param('dump_mail')) {
        my $smtp = Net::SMTP->new($self->param('smtp_server'));
        return $self->error("Unable to connect to SMTP server ".$self->param('smtp_server')." : $!")
            unless defined $smtp and UNIVERSAL::isa($smtp,'Net::SMTP');
        $smtp->debug(1) if $self->param('smtp_debug');

        $smtp->mail("$name <$from_email>");
        foreach (@$to_emails) {
            $smtp->to($_);
        }
        $smtp->data();
        $smtp->datasend($msg->as_string());
        $smtp->dataend();
        $smtp->quit();

    } else {
        # debuging hook for test.pl
        my $mailref = $self->param('dump_mail');
        $$mailref = $msg->as_string();
        return $self->error("Mail Dumped");
    }

    # all done
    return $self->show_thanks;
}

sub show_thanks {
    my $self = shift;
    my $query = $self->query;
    my $page = $query->param('page');

    my $template;
    if ($self->param('thanks_template')) {
        $template = $self->load_tmpl($self->param('thanks_template'),
                                    die_on_bad_params   => 0,
                                    cache               => 1,
        );
    } else {
        my @path = $self->tmpl_path;
        @path = @{ $self->tmpl_path} if(ref($path[0]) eq 'ARRAY');
        $template = $self->load_tmpl('CGI/Application/MailPage/templates/thanks.tmpl',
                                    die_on_bad_params   => 0,
                                    path                => [@path, @INC],
                                    cache               => 1,
        );
    }

    $template->param(PAGE => $page);
    $template->param(%{$self->param('extra_tmpl_params')})
        if($self->param('extra_tmpl_params'));
    return $template->output();
}


sub error {
    my ($self, $msg) = @_;
    my $template;

    if($self->param('error_template')) {
        $template = $self->load_tmpl( $self->param('error_template'),
                                    die_on_bad_params   => 0,
                                    cache               => 1,
        );
    } else {
        my @path = $self->tmpl_path;
        @path = @{ $self->tmpl_path} if(ref($path[0]) eq 'ARRAY');
        $template = $self->load_tmpl( 'CGI/Application/MailPage/templates/error.tmpl',
                                    die_on_bad_params   => 0,
                                    path                => [@path, @INC],
                                    cache               => 1,
        );
    }

    $template->param(error => $msg);
    $template->param(%{$self->param('extra_tmpl_params')})
        if($self->param('extra_tmpl_params'));
    return $template->output();
}

sub _find_html_file {
    my $self = shift;
    my $url = shift;
    my $path;

    # if it doesn't start with http, its relative to web root
    if($url =~ m!^https?://([-\w\.:]+)/(.*)!) {
        my $host = $1;
        $path = $2;
        # if the path starts with a ~user thing, remove it
        $path =~ s!~[^/]+/!!;
    } else {
        $path = ($url =~ /^\//) ? $url : "/$url";   #make sure it has a preceding path
    }

    # now make sure we don't allow any '../' sections to try and hack the server
    $path =~ s/\.\.\///g;
    # append it to document_root and return it
    return File::Spec->join($self->param('document_root'), $path);
}

# takes an html file and returns text.  This code was taken and
# modified from html2text.pl by Ave Wrigley.  I don't really
# understand most of it, but it seems to work well.

#--------------------------------------------------------------------------
#
# prefixes to convert tags into - some are converted back to Text::Format
# formatting later
#
#--------------------------------------------------------------------------

my %prefix = (
              'li'        => '* ',
              'dt'        => '+ ',
              'dd'        => '- ',
             );

my %underline = (
                 'h1'        => '=',
                 'h2'        => '-',
                 'h3'        => '-',
                 'h4'        => '-',
                 'h5'        => '-',
                 'h6'        => '-',
                );

my @heading_number = ( 0, 0, 0, 0, 0, 0 );

sub _html2text {
  my $self = shift;
  my $filename = shift;
  my $page = shift;

  my $html_tree = new HTML::TreeBuilder;
  my $text_formatter = new Text::Format;
  $text_formatter->firstIndent( 0 );

  my $result = "";

  #----------------------------------------------------------------------
  #
  # get_text - get all the text under a node
  #
  #----------------------------------------------------------------------

  sub get_text
    {
      my $this = shift;
      my $text = '';

      # iterate though my children ...
      return unless defined $this->content;
      for my $child ( @{ $this->content } )
        {
          # if the child is also non-text ...
          if ( ref( $child ) )
            {
              # traverse it ...
              $child->traverse(
                               # traveral callback
                               sub {
                                 my( $node, $startflag, $depth ) = @_;
                                 # only visit once
                                 return 0 unless $startflag;
                                 # if it is non-text ...
                                 if ( ref( $node ) )
                                   {
                                     # recurse get_text
                                     $text .= get_text( $node );
                                   }
                                 # if it is text
                                 else
                                   {
                                     # add it to $text
                                     $text .= $node if $node =~ /\S/;
                                   }
                                 return 0;
                               },
                               0
                              );
            }
          # if it is text
          else
            {
              # add it to $text
              $text .= $child if $child =~ /\S/;
            }
        }
      return $text;
    }

  #--------------------------------------------------------------------------
  #
  # get_paragraphs - routine for generating an array of paras from a given node
  #
  #--------------------------------------------------------------------------

  sub get_paragraphs
    {
      my $this = shift;

      # array to save paragraphs in
      my @paras = ();
      # avoid -w warning for .= operation on undefined
      $paras[ 0 ] = '';

      # iterate though my children ...
      for my $child ( @{ $this->content } )
        {
          # if the child is also non-text ...
          if ( ref( $child ) )
            {
              # traverse it ...
              $child->traverse(
                               # traveral callback
                               sub {
                                 my( $node, $startflag, $depth ) = @_;
                                 # only visit once
                                 return 0 unless $startflag;
                                 # if it is non-text ...
                                 if ( ref( $node ) )
                                   {
                                     # if it is a list element ...
                                     if ( $node->tag =~ /^(?:li|dd|dt)$/ )
                                       {
                                         # recurse get_paragraphs
                                         my @new_paras = get_paragraphs( $node );
                                         # pre-pend appropriate prefix for list
                                         $new_paras[ 0 ] =
                                           $prefix{ $node->tag } . $new_paras[ 0 ]
                                             ;
                                         # and update the @paras array
                                         @paras = ( @paras, @new_paras );
                            # and traverse no more
                                         return 0;
                                       }
                                     else
                                       {
                                         # any other element, just traverse
                                         return 1;
                                       }
                                   }
                                 else
                                   {
                                     # add text to the current paragraph ...
                                     $paras[ $#paras ] =
                                       join( ' ', $paras[ $#paras ], $node )
                                         if $node =~ /\S/
                                           ;
                                     # and recurse no more
                                     return 0;
                                   }
                               },
                               0
                              );
            }
          else
            {
              # add test to current paragraph ...
              $paras[ $#paras ] = join( ' ', $paras[ $#paras ], $child )
                if $child =~ /\S/
                  ;
            }
        }
      return @paras;
    }

  #--------------------------------------------------------------------------
  #
  # Main
  #
  #--------------------------------------------------------------------------

  # parse the HTML file
  if ($self->param('read_file_callback')) {
    my $callback = $self->param('read_file_callback');
    $html_tree->parse( $callback->($filename) );
  } elsif( $self->param('remote_fetch') && ($page =~ /^https?:\/\//) ) {
      #fetch this page with LWP
      require LWP::UserAgent;
      require HTTP::Request;
      my $agent = LWP::UserAgent->new();
      my $response = $agent->request(HTTP::Request->new(GET => $page));
      if( $response->is_success ) {
          my $buffer = $response->content();
          $html_tree->parse($buffer);
      } else {
          return $self->error("Unable to retrieve remote page $page");
      }
  } else {
    open(HTML, $filename) or return $self->error("Can't open $filename : $!");
    $html_tree->parse( join( '',  ) );
    close(HTML);
  }

  # main tree traversal routine

  $html_tree->traverse(
                       sub {
                         my( $node, $startflag, $depth ) = @_;
                         # ignore what's in the
                         return 0 if ref( $node ) and $node->tag eq 'head';
                         # only visit nodes once
                         return 0 unless $startflag;
                         # if this node is non-text ...
                         if ( ref $node )
                           {
                             # if this is a para  ...
                             if ( $node->tag eq 'p' )
                               {
                                 # iterate sub-paragraphs (including lists) ...
                                 for ( get_paragraphs( $node ) )
                                   {
                                     # if it is a  ...
                                     if ( /^\* / )
                                       {
                                         # indent first line by 4, rest by 6
                                         $text_formatter->firstIndent( 4 );
                                         $text_formatter->bodyIndent( 6 );
                                       }
                                     # if it is a  ...
                                     elsif ( s/^\+ // )
                                       {
                                         # set left margin to 4
                                         $text_formatter->leftMargin( 4 );
                                       }
                                     # if it is a  ...
                                     elsif ( s/^- // )
                                       {
                                         # set left margin to 8
                                         $text_formatter->leftMargin( 8 );
                                       }
                                     # print formatted paragraphs ...
                                     $result .= $text_formatter->paragraphs( $_ );
                                     # and reset formatter defaults
                                     $text_formatter->leftMargin( 0 );
                                     $text_formatter->firstIndent( 0 );
                                     $text_formatter->bodyIndent( 0 );
                                   }
                                 $result .= "\n";
                                 return 0;
                               }
                             # if this is a heading ...
                             elsif ( $node->tag =~ /^h(\d)/ )
                               {
                                 # get the heading level ...
                                 my $level = $1;
                                 # increment the number for this level ...
                                 $heading_number[ $level ]++;
                                 # reset lower level heading numbers ...
                                 for ( $level+1 .. $#heading_number )
                                   {
                                     $heading_number[ $_ ] = 0;
                                   }
                                 # create heading number string
                                 my $heading_number = join(
                                                           '.',
                                                           @heading_number[ 1 .. $level ]
                                                          );
                                 # generate heading from number string and heading text ...
                                 # my $text = "$heading_number " . get_text( $node );
                                 my $text = get_text( $node );
                                 # underline it with the appropriate underline character ...
                                 $text =~ s{
                        (.*)
                    }
                                   {
                                     "$1\n" . $underline{ $node->tag } x length( $1 )
                                   }gex
                                     ;
                                 $result .= $text;
                                 return 0;
                               } else {
                                 return 1;
                               }
                           }
                         # if it is text ...
                         else
                           {
                             return 0 unless $node =~ /\S/;
                             $result .= $text_formatter->format( $node );
                             return 0;
                           }
                       },
                       0
                      );

  # filter out comments
  $result =~ s///gs;

  return $result;
}


1;
__END__