1 |
# -*- 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 |
} |