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};
}
1	dpavlin	106	# -- Mode: Perl --
2			# WAIT::Parse::Pod --
3			# ITIID : $ITI$ $Header $__Header$
4			# Author : Ulrich Pfeifer
5			# Created On : Sat Dec 14 17:38:29 1996
6			# Last Modified By: Ulrich Pfeifer
7			# Last Modified On: Sun Nov 22 18:44:40 1998
8			# Language : CPerl
9			# Update Count : 275
10			# Status : Unknown, Use with caution!
11			#
12			# Copyright (c) 1996-1997, Ulrich Pfeifer
13			#
14			package WAIT::Parse::Pod;
15			use Pod::Parser;
16			use Carp;
17			use vars qw(@ISA %GOOD_HEADER);
18
19			# Got tired reinstalling Pod::Parser after each perl rebuild. So I renamed
20			# Pod::Text to Pod::PText. Thus this hack:
21			BEGIN {
22			eval {require Pod::PText;};
23			if ($@ ne '') {
24			require Pod::Text;
25			croak "Need Pod::Tex version > 2.0" if $Pod::Text::VERSION < 2.0;
26			@ISA = qw(Pod::Text Pod::Parser WAIT::Parse::Base);
27			} else {
28			@ISA = qw(Pod::PText Pod::Parser WAIT::Parse::Base);
29			}
30			}
31			use Text::Tabs qw(expand);
32			use strict;
33
34
35
36			# recognized =head1 headers
37			%GOOD_HEADER = (
38			name => 1,
39			synopsis => 1,
40			options => 1,
41			description => 1,
42			author => 1,
43			example => 1,
44			bugs => 1,
45			text => 1,
46			see => 1,
47			environment => 1,
48			);
49
50			sub default_indent () {4};
51
52			# make frequent tag sets reusable
53			my $CODE = {text => 1, _c => 1};
54			my $BOLD = {text => 1, _b => 1};
55			my $ITALIC = {text => 1, _i => 1};
56			my $PLAIN = {text => 1};
57
58			sub new {
59			my $this = shift;
60			my $class = ref($this) \|\| $this;
61			my $self = $this->SUPER::new(@_);
62			bless $self, $class;
63			}
64
65			sub begin_input {
66			my $self = shift;
67
68			$self->indent(default_indent);
69			$self->{TAGS} = {};
70			$self->{OUT} = [];
71			}
72
73			sub indent {
74			my $self = shift;
75
76			if (@_) {
77			$self->{INDENT} = shift;
78			}
79			$self->{INDENT};
80			}
81
82			# Stolen afrom Pod::Parser by Tom Christiansen and Brad Appleton and modified
83			sub interpolate {
84			my $self = shift;
85			my ($text, $end_re) = @_;
86
87			$text = '' unless (defined $text);
88			$end_re = "\$" unless ((defined $end_re) && ($end_re ne ''));
89			local($_) = $text;
90			my @result;
91
92			my ($seq_cmd, $seq_arg, $end) = ('', '', undef);
93			while (($_ ne '') && /([A-Z])<\|($end_re)/) {
94			# Only text after the match remains to be processed
95			$_ = $';
96			# Append text before the match to the result
97			push @result, $self->{TAGS}, $`;
98			# See if we matched an interior sequence or an end-expression
99			($seq_cmd, $end) = ($1, $2);
100			last if (defined $end); # Saw the end - quit loop here
101			# At this point we have found an interior sequence,
102			# we need to obtain its argument
103			if ($seq_cmd =~ /^([FBIC])/) {
104			my $tag = '_' . lc $1;
105			my $tags = $self->{TAGS};
106			my %tags = (%{$tags}, $tag => 1);
107			$self->{TAGS} = \%tags;
108			push @result, $self->interpolate($_, '>');
109			$self->{TAGS} = $tags;
110			} else {
111			my @seq_arg = $self->interpolate($_, '>');
112			my $i;
113
114			for ($i=1;$i<=@seq_arg;$i+=2) {
115			push @result, $seq_arg[$i-1],
116			$self->interior_sequence($seq_cmd, $seq_arg[$i]);
117			}
118			}
119			}
120			## Handle whatever is left if we didnt match the ending regexp
121			unless ((defined $end) && ($end_re ne "\$")) {
122			push @result, $self->{TAGS}, $_;
123			$_ = '';
124			}
125			## Modify the input parameter to consume the text that was
126			## processed so far.
127			$_[0] = $_;
128			## Return the processed-text
129			return @result;
130			}
131
132			sub textblock {
133			my ($self, $text) = @_;
134
135			$self->output($self->interpolate($self->wrap($text)), $PLAIN, "\n\n");
136			}
137
138			sub output {
139			my ($self) = shift;
140
141			while (@_) {
142			my $tags = shift;
143			my $text = shift;
144			croak "Bad tags parameter: '$tags'" unless ref($tags);
145			push @{$self->{OUT}}, $tags, $text;
146			}
147			}
148
149			sub verbatim {
150			my ($self, $text) = @_;
151			my $indent = $self->indent() + default_indent;
152
153			$text = expand($text);
154			my ($prefix) = ($text =~ /^(\s+)/);
155
156			if (length($prefix) < $indent) {
157			my $add = ' ' x ($indent - length($prefix));
158			$text =~ s/^/$add/gm;
159			} elsif (length($prefix) > $indent) {
160			my $sub = ' ' x (length($prefix) - $indent);
161			$text =~ s/^$sub//gm;
162			}
163			$self->output($CODE, $text);
164			}
165
166			sub command {
167			my ($self, $cmd, $arg, $sep) = @_;
168
169			if ($cmd =~ /^head(\d)/) {
170			my $indent = $1-1;
171			my $tags = $self->{TAGS};
172
173			$self->{TAGS} = $BOLD;
174			$self->output($self->interpolate($self->wrap($arg,
175			$indent*default_indent)."\n\n"));
176			if ($indent) {
177			$self->{TAGS} = $tags;
178			} else {
179			my $sarg = lc $arg;
180			$sarg =~ s/\s.*//g;
181			if ($GOOD_HEADER{$sarg}) {
182			$self->{TAGS} = {lc $sarg => 1}
183			} else {
184			$self->{TAGS} = {text => 1}
185			}
186			}
187			} elsif ($cmd =~ /^back/) {
188			$self->indent(default_indent);
189			} elsif ($cmd =~ /^over/) {
190			my $indent = (($arg)?$arg:default_indent) + default_indent;
191			$self->indent($indent);
192			} elsif ($cmd =~ /^item/) {
193			$self->output($self->interpolate($self->wrap($arg,default_indent)."\n\n"))
194			} else {
195			$self->output($self->{TAGS}, $arg);
196			}
197			}
198
199			# inspired from Text::Wrap by David Muir Sharnoff
200			sub wrap {
201			my ($self, $t, $indent) = @_;
202			$indent = $self->indent unless defined $indent;
203
204			my $columns = 76 - $indent;
205			my $ll = $columns;
206			my $prefix = ' ' x $indent;
207			my $result = $prefix;
208			my $length;
209
210			# E/L will probably change length
211			$t =~ s/([EL])<(.*?)>/$self->interior_sequence($1,$2)/eg;
212			$t =~ s/\s+/ /g;
213			while ($t =~ s/^(\S+)\s?//o) {
214			my $word = $1;
215
216			# inline length calculation for speed
217			my $dummy = $word;
218			$dummy =~ s/[A-Z]<(.*?)>/$1/og;
219			$length = length($dummy);
220
221			if ($length < $ll) {
222			$result .= $word . ' ';
223			$ll -= $length + 1;
224			} else {
225			$result =~ s/ $/\n/;
226			$result .= $prefix . $word . ' ';
227			$ll = $columns - $length - 1;
228			}
229			}
230			return $result;
231			}
232
233
234			sub parse_from_string {
235			my $self = shift;
236			local($_);
237
238			$self->{CUTTING} = 1; ## Keep track of when we are cutting
239			$self->begin_input();
240
241			my $paragraph = '';
242			for (split /\n\s*\n/, $_[0]) {
243			$self->parse_paragraph($_ . "\n\n");
244			}
245
246			$self->end_input();
247			}
248
249
250			sub tag {
251			my $self = shift;
252
253			$self->begin_input;
254			$self->parse_from_string(@_);
255			my $result = $self->{OUT};
256			delete $self->{OUT};
257			delete $self->{TAGS};
258			@{$result};
259			}