lib/Pod/Constants.pm

   1 # Copyright (C) 2001, 2002, 2007 Sam Vilain.  All Rights Reserved.
   2 # This module is free software. It may be used, redistributed and/or
   3 # modified under the terms of the Perl Artistic License, version 2 or
   4 # later, OR the terms of the GNU General Public License, v3 or later.
   5
   6 package Pod::Constants;
   7
   8 use 5.006002;
   9 use strict;
  10 use warnings;
  11
  12 use base qw(Pod::Parser Exporter);
  13 use Carp;
  14
  15 our $VERSION = 0.17;
  16
  17 # An ugly hack to go from caller() to the relevant parser state
  18 # variable
  19 my %parsers;
  20
  21 sub end_input {
  22         #my ($parser, $command, $paragraph, $line_num) = (@_);
  23         my $parser = shift;
  24
  25         return unless $parser->{active};
  26
  27         print "Found end of $parser->{active}\n" if $parser->{DEBUG};
  28         my $whereto = $parser->{wanted_pod_tags}->{$parser->{active}};
  29         print "\$_ will be set to:\n---\n$parser->{paragraphs}\n---\n" if $parser->{DEBUG};
  30
  31         $parser->{paragraphs} =~ s/^\s*|\s*$//gs if $parser->{trimmed_tags}->{$parser->{active}};
  32
  33         if (ref $whereto eq "CODE") {
  34                 print "calling sub\n" if $parser->{DEBUG};
  35                 local ($_) = $parser->{paragraphs};
  36                 $whereto->();
  37                 print "done\n" if $parser->{DEBUG};
  38         } elsif (ref $whereto eq "SCALAR") {
  39                 print "inserting into scalar\n" if $parser->{DEBUG};
  40                 $$whereto = $parser->{paragraphs};
  41         } elsif (ref $whereto eq "ARRAY") {
  42                 print "inserting into array\n" if $parser->{DEBUG};
  43                 @$whereto = split /\n/, $parser->{paragraphs};
  44         } elsif (ref $whereto eq "HASH") {
  45                 print "inserting into hash\n" if $parser->{DEBUG};
  46                 # Oh, sorry, should I be in LISP101?
  47                 %$whereto = (
  48                         map { map { s/^\s*|\s*$//g; $_ } split /=>/, $_ } grep m/^
  49                                          ( (?:[^=]|=[^>])+ )   # scan up to "=>"
  50                                          =>
  51                                          ( (?:[^=]|=[^>])+ =? )# don't allow more "=>"'s
  52                                          $/x, split /\n/, $parser->{paragraphs});
  53         } else { die $whereto }
  54         $parser->{active} = undef;
  55 }
  56
  57 # Pod::Parser overloaded command
  58 sub command {
  59         my ($parser, $command, $paragraph, $line_num) = @_;
  60
  61         $paragraph =~ s/(?:\r\n|\n\r)/\n/g;
  62
  63         print "Got command =$command, value=$paragraph\n" if $parser->{DEBUG};
  64
  65         $parser->end_input() if $parser->{active};
  66
  67         my ($lookup);
  68         # first check for a catch-all for this command type
  69         if ( exists $parser->{wanted_pod_tags}->{"*$command"} ) {
  70                 $parser->{paragraphs} = $paragraph;
  71                 $parser->{active} = "*$command";
  72         } elsif ($command =~ m/^(head\d+|item|(for|begin))$/) {
  73                 if ( $2 ) {
  74                         # if it's a "for" or "begin" section, the title is the
  75                         # first word only
  76                         ($lookup, $parser->{paragraphs}) = $paragraph =~ m/^\s*(\S*)\s*(.*)/s;
  77                 } else {
  78                         # otherwise, it's up to the end of the line
  79                         ($lookup, $parser->{paragraphs}) = $paragraph =~ m/^\s*(\S[^\n]*?)\s*\n(.*)$/s;
  80                 }
  81
  82                 # Look for a match by name
  83                 if (defined $lookup && exists $parser->{wanted_pod_tags}->{$lookup}) {
  84                         print "Found $lookup\n" if ($parser->{DEBUG});
  85                         $parser->{active} = $lookup;
  86                 } elsif ($parser->{DEBUG}) {
  87                         local $^W = 0;
  88                         print "Ignoring =$command $paragraph (lookup = $lookup)\n"
  89                 }
  90
  91         } else {
  92                 # nothing
  93                 print "Ignoring =$command (not known)\n" if $parser->{DEBUG};
  94         }
  95 }
  96
  97 # Pod::Parser overloaded verbatim
  98 sub verbatim {
  99         my ($parser, $paragraph, $line_num) = @_;
 100         $paragraph =~ s/(?:\r\n|\n\r)/\n/g;
 101
 102         my $status = $parser->{active} ? "using" : "ignoring";
 103         print "Got paragraph: $paragraph ($status)\n" if $parser->{DEBUG};
 104
 105         $parser->{paragraphs} .= $paragraph if defined $parser->{active}
 106 }
 107
 108 # Pod::Parser overloaded textblock
 109 sub textblock { goto \&verbatim }
 110
 111 sub import {
 112         my $class = shift;
 113
 114         # if no args, just return
 115         return unless (@_);
 116
 117         # try to guess the source file of the caller
 118         my $source_file;
 119         if (caller ne "main") {
 120                 (my $module = caller().".pm") =~ s|::|/|g;
 121                 $source_file = $INC{$module};
 122         }
 123         $source_file ||= $0;
 124
 125         croak "Cannot find source file (guessed $source_file) for package ".caller unless -f $source_file;
 126
 127         # nasty tricks with the stack so we don't have to be silly with
 128         # caller()
 129         unshift @_, $source_file;
 130         goto \&import_from_file;
 131 }
 132
 133 use IO::Handle;
 134
 135 sub import_from_file {
 136         my $filename = shift;
 137
 138         my $parser = __PACKAGE__->new();
 139
 140         $parser->{wanted_pod_tags} = {};
 141         $parser->{trimmed_tags} = {};
 142         $parser->{trim_next} = 0;
 143         $parser->{DEBUG} = 0;
 144         $parser->{active} = undef;
 145         $parsers{caller()} = $parser;
 146
 147         $parser->add_hook(@_);
 148
 149         print "Pod::Parser: DEBUG: Opening $filename for reading\n" if $parser->{DEBUG};
 150         my $fh = new IO::Handle;
 151         open $fh, "<$filename" or die "cannot open $filename for reading; $!";
 152
 153         $parser->parse_from_filehandle($fh, \*STDOUT);
 154
 155         close $fh;
 156 }
 157
 158 sub add_hook {
 159         my $parser;
 160         if (UNIVERSAL::isa($_[0], __PACKAGE__)) {
 161                 $parser = shift;
 162         } else {
 163                 $parser = $parsers{caller()} or die "add_hook called, but don't know what for - caller = ".caller;
 164         }
 165         while (my ($pod_tag, $var) = splice @_, 0, 2) {
 166                 #print "$pod_tag: $var\n";
 167                 if (lc($pod_tag) eq "-trim") {
 168                         $parser->{trim_next} = $var;
 169                 } elsif ( lc($pod_tag) eq "-debug" ) {
 170                         $parser->{DEBUG} = $var;
 171                 } elsif (lc($pod_tag) eq "-usage") {
 172                         # an idea for later - automatic "usage"
 173                         #%wanted_pod_tags{@tags}
 174                 } else {
 175                         if ((ref $var) =~ /^(?:SCALAR|CODE|ARRAY|HASH)$/) {
 176                                 print "Will look for $pod_tag.\n" if $parser->{DEBUG};
 177                                 $parser->{wanted_pod_tags}->{$pod_tag} = $var;
 178                                 $parser->{trimmed_tags}->{$pod_tag} = 1 if $parser->{trim_next};
 179                         } else {
 180                                 die "Sorry - need a reference to import POD sections into, not the scalar value $var"
 181                         }
 182                 }
 183         }
 184 }
 185
 186 sub delete_hook {
 187         my $parser;
 188         if ( UNIVERSAL::isa($_[0], __PACKAGE__) ) {
 189                 $parser = shift;
 190         } else {
 191                 $parser = $parsers{caller()} or die "delete_hook called, but don't know what for - caller = ".caller;
 192         }
 193         while ( my $label = shift ) {
 194                 delete $parser->{wanted_pod_tags}->{$label};
 195                 delete $parser->{trimmed_tags}->{$label};
 196         }
 197 }
 198
 199 1.4142;
 200 __END__
 201
 202 =encoding utf-8
 203
 204 =head1 NAME
 205
 206 Pod::Constants - Include constants from POD
 207
 208 =head1 SYNOPSIS
 209
 210  our ($myvar, $VERSION, @myarray, $html, %myhash);
 211
 212  use Pod::Constants -trim => 1,
 213      'Pod Section Name' => \$myvar,
 214      'Version' => sub { eval },
 215      'Some list' => \@myarray,
 216      html => \$html,
 217      'Some hash' => \%myhash;
 218
 219  =head2 Pod Section Name
 220
 221  This string will be loaded into $myvar
 222
 223  =head2 Version
 224
 225  # This is an example of using a closure.  $_ is set to the
 226  # contents of the paragraph.  In this example, "eval" is
 227  # used to execute this code at run time.
 228  $VERSION = 0.17;
 229
 230  =head2 Some list
 231
 232  Each line from this section of the file
 233  will be placed into a separate array element.
 234  For example, this is $myarray[2].
 235
 236  =head2 Some hash
 237
 238  This text will not go into the hash, because
 239  it doesn't look like a definition list.
 240      key1 => Some value (this will go into the hash)
 241      var2 => Some Other value (so will this)
 242      wtf = This won't make it in.
 243
 244  =head2 %myhash's value after the above:
 245
 246     ( key1 => "Some value (this will go into the hash)",
 247       var2 => "Some Other value (so will this)"          )
 248
 249  =begin html <p>This text will be in $html</p>
 250
 251  =cut
 252
 253 =head1 DESCRIPTION
 254
 255 This module allows you to specify those constants that should be
 256 documented in your POD, and pull them out a run time in a fairly
 257 arbitrary fashion.
 258
 259 Pod::Constants uses Pod::Parser to do the parsing of the source file.
 260 It has to open the source file it is called from, and does so directly
 261 either by lookup in %INC or by assuming it is $0 if the caller is
 262 "main" (or it can't find %INC{caller()})
 263
 264 =head2 ARBITARY DECISIONS
 265
 266 I have made this code only allow the "Pod Section Name" to match
 267 `headN', `item', `for' and `begin' POD sections.  If you have a good
 268 reason why you think it should match other POD sections, drop me a
 269 line and if I'm convinced I'll put it in the standard version.
 270
 271 For `for' and `begin' sections, only the first word is counted as
 272 being a part of the specifier, as opposed to `headN' and `item', where
 273 the entire rest of the line counts.
 274
 275 =head1 FUNCTIONS
 276
 277 =head2 import(@args)
 278
 279 This function is called when we are "use"'d.  It determines the source
 280 file by inspecting the value of caller() or $0.
 281
 282 The form of @args is HOOK => $where.
 283
 284 $where may be a scalar reference, in which case the contents of the
 285 POD section called "HOOK" will be loaded into $where.
 286
 287 $where may be an array reference, in which case the contents of the
 288 array will be the contents of the POD section called "HOOK", split
 289 into lines.
 290
 291 $where may be a hash reference, in which case any lines with a "=>"
 292 symbol present will have everything on the left have side of the =>
 293 operator as keys and everything on the right as values.  You do not
 294 need to quote either, nor have trailing commas at the end of the
 295 lines.
 296
 297 $where may be a code reference (sub { }), in which case the sub is
 298 called when the hook is encountered.  $_ is set to the value of the
 299 POD paragraph.
 300
 301 You may also specify the behaviour of whitespace trimming; by default,
 302 no trimming is done except on the HOOK names.  Setting "-trim => 1"
 303 turns on a package "global" (until the next time import is called)
 304 that will trim the $_ sent for processing by the hook processing
 305 function (be it a given function, or the built-in array/hash
 306 splitters) for leading and trailing whitespace.
 307
 308 The name of HOOK is matched against any "=head1", "=head2", "=item",
 309 "=for", "=begin" value.  If you specify the special hooknames "*item",
 310 "*head1", etc, then you will get a function that is run for every
 311
 312 Note that the supplied functions for array and hash splitting are
 313 exactly equivalent to fairly simple Perl blocks:
 314
 315 Array:
 316
 317   HOOK => sub { @array = split /\n/, $_ }
 318
 319 Hash:
 320
 321   HOOK => sub {
 322   %hash =
 323       (map { map { s/^\s+|\s+$//g; $_ } split /=>/, $_ }
 324         (grep m/^
 325             ( (?:[^=]|=[^>])+ )   # scan up to "=>"
 326             =>
 327             ( (?:[^=]|=[^>])+ =? )# don't allow more "=>"'s
 328             $/x, split /\n/, $_));
 329   }
 330
 331 Well, they're simple if you can grok map, a regular expression like
 332 that and a functional programming style.  If you can't I'm sure it is
 333 probably voodoo to you.
 334
 335 Here's the procedural equivalent:
 336
 337   HOOK => sub {
 338      for my $line (split /\n/, $_) {
 339          my ($key, $value, $junk) = split /=>/, $line;
 340          next if $junk;
 341          $key =~ s/^\s+|\s+$//g
 342          $value =~ s/^\s+|\s+$//g
 343          $hash{$key} = $value;
 344      }
 345   },
 346
 347 =head2 import_from_file($filename, @args)
 348
 349 Very similar to straight "import", but you specify the source filename
 350 explicitly.
 351
 352 =head2 add_hook(NAME => value)
 353
 354 This function adds another hook, it is useful for dynamic updating of
 355 parsing through the document.
 356
 357 For an example, please see t/01-constants.t in the source
 358 distribution.  More detailed examples will be added in a later
 359 release.
 360
 361 =head2 delete_hook(@list)
 362
 363 Deletes the named hooks.  Companion function to add_hook
 364
 365 =head2 CLOSURES AS DESTINATIONS
 366
 367 If the given value is a ref CODE, then that function is called, with
 368 $_ set to the value of the paragraph.  This can be very useful for
 369 applying your own custom mutations to the POD to change it from human
 370 readable text into something your program can use.
 371
 372 After I added this function, I just kept on thinking of cool uses for
 373 it.  The nice, succinct code you can make with it is one of
 374 Pod::Constant's strongest features.
 375
 376 Below are some examples.
 377
 378 =head1 EXAMPLES
 379
 380 =head2 Module Makefile.PL maintenance
 381
 382 Tired of keeping those module Makefile.PL's up to date?  Note: This
 383 method seems to break dh-make-perl.
 384
 385 =head2 Example Makefile.PL
 386
 387  eval "use Pod::Constants";
 388  ($Pod::Constants::VERSION >= 0.11)
 389      or die <<EOF
 390  ####
 391  ####  ERROR: This module requires Pod::Constants 0.11 or
 392  ####  higher to be installed.
 393  ####
 394  EOF
 395
 396  my ($VERSION, $NAME, $PREREQ_PM, $ABSTRACT, $AUTHOR);
 397  Pod::Constants::import_from_file
 398      (
 399       'MyTestModule.pm',
 400       'MODULE RELEASE' => sub { ($VERSION) = m/(\d+\.\d+)/ },
 401       'DEPENDENCIES' => ($PREREQ_PM = { }),
 402        -trim => 1,
 403       'NAME' => sub { $ABSTRACT=$_; ($NAME) = m/(\S+)/ },
 404       'AUTHOR' => \$AUTHOR,
 405      );
 406
 407  WriteMakefile
 408      (
 409       'NAME'        => $NAME,
 410       'PREREQ_PM'        => $PREREQ_PM,
 411       'VERSION'          => $VERSION,
 412       ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
 413        (ABSTRACT         => $ABSTRACT,
 414         AUTHOR           => $AUTHOR) : ()),
 415      );
 416
 417 =head2 Corresponding Module
 418
 419  =head1 NAME
 420
 421  MyTestModule - Demonstrate Pod::Constant's Makefile.PL usefulness
 422
 423  =head2 MODULE RELEASE
 424
 425  This is release 1.05 of this module.
 426
 427  =head2 DEPENDENCIES
 428
 429  The following modules are required to make this module:
 430
 431     Some::Module => 0.02
 432
 433  =head2 AUTHOR
 434
 435  Ima Twat <ima@twat.name>
 436
 437  =cut
 438
 439  our $VERSION;
 440  use Pod::Constants -trim => 1,
 441      'MODULE RELEASE' => sub { ($VERSION) = m/(\d+\.\d+) or die };
 442
 443 =head1 AUTHOR
 444
 445 Sam Vilain, <samv@cpan.org>
 446
 447 =head1 BUGS/TODO
 448
 449 I keep thinking it would be nice to be able to import an =item list
 450 into an array or something, eg for a program argument list.  But I'm
 451 not too sure how it would be all that useful in practice; you'd end up
 452 putting the function names for callbacks in the pod or something
 453 (perhaps not all that bad).
 454
 455 Would this be useful?
 456
 457  Pod::Constants::import(Foo::SECTION => \$myvar);
 458
 459 Debug output is not very readable
 460
 461 =head1 PATCHES WELCOME
 462
 463 If you have any suggestions for enhancements, they are much more likely
 464 to happen if you submit them as a patch to the distribution.
 465
 466 Source is kept at
 467
 468   git://utsl.gen.nz/Pod-Constants
 469
 470
 471 =cut