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 |
|
|
} |