WAIT/Parse/Nroff.pm

#                              -*- Mode: Perl -*- 
# Nroff.pm -- 
# ITIID           : $ITI$ $Header $__Header$
# Author          : Ulrich Pfeifer
# Created On      : Mon Sep 16 15:54:25 1996
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Sun Nov 22 18:44:41 1998
# Language        : CPerl
# Update Count    : 160
# Status          : Unknown, Use with caution!
# 
# Copyright (c) 1996-1997, Ulrich Pfeifer
# 

package WAIT::Parse::Nroff;
require WAIT::Parse::Base;
use vars qw(@ISA %GOOD_HEADER $DEFAULT_HEADER);
@ISA = qw(WAIT::Parse::Base);

%GOOD_HEADER = (
                name         => 1,
                synopsis     => 1,
                options      => 1,
                description  => 1,
                author       => 1,
                example      => 1,
                bugs         => 1,
                text         => 1,
                see          => 1,
                environment  => 1,
               );
my $HEADER_REGEXP = uc join '|', keys %GOOD_HEADER;
$DEFAULT_HEADER = 'text';

sub split {                     # called as method
  my %result;
  my $fld    = $DEFAULT_HEADER;    # do not drop any words
  my $indent = 8;
  # initialize to make perl -w happy
  @result{keys %GOOD_HEADER} = ('') x scalar(keys %GOOD_HEADER);
  
  $_[1] =~ s/-\s*\n\s*//g;
  $_[1] =~ s/.//g;
  for (split /\n/, $_[1]) {
    if (s/^(\s*)($HEADER_REGEXP)\b//o) {
      my $id = length($1);
      if ($id <= $indent) {
        $fld = lc($2);
        if ($id < $indent) {
          # Some weired systems (IRIX) have a left margin here!
          # so let's adapt to the smallest one
          $indent = $id;
        }
      }
    }

    $result{$fld} .= $_ . ' ';
  }
  #print STDERR "\n";
  return \%result;              # we go for speed
}

sub tag {                       # called as method
  my @result;
  my $tag  = $DEFAULT_HEADER;   # do not drop any words
  my $text = '';
  my $line = 0;

  for (split /\n/, $_[1]) {
    $line++;
    $line -= 66 if $line > 66;
    next if $line <  5;
    next if $line >  62;
    next if $line <  8   and /^\s*$/;
    next if $line >  59  and /^\s*$/;
    if (s/^((([A-Z])(\3)+){3,})//) {
      my $header = WAIT::Filter::unroff($1);
      push @result, _tag($text, $tag);
      $text = '';
      push @result, {_b => 1}, $header;
      $header = lc $header;
      $tag = ($GOOD_HEADER{$header}?$header:$DEFAULT_HEADER);
    }
    $text .= "$_\n";
  }
  push @result, _tag($text, $tag);
  return @result;               # we don't go for speed
}

sub _tag {
  local($_) = shift;
  my $tag   = shift;

  return unless defined $tag;
  #print STDERR "$tag-";
  my @result;
  my ($b, $i, $n);
  if (defined $tag) {
    $b = {$tag => 1, _b => 1};
    $i = {$tag => 1, _i => 1};
    $n = {$tag => 1};
  } else {
    $b = {_b => 1};
    $i = {_i => 1};
    $n = {};
  }
  while (length($_)) {
    if (s/^(((.)(\3)+)+\s*)//o) {
      push @result, $b, WAIT::Filter::unroff($1);
    } elsif (s/^((_.)+)//o) {
      push @result, $i, WAIT::Filter::unroff($1);
    } elsif (s/^([^]+)(.)/$2/o) {
      push @result, $n, $1;
    } else {
      s/.//g;
      push @result, $n, $_;
      $_ = '';
    }
  }
  #print STDERR '+';
  @result;
}


package WAIT::Filter;

sub unroff {
  my $text = shift;
  $text =~ s/.//g;
  $text;
}

1;
__END__
sub bold {
  join '', map "$_($_)+", grep /./, split /(.)/, $_[0];
}

1	ulpfr	10	# -- Mode: Perl --
2			# Nroff.pm --
3			# ITIID : $ITI$ $Header $__Header$
4			# Author : Ulrich Pfeifer
5			# Created On : Mon Sep 16 15:54:25 1996
6			# Last Modified By: Ulrich Pfeifer
7			# Last Modified On: Sun Nov 22 18:44:41 1998
8			# Language : CPerl
9			# Update Count : 160
10			# Status : Unknown, Use with caution!
11			#
12			# Copyright (c) 1996-1997, Ulrich Pfeifer
13			#
14
15			package WAIT::Parse::Nroff;
16			require WAIT::Parse::Base;
17			use vars qw(@ISA %GOOD_HEADER $DEFAULT_HEADER);
18			@ISA = qw(WAIT::Parse::Base);
19
20			%GOOD_HEADER = (
21			name => 1,
22			synopsis => 1,
23			options => 1,
24			description => 1,
25			author => 1,
26			example => 1,
27			bugs => 1,
28			text => 1,
29			see => 1,
30			environment => 1,
31			);
32			my $HEADER_REGEXP = uc join '\|', keys %GOOD_HEADER;
33			$DEFAULT_HEADER = 'text';
34
35			sub split { # called as method
36			my %result;
37			my $fld = $DEFAULT_HEADER; # do not drop any words
38			my $indent = 8;
39			# initialize to make perl -w happy
40			@result{keys %GOOD_HEADER} = ('') x scalar(keys %GOOD_HEADER);
41
42			$_[1] =~ s/-\s\n\s//g;
43			$_[1] =~ s/.//g;
44			for (split /\n/, $_[1]) {
45			if (s/^(\s*)($HEADER_REGEXP)\b//o) {
46			my $id = length($1);
47			if ($id <= $indent) {
48			$fld = lc($2);
49			if ($id < $indent) {
50			# Some weired systems (IRIX) have a left margin here!
51			# so let's adapt to the smallest one
52			$indent = $id;
53			}
54			}
55			}
56
57			$result{$fld} .= $_ . ' ';
58			}
59			#print STDERR "\n";
60			return \%result; # we go for speed
61			}
62
63			sub tag { # called as method
64			my @result;
65			my $tag = $DEFAULT_HEADER; # do not drop any words
66			my $text = '';
67			my $line = 0;
68
69			for (split /\n/, $_[1]) {
70			$line++;
71			$line -= 66 if $line > 66;
72			next if $line < 5;
73			next if $line > 62;
74			next if $line < 8 and /^\s*$/;
75			next if $line > 59 and /^\s*$/;
76			if (s/^((([A-Z])(\3)+){3,})//) {
77			my $header = WAIT::Filter::unroff($1);
78			push @result, _tag($text, $tag);
79			$text = '';
80			push @result, {_b => 1}, $header;
81			$header = lc $header;
82			$tag = ($GOOD_HEADER{$header}?$header:$DEFAULT_HEADER);
83			}
84			$text .= "$_\n";
85			}
86			push @result, _tag($text, $tag);
87			return @result; # we don't go for speed
88			}
89
90			sub _tag {
91			local($_) = shift;
92			my $tag = shift;
93
94			return unless defined $tag;
95			#print STDERR "$tag-";
96			my @result;
97			my ($b, $i, $n);
98			if (defined $tag) {
99			$b = {$tag => 1, _b => 1};
100			$i = {$tag => 1, _i => 1};
101			$n = {$tag => 1};
102			} else {
103			$b = {_b => 1};
104			$i = {_i => 1};
105			$n = {};
106			}
107			while (length($_)) {
108			if (s/^(((.)(\3)+)+\s*)//o) {
109			push @result, $b, WAIT::Filter::unroff($1);
110			} elsif (s/^((_.)+)//o) {
111			push @result, $i, WAIT::Filter::unroff($1);
112			} elsif (s/^([^]+)(.)/$2/o) {
113			push @result, $n, $1;
114			} else {
115			s/.//g;
116			push @result, $n, $_;
117			$_ = '';
118			}
119			}
120			#print STDERR '+';
121			@result;
122			}
123
124
125			package WAIT::Filter;
126
127			sub unroff {
128			my $text = shift;
129			$text =~ s/.//g;
130			$text;
131			}
132
133			1;
134			__END__
135			sub bold {
136			join '', map "$_($_)+", grep /./, split /(.)/, $_[0];
137			}
138