Re: RFC 183 (v1) "=for testing" - Embedded tests

[Barrie Slaymaker]

Here's a quick take on a Pod::Tests, I threw it together as part of my =also
prototype code (I hacked it in to a copy of Pod::Select, named "Pod::AlsoSelect")
since that's what Pod::Text relies on).  The =also stuff seems to work.

- Barrie

-------------8<------------8<-------------8<------------
package Pod::Tests ;

=head1 NAME

Pod::Tests - Extract test suites from POD.

=head1 SYNOPSIS

   use Pod::Tests ;

   my $p = Pod::Tests->new() ;
   $p->parse_from_file( 'podfile', 'test_directory' ) ;

Note that the destination must be a directory, and that it is not
optional.

=head1 DESCRIPTION

This module uses Pod::AlsoSelect and looks for sections marked

   =for test foo.t

and (due to Pod::AlsoSelect's devious machinations)

   =also_for test foo.t

and ignores normal text.

It does not use any functionality of Pod::Select, just what's inherited from
Pod::Parser, so in a real implementation, it would not inherit from
Pod::Select.

=cut

use strict ;
use vars qw( @ISA ) ;

use Carp ;
use File::Spec ;
use Pod::AlsoSelect ;
use Symbol ;

@ISA = qw( Pod::AlsoSelect ) ;


sub parse_from_file {
    my $self = shift;
    my ( $file_name, $dest_dir ) = @_ ;
    $self->{DEST_DIR} = $dest_dir ;
    croak "No destination directory supplied"
       unless defined $dest_dir && length $dest_dir ;
    $self->parse_from_file( $file_name ) ;
}


## Lifted from Pod::Text.  Should really go in Pod::StdParser some day.
sub command {
    my $self = shift;
    my $command = shift;
    return if $command eq 'pod';
    return if ($$self{EXCLUDE} && $command ne 'end');
    $self->item ("\n") if defined $$self{ITEM};
    $command = 'cmd_' . $command;
    $self->$command (@_) if $self->can( $command ) ;
}


sub open_test_file {
   my $self = shift ;
   my ( $fn ) = @_ ;

   # $fn eq '' means to restore normal operation
   my $ton = length $fn ? File::Spec->catfile( $self->{DEST_DIR}, $fn ) : '' ;
   if ( $self->{SAVED_HANDLE} ) {
      return if $ton eq $self->{TEST_OUT_NAME} ;
      $self->close_test_file ;
   }
   $self->{TEST_OUT_NAME} = $ton ;
   return unless length $ton ;

   $self->{SAVED_HANDLE} = $self->output_handle ;

   ## Break encapsulation here, since I see no other way defined by Pod::Parser
   $self->{_OUTPUT} = gensym ;
   open( $self->output_handle, ">$ton" ) or croak "$! opening '$ton'" ;
}


sub close_test_file {
   my $self = shift;
   close( $self->output_handle ) or croak "$! closing '$self->{TEST_OUT_NAME}'";
   $self->{_OUTPUT} = $self->{SAVED_HANDLE} ;
   $self->{SAVED_HANDLE} = undef ;
   $self->{TEST_OUT_NAME} = undef ;
}


sub output {
   my $self = shift ;
   my $fh = $self->output_handle ;
   print $fh $_[1] ;
}

# Throw away all normal text, print all others
sub verbatim  {
   my $self = shift ;
   $self->output( shift ) if $self->{TEST_OUTPUT} ;
}

*textblock = *textblock = \&verbatim ;

sub cmd_for {
   my $self = shift ;
   my ( $text, $line ) = @_ ;
   return unless $text =~ s/\Atest\s+(\S*).*\n//m ;
   local $self->{TEST_OUTPUT} = 1 ;
   $self->open_test_file( $1 ) ;
   $self->textblock( $text, $line ) ;
}

sub cmd_begin {
   my $self = shift ;
   my ( $text, $line ) = @_ ;

   $self->{TEST_OUTPUT} = ( $text =~ /\Atest\s+(\S*)/ ) ;
   $self->open_test_file( $1 ) ;
}

sub cmd_end {
   my $self = shift ;
   my ( $text, $line ) = @_ ;
   $self->{TEST_OUTPUT} = ! ( $text =~ s/\Atest// ) ;
   $self->close_test_file() ;
}