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 sub import_from_file {
 134         my $filename = shift;
 135
 136         my $parser = __PACKAGE__->new();
 137
 138         $parser->{wanted_pod_tags} = {};
 139         $parser->{trimmed_tags} = {};
 140         $parser->{trim_next} = 0;
 141         $parser->{DEBUG} = 0;
 142         $parser->{active} = undef;
 143         $parsers{caller()} = $parser;
 144
 145         $parser->add_hook(@_);
 146
 147         print "Pod::Parser: DEBUG: Opening $filename for reading\n" if $parser->{DEBUG};
 148         open my $fh, '<', $filename or croak "cannot open $filename for reading; $!";
 149
 150         $parser->parse_from_filehandle($fh, \*STDOUT);
 151
 152         close $fh;
 153 }
 154
 155 sub add_hook {
 156         my $parser;
 157         if (eval { $_[0]->isa(__PACKAGE__) }) {
 158                 $parser = shift;
 159         } else {
 160                 $parser = $parsers{caller()} or croak 'add_hook called, but don\'t know what for - caller = '.caller;
 161         }
 162         while (my ($pod_tag, $var) = splice @_, 0, 2) {
 163                 #print "$pod_tag: $var\n";
 164                 if (lc($pod_tag) eq '-trim') {
 165                         $parser->{trim_next} = $var;
 166                 } elsif ( lc($pod_tag) eq '-debug' ) {
 167                         $parser->{DEBUG} = $var;
 168                 } elsif (lc($pod_tag) eq '-usage') {
 169                         # an idea for later - automatic "usage"
 170                         #%wanted_pod_tags{@tags}
 171                 } else {
 172                         if ((ref $var) =~ /^(?:SCALAR|CODE|ARRAY|HASH)$/) {
 173                                 print "Will look for $pod_tag.\n" if $parser->{DEBUG};
 174                                 $parser->{wanted_pod_tags}->{$pod_tag} = $var;
 175                                 $parser->{trimmed_tags}->{$pod_tag} = 1 if $parser->{trim_next};
 176                         } else {
 177                                 croak "Sorry - need a reference to import POD sections into, not the scalar value $var"
 178                         }
 179                 }
 180         }
 181 }
 182
 183 sub delete_hook {
 184         my $parser;
 185         if (eval { $_[0]->isa(__PACKAGE__) }) {
 186                 $parser = shift;
 187         } else {
 188                 $parser = $parsers{caller()} or croak 'delete_hook called, but don\'t know what for - caller = '.caller;
 189         }
 190         while ( my $label = shift ) {
 191                 delete $parser->{wanted_pod_tags}->{$label};
 192                 delete $parser->{trimmed_tags}->{$label};
 193         }
 194 }
 195
 196 1;
 197 __END__
 198
 199 =encoding utf-8
 200
 201 =head1 NAME
 202
 203 Pod::Constants - Include constants from POD
 204
 205 =head1 SYNOPSIS
 206
 207  our ($myvar, $VERSION, @myarray, $html, %myhash);
 208
 209  use Pod::Constants -trim => 1,
 210      'Pod Section Name' => \$myvar,
 211      'Version' => sub { eval },
 212      'Some list' => \@myarray,
 213      html => \$html,
 214      'Some hash' => \%myhash;
 215
 216  =head2 Pod Section Name
 217
 218  This string will be loaded into $myvar
 219
 220  =head2 Version
 221
 222  # This is an example of using a closure.  $_ is set to the
 223  # contents of the paragraph.  In this example, "eval" is
 224  # used to execute this code at run time.
 225  $VERSION = 0.17;
 226
 227  =head2 Some list
 228
 229  Each line from this section of the file
 230  will be placed into a separate array element.
 231  For example, this is $myarray[2].
 232
 233  =head2 Some hash
 234
 235  This text will not go into the hash, because
 236  it doesn't look like a definition list.
 237      key1 => Some value (this will go into the hash)
 238      var2 => Some Other value (so will this)
 239      wtf = This won't make it in.
 240
 241  =head2 %myhash's value after the above:
 242
 243     ( key1 => "Some value (this will go into the hash)",
 244       var2 => "Some Other value (so will this)"          )
 245
 246  =begin html <p>This text will be in $html</p>
 247
 248  =cut
 249
 250 =head1 DESCRIPTION
 251
 252 This module allows you to specify those constants that should be
 253 documented in your POD, and pull them out a run time in a fairly
 254 arbitrary fashion.
 255
 256 Pod::Constants uses Pod::Parser to do the parsing of the source file.
 257 It has to open the source file it is called from, and does so directly
 258 either by lookup in %INC or by assuming it is $0 if the caller is
 259 "main" (or it can't find %INC{caller()})
 260
 261 =head2 ARBITARY DECISIONS
 262
 263 I have made this code only allow the "Pod Section Name" to match
 264 `headN', `item', `for' and `begin' POD sections.  If you have a good
 265 reason why you think it should match other POD sections, drop me a
 266 line and if I'm convinced I'll put it in the standard version.
 267
 268 For `for' and `begin' sections, only the first word is counted as
 269 being a part of the specifier, as opposed to `headN' and `item', where
 270 the entire rest of the line counts.
 271
 272 =head1 FUNCTIONS
 273
 274 =head2 import(@args)
 275
 276 This function is called when we are "use"'d.  It determines the source
 277 file by inspecting the value of caller() or $0.
 278
 279 The form of @args is HOOK => $where.
 280
 281 $where may be a scalar reference, in which case the contents of the
 282 POD section called "HOOK" will be loaded into $where.
 283
 284 $where may be an array reference, in which case the contents of the
 285 array will be the contents of the POD section called "HOOK", split
 286 into lines.
 287
 288 $where may be a hash reference, in which case any lines with a "=>"
 289 symbol present will have everything on the left have side of the =>
 290 operator as keys and everything on the right as values.  You do not
 291 need to quote either, nor have trailing commas at the end of the
 292 lines.
 293
 294 $where may be a code reference (sub { }), in which case the sub is
 295 called when the hook is encountered.  $_ is set to the value of the
 296 POD paragraph.
 297
 298 You may also specify the behaviour of whitespace trimming; by default,
 299 no trimming is done except on the HOOK names.  Setting "-trim => 1"
 300 turns on a package "global" (until the next time import is called)
 301 that will trim the $_ sent for processing by the hook processing
 302 function (be it a given function, or the built-in array/hash
 303 splitters) for leading and trailing whitespace.
 304
 305 The name of HOOK is matched against any "=head1", "=head2", "=item",
 306 "=for", "=begin" value.  If you specify the special hooknames "*item",
 307 "*head1", etc, then you will get a function that is run for every
 308
 309 Note that the supplied functions for array and hash splitting are
 310 exactly equivalent to fairly simple Perl blocks:
 311
 312 Array:
 313
 314   HOOK => sub { @array = split /\n/, $_ }
 315
 316 Hash:
 317
 318   HOOK => sub {
 319   %hash =
 320       (map { map { s/^\s+|\s+$//g; $_ } split /=>/, $_ }
 321         (grep m/^
 322             ( (?:[^=]|=[^>])+ )   # scan up to "=>"
 323             =>
 324             ( (?:[^=]|=[^>])+ =? )# don't allow more "=>"'s
 325             $/x, split /\n/, $_));
 326   }
 327
 328 Well, they're simple if you can grok map, a regular expression like
 329 that and a functional programming style.  If you can't I'm sure it is
 330 probably voodoo to you.
 331
 332 Here's the procedural equivalent:
 333
 334   HOOK => sub {
 335      for my $line (split /\n/, $_) {
 336          my ($key, $value, $junk) = split /=>/, $line;
 337          next if $junk;
 338          $key =~ s/^\s+|\s+$//g
 339          $value =~ s/^\s+|\s+$//g
 340          $hash{$key} = $value;
 341      }
 342   },
 343
 344 =head2 import_from_file($filename, @args)
 345
 346 Very similar to straight "import", but you specify the source filename
 347 explicitly.
 348
 349 =head2 add_hook(NAME => value)
 350
 351 This function adds another hook, it is useful for dynamic updating of
 352 parsing through the document.
 353
 354 For an example, please see t/01-constants.t in the source
 355 distribution.  More detailed examples will be added in a later
 356 release.
 357
 358 =head2 delete_hook(@list)
 359
 360 Deletes the named hooks.  Companion function to add_hook
 361
 362 =head2 CLOSURES AS DESTINATIONS
 363
 364 If the given value is a ref CODE, then that function is called, with
 365 $_ set to the value of the paragraph.  This can be very useful for
 366 applying your own custom mutations to the POD to change it from human
 367 readable text into something your program can use.
 368
 369 After I added this function, I just kept on thinking of cool uses for
 370 it.  The nice, succinct code you can make with it is one of
 371 Pod::Constant's strongest features.
 372
 373 Below are some examples.
 374
 375 =head1 EXAMPLES
 376
 377 =head2 Module Makefile.PL maintenance
 378
 379 Tired of keeping those module Makefile.PL's up to date?  Note: This
 380 method seems to break dh-make-perl.
 381
 382 =head2 Example Makefile.PL
 383
 384  eval "use Pod::Constants";
 385  ($Pod::Constants::VERSION >= 0.11)
 386      or die <<EOF
 387  ####
 388  ####  ERROR: This module requires Pod::Constants 0.11 or
 389  ####  higher to be installed.
 390  ####
 391  EOF
 392
 393  my ($VERSION, $NAME, $PREREQ_PM, $ABSTRACT, $AUTHOR);
 394  Pod::Constants::import_from_file
 395      (
 396       'MyTestModule.pm',
 397       'MODULE RELEASE' => sub { ($VERSION) = m/(\d+\.\d+)/ },
 398       'DEPENDENCIES' => ($PREREQ_PM = { }),
 399        -trim => 1,
 400       'NAME' => sub { $ABSTRACT=$_; ($NAME) = m/(\S+)/ },
 401       'AUTHOR' => \$AUTHOR,
 402      );
 403
 404  WriteMakefile
 405      (
 406       'NAME'        => $NAME,
 407       'PREREQ_PM'        => $PREREQ_PM,
 408       'VERSION'          => $VERSION,
 409       ($] >= 5.005 ?    ## Add these new keywords supported since 5.005
 410        (ABSTRACT         => $ABSTRACT,
 411         AUTHOR           => $AUTHOR) : ()),
 412      );
 413
 414 =head2 Corresponding Module
 415
 416  =head1 NAME
 417
 418  MyTestModule - Demonstrate Pod::Constant's Makefile.PL usefulness
 419
 420  =head2 MODULE RELEASE
 421
 422  This is release 1.05 of this module.
 423
 424  =head2 DEPENDENCIES
 425
 426  The following modules are required to make this module:
 427
 428     Some::Module => 0.02
 429
 430  =head2 AUTHOR
 431
 432  Ima Twat <ima@twat.name>
 433
 434  =cut
 435
 436  our $VERSION;
 437  use Pod::Constants -trim => 1,
 438      'MODULE RELEASE' => sub { ($VERSION) = m/(\d+\.\d+) or die };
 439
 440 =head1 AUTHOR
 441
 442 Sam Vilain, <samv@cpan.org>
 443
 444 =head1 BUGS/TODO
 445
 446 I keep thinking it would be nice to be able to import an =item list
 447 into an array or something, eg for a program argument list.  But I'm
 448 not too sure how it would be all that useful in practice; you'd end up
 449 putting the function names for callbacks in the pod or something
 450 (perhaps not all that bad).
 451
 452 Would this be useful?
 453
 454  Pod::Constants::import(Foo::SECTION => \$myvar);
 455
 456 Debug output is not very readable
 457
 458 =head1 PATCHES WELCOME
 459
 460 If you have any suggestions for enhancements, they are much more likely
 461 to happen if you submit them as a patch to the distribution.
 462
 463 Source is kept at
 464
 465   git://utsl.gen.nz/Pod-Constants
 466
 467
 468 =cut