lib/Pod/Constants.pm

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