/usr/local/CPAN/WAIT/WAIT/Parse/Pod.pm
# -*- Mode: Perl -*-
# WAIT::Parse::Pod --
# ITIID : $ITI$ $Header $__Header$
# Author : Ulrich Pfeifer
# Created On : Sat Dec 14 17:38:29 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sun Nov 22 18:44:40 1998
# Language : CPerl
# Update Count : 275
# Status : Unknown, Use with caution!
#
# Copyright (c) 1996-1997, Ulrich Pfeifer
#
package WAIT::Parse::Pod;
use Pod::Parser;
use Carp;
use vars qw(@ISA %GOOD_HEADER);
# Got tired reinstalling Pod::Parser after each perl rebuild. So I renamed
# Pod::Text to Pod::PText. Thus this hack:
BEGIN {
eval {require Pod::PText;};
if ($@ ne '') {
require Pod::Text;
croak "Need Pod::Tex version > 2.0" if $Pod::Text::VERSION < 2.0;
@ISA = qw(Pod::Text Pod::Parser WAIT::Parse::Base);
} else {
@ISA = qw(Pod::PText Pod::Parser WAIT::Parse::Base);
}
}
use Text::Tabs qw(expand);
use strict;
# recognized =head1 headers
%GOOD_HEADER = (
name => 1,
synopsis => 1,
options => 1,
description => 1,
author => 1,
example => 1,
bugs => 1,
text => 1,
see => 1,
environment => 1,
);
sub default_indent () {4};
# make frequent tag sets reusable
my $CODE = {text => 1, _c => 1};
my $BOLD = {text => 1, _b => 1};
my $ITALIC = {text => 1, _i => 1};
my $PLAIN = {text => 1};
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = $this->SUPER::new(@_);
bless $self, $class;
}
sub begin_input {
my $self = shift;
$self->indent(default_indent);
$self->{TAGS} = {};
$self->{OUT} = [];
}
sub indent {
my $self = shift;
if (@_) {
$self->{INDENT} = shift;
}
$self->{INDENT};
}
# Stolen afrom Pod::Parser by Tom Christiansen and Brad Appleton and modified
sub interpolate {
my $self = shift;
my ($text, $end_re) = @_;
$text = '' unless (defined $text);
$end_re = "\$" unless ((defined $end_re) && ($end_re ne ''));
local($_) = $text;
my @result;
my ($seq_cmd, $seq_arg, $end) = ('', '', undef);
while (($_ ne '') && /([A-Z])<|($end_re)/) {
# Only text after the match remains to be processed
$_ = $';
# Append text before the match to the result
push @result, $self->{TAGS}, $`;
# See if we matched an interior sequence or an end-expression
($seq_cmd, $end) = ($1, $2);
last if (defined $end); # Saw the end - quit loop here
# At this point we have found an interior sequence,
# we need to obtain its argument
if ($seq_cmd =~ /^([FBIC])/) {
my $tag = '_' . lc $1;
my $tags = $self->{TAGS};
my %tags = (%{$tags}, $tag => 1);
$self->{TAGS} = \%tags;
push @result, $self->interpolate($_, '>');
$self->{TAGS} = $tags;
} else {
my @seq_arg = $self->interpolate($_, '>');
my $i;
for ($i=1;$i<=@seq_arg;$i+=2) {
push @result, $seq_arg[$i-1],
$self->interior_sequence($seq_cmd, $seq_arg[$i]);
}
}
}
## Handle whatever is left if we didnt match the ending regexp
unless ((defined $end) && ($end_re ne "\$")) {
push @result, $self->{TAGS}, $_;
$_ = '';
}
## Modify the input parameter to consume the text that was
## processed so far.
$_[0] = $_;
## Return the processed-text
return @result;
}
sub textblock {
my ($self, $text) = @_;
$self->output($self->interpolate($self->wrap($text)), $PLAIN, "\n\n");
}
sub output {
my ($self) = shift;
while (@_) {
my $tags = shift;
my $text = shift;
croak "Bad tags parameter: '$tags'" unless ref($tags);
push @{$self->{OUT}}, $tags, $text;
}
}
sub verbatim {
my ($self, $text) = @_;
my $indent = $self->indent() + default_indent;
$text = expand($text);
my ($prefix) = ($text =~ /^(\s+)/);
if (length($prefix) < $indent) {
my $add = ' ' x ($indent - length($prefix));
$text =~ s/^/$add/gm;
} elsif (length($prefix) > $indent) {
my $sub = ' ' x (length($prefix) - $indent);
$text =~ s/^$sub//gm;
}
$self->output($CODE, $text);
}
sub command {
my ($self, $cmd, $arg, $sep) = @_;
if ($cmd =~ /^head(\d)/) {
my $indent = $1-1;
my $tags = $self->{TAGS};
$self->{TAGS} = $BOLD;
$self->output($self->interpolate($self->wrap($arg,
$indent*default_indent)."\n\n"));
if ($indent) {
$self->{TAGS} = $tags;
} else {
my $sarg = lc $arg;
$sarg =~ s/\s.*//g;
if ($GOOD_HEADER{$sarg}) {
$self->{TAGS} = {lc $sarg => 1}
} else {
$self->{TAGS} = {text => 1}
}
}
} elsif ($cmd =~ /^back/) {
$self->indent(default_indent);
} elsif ($cmd =~ /^over/) {
my $indent = (($arg)?$arg:default_indent) + default_indent;
$self->indent($indent);
} elsif ($cmd =~ /^item/) {
$self->output($self->interpolate($self->wrap($arg,default_indent)."\n\n"))
} else {
$self->output($self->{TAGS}, $arg);
}
}
# inspired from Text::Wrap by David Muir Sharnoff
sub wrap {
my ($self, $t, $indent) = @_;
$indent = $self->indent unless defined $indent;
my $columns = 76 - $indent;
my $ll = $columns;
my $prefix = ' ' x $indent;
my $result = $prefix;
my $length;
# E/L will probably change length
$t =~ s/([EL])<(.*?)>/$self->interior_sequence($1,$2)/eg;
$t =~ s/\s+/ /g;
while ($t =~ s/^(\S+)\s?//o) {
my $word = $1;
# inline length calculation for speed
my $dummy = $word;
$dummy =~ s/[A-Z]<(.*?)>/$1/og;
$length = length($dummy);
if ($length < $ll) {
$result .= $word . ' ';
$ll -= $length + 1;
} else {
$result =~ s/ $/\n/;
$result .= $prefix . $word . ' ';
$ll = $columns - $length - 1;
}
}
return $result;
}
sub parse_from_string {
my $self = shift;
local($_);
$self->{CUTTING} = 1; ## Keep track of when we are cutting
$self->begin_input();
my $paragraph = '';
for (split /\n\s*\n/, $_[0]) {
$self->parse_paragraph($_ . "\n\n");
}
$self->end_input();
}
sub tag {
my $self = shift;
$self->begin_input;
$self->parse_from_string(@_);
my $result = $self->{OUT};
delete $self->{OUT};
delete $self->{TAGS};
@{$result};
}