← Back to branch summary

~percona-toolkit-dev/percona-toolkit/fix-change-master-bug-932614

« back to all changes in this revision

Viewing changes to lib/PodParser.pm

  • Committer: Daniel Nichter
  • Date: 2011-06-24 17:22:06 UTC
  • Revision ID: daniel@percona.com-20110624172206-c7q4s4ad6r260zz6
Add lib/, t/lib/, and sandbox/.  All modules are updated and passing on MySQL 5.1.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/PodParser.pm
 
1
# This program is copyright 2010-2011 Percona Inc.
 
2
# Feedback and improvements are welcome.
 
3
#
 
4
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
 
5
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 
6
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
7
#
 
8
# This program is free software; you can redistribute it and/or modify it under
 
9
# the terms of the GNU General Public License as published by the Free Software
 
10
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
 
11
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
 
12
# licenses.
 
13
#
 
14
# You should have received a copy of the GNU General Public License along with
 
15
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
 
16
# Place, Suite 330, Boston, MA  02111-1307  USA.
 
17
# ###########################################################################
 
18
# PodParser package $Revision: 7053 $
 
19
# ###########################################################################
 
20
package PodParser;
 
21
 
 
22
# This package wants to subclasses Pod::Parser but because some people
 
23
# still run ancient systems on which even "core" modules are missing,
 
24
# we have to roll our own pod parser.
 
25
 
 
26
use strict;
 
27
use warnings FATAL => 'all';
 
28
use English qw(-no_match_vars);
 
29
 
 
30
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
 
31
 
 
32
# List =item from these head1 sections will be parsed into a hash
 
33
# with the item's name as the key and its paragraphs parsed as
 
34
# another hash of attribute-value pairs.  The first para is usually
 
35
# a single line of attrib: value; ..., but this is optional.  The
 
36
# other paras are the item's description, saved under the desc key.
 
37
my %parse_items_from = (
 
38
   'OPTIONS'     => 1,
 
39
   'DSN OPTIONS' => 1,
 
40
   'RULES'       => 1,
 
41
);
 
42
 
 
43
# Pattern to match and capture the item's name after "=item ".
 
44
my %item_pattern_for = (
 
45
   'OPTIONS'     => qr/--(.*)/,
 
46
   'DSN OPTIONS' => qr/\* (.)/,
 
47
   'RULES'       => qr/(.*)/,
 
48
);
 
49
 
 
50
# True if the head1 section's paragraphs before its first =item
 
51
# define rules, one per para/line.  These rules are saved in an
 
52
# arrayref under the rules key.
 
53
my %section_has_rules = (
 
54
   'OPTIONS'     => 1,
 
55
   'DSN OPTIONS' => 0,
 
56
   'RULES'       => 0,
 
57
);
 
58
 
 
59
sub new {
 
60
   my ( $class, %args ) = @_;
 
61
   my $self = {
 
62
      current_section => '',
 
63
      current_item    => '',
 
64
      in_list         => 0,
 
65
      items           => {},  # keyed off SECTION
 
66
      magic           => {},  # keyed off SECTION->magic ident (without MAGIC_)
 
67
      magic_ident     => '',  # set when next para is a magic para
 
68
   };
 
69
   return bless $self, $class;
 
70
}
 
71
 
 
72
sub get_items {
 
73
   my ( $self, $section ) = @_;
 
74
   return $section ? $self->{items}->{$section} : $self->{items};
 
75
}
 
76
 
 
77
sub get_magic {
 
78
   my ( $self, $section ) = @_;
 
79
   return $section ? $self->{magic}->{$section} : $self->{magic};
 
80
}
 
81
 
 
82
sub parse_from_file {
 
83
   my ( $self, $file ) = @_;
 
84
   return unless $file;
 
85
 
 
86
   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
 
87
   local $INPUT_RECORD_SEPARATOR = '';  # read paragraphs
 
88
   my $para;
 
89
 
 
90
   # Skip past file contents until we reach start of POD.
 
91
   1 while defined($para = <$fh>) && $para !~ m/^=pod/;
 
92
   die "$file does not contain =pod" unless $para;
 
93
 
 
94
   while ( defined($para = <$fh>) && $para !~ m/^=cut/ ) {
 
95
      if ( $para =~ m/^=(head|item|over|back)/ ) {
 
96
         my ($cmd, $name) = $para =~ m/^=(\w+)(?:\s+(.+))?/;
 
97
         $name ||= '';
 
98
         MKDEBUG && _d('cmd:', $cmd, 'name:', $name);
 
99
         $self->command($cmd, $name);
 
100
      }
 
101
      else {
 
102
         $self->textblock($para);
 
103
      }
 
104
   }
 
105
 
 
106
   close $fh;
 
107
}
 
108
 
 
109
# Commands like =head1, =over, =item and =back.  Paragraphs following
 
110
# these command are passed to textblock().
 
111
sub command {
 
112
   my ( $self, $cmd, $name ) = @_;
 
113
   
 
114
   $name =~ s/\s+\Z//m;  # Remove \n and blank line after name.
 
115
   
 
116
   if  ( $cmd eq 'head1' && $parse_items_from{$name} ) {
 
117
      MKDEBUG && _d('In section', $name);
 
118
      $self->{current_section} = $name;
 
119
      $self->{items}->{$name}  = {};
 
120
   }
 
121
   elsif ( $cmd eq 'over' ) {
 
122
      MKDEBUG && _d('Start items in', $self->{current_section});
 
123
      $self->{in_list} = 1;
 
124
   }
 
125
   elsif ( $cmd eq 'item' ) {
 
126
      my $pat = $item_pattern_for{ $self->{current_section} };
 
127
      my ($item) = $name =~ m/$pat/;
 
128
      if ( $item ) {
 
129
         MKDEBUG && _d($self->{current_section}, 'item:', $item);
 
130
         $self->{items}->{ $self->{current_section} }->{$item} = {
 
131
            desc => '',  # every item should have a desc
 
132
         };
 
133
         $self->{current_item} = $item;
 
134
      }
 
135
      else {
 
136
         warn "Item $name does not match $pat";
 
137
      }
 
138
   }
 
139
   elsif ( $cmd eq '=back' ) {
 
140
      MKDEBUG && _d('End items');
 
141
      $self->{in_list} = 0;
 
142
   }
 
143
   else {
 
144
      $self->{current_section} = '';
 
145
      $self->{in_list}         = 0;
 
146
   }
 
147
   
 
148
   return;
 
149
}
 
150
 
 
151
# Paragraphs after a command.
 
152
sub textblock {
 
153
   my ( $self, $para ) = @_;
 
154
 
 
155
   return unless $self->{current_section} && $self->{current_item};
 
156
 
 
157
   my $section = $self->{current_section};
 
158
   my $item    = $self->{items}->{$section}->{ $self->{current_item} };
 
159
 
 
160
   $para =~ s/\s+\Z//;
 
161
 
 
162
   if ( $para =~ m/^[a-z]\w+[:;] / ) {
 
163
      MKDEBUG && _d('Item attributes:', $para);
 
164
      map {
 
165
         my ($attrib, $val) = split(/: /, $_);
 
166
         $item->{$attrib} = defined $val ? $val : 1;
 
167
      } split(/; /, $para);
 
168
   }
 
169
   else {
 
170
      # Handle MAGIC (verbatim) para signal by previous call/para.
 
171
      if ( $self->{magic_ident} ) {
 
172
 
 
173
         # Magical paras have to be indented (because they're verbatim paras).
 
174
         my ($leading_space) = $para =~ m/^(\s+)/;
 
175
         my $indent          = length($leading_space || '');
 
176
         if ( $indent ) {
 
177
            $para =~ s/^\s{$indent}//mg;
 
178
            $para =~ s/\s+$//;
 
179
            MKDEBUG && _d("MAGIC", $self->{magic_ident}, "para:", $para);
 
180
            $self->{magic}->{$self->{current_section}}->{$self->{magic_ident}}
 
181
               = $para;
 
182
         }
 
183
         else {
 
184
            MKDEBUG && _d("MAGIC", $self->{magic_ident},
 
185
               "para is not indented; treating as normal para");
 
186
         }
 
187
 
 
188
         $self->{magic_ident} = '';  # must unset this!
 
189
      }
 
190
 
 
191
      # Save the para text to the description for this item.
 
192
      MKDEBUG && _d('Item desc:', substr($para, 0, 40),
 
193
         length($para) > 40 ? '...' : '');
 
194
      $para =~ s/\n+/ /g;
 
195
      $item->{desc} .= $para;
 
196
 
 
197
      # If this para contains a MAGIC identifier, the next para should be
 
198
      # an indented (verbatim) para.  We set magic_ident to signal this and
 
199
      # handle it next call in code block above.
 
200
      if ( $para =~ m/MAGIC_(\w+)/ ) {
 
201
         $self->{magic_ident} = $1;  # XXX
 
202
         MKDEBUG && _d("MAGIC", $self->{magic_ident}, "follows");
 
203
      }
 
204
   }
 
205
 
 
206
   return;
 
207
}
 
208
 
 
209
# Indented blocks of text, e.g. SYNOPSIS examples.  We don't
 
210
# do anything with these yet.
 
211
sub verbatim {
 
212
   my ( $self, $para ) = @_;
 
213
   return;
 
214
}
 
215
 
 
216
sub _d {
 
217
   my ($package, undef, $line) = caller 0;
 
218
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
 
219
        map { defined $_ ? $_ : 'undef' }
 
220
        @_;
 
221
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
 
222
}
 
223
 
 
224
1;
 
225
 
 
226
# ###########################################################################
 
227
# End PodParser package
 
228
# ###########################################################################