File Coverage

blib/lib/PDL/Doc.pm

Criterion	Covered	Total	%
statement	231	335	68.9
branch	57	142	40.1
condition	37	79	46.8
subroutine	40	54	74.0
pod	16	19	84.2
total	381	629	60.5

# the filter for the PDL pod format (which is a valid general perl
# pod format but with special interpretation of some =for directives)

package # hide from PAUSE/MetaCPAN
  PDL::Doc::SelectJustPod;
use strict;
use warnings;
use parent qw(Pod::Simple::JustPod);

sub select_head1s {
  my ($self, @titles) = @_;
  $self->{interested_head1s}{$_} = 1 for @titles;
  $self;
}

sub select_head2 {
  my ($self, $name) = @_;
  $self->{interested_head2} = $name;
  $self;
}

sub end_head1 {
  my $self = shift;
  my ($text) = $self->{buffer} =~ /=head1 +(.*)\z/;
  $self->{current_head1} = $text;
  delete $self->{current_head2};
  $self->SUPER::end_head1(@_);
}

sub end_head2 {
  my $self = shift;
  my ($text) = $self->{buffer} =~ /=head2 +(.*)\z/;
  $self->{current_head2} = $text;
  $self->SUPER::end_head2(@_);
}

sub start_for {
  my $self = shift;
  my ($attrs) = @_;
  $self->{buffer} .= "@$attrs{qw(~really target)}\n\n";
}

sub emit {
  my ($self) = @_;
  print { $self->{output_fh} } $self->{buffer}, "\n\n" # superclass adds "" at start which inserts a space
    if $self->{buffer} ne ''
    and $self->{interested_head1s}{$self->{current_head1} // ''}
    and ($self->{current_head2}//'') =~ /\b\Q$self->{interested_head2}\E\b/;
  $self->{buffer} = "";
}

sub end_Document { # only override is not adding "=cut"
  my $self = shift;
  $self->emit;        # Make sure buffer gets flushed
}

package # hide from PAUSE/MetaCPAN
  PDL::PodParser;
use strict;
use warnings;
use PDL::Core '';
use Pod::Simple::PullParser;
use parent qw(Pod::Text);

our %Title = ('Example' => 'Example',
	  'Ref'     => 'Reference',
	  'Sig'     => 'Signature',
	  'Opt'     => 'Options',
	  'Usage'   => 'Usage',
          'Bad'     => 'Bad value support',
	 );

my @h1s = qw(OPERATORS FUNCTIONS CONSTRUCTORS METHODS);
sub new {
  my $class = shift;
  my $parser = $class->SUPER::new(@_);
  $parser->accept_targets(qw(bad example ref options sig usage));
  @{ $parser->{interested_head1s} }{@h1s} = (1) x @h1s;
  $parser->{CURFUNC} = undef;
  $parser->{SYMHASH} = {};
  $parser->{Mode} = "";
  $parser->{verbose} = 0;
  $parser->{NAME} = 'UNKNOWN';
  $parser;
}

sub cmd_head1 {
  my ($this, $attrs, $text) = @_;
  $this->{Mode} = $text;
  $this->{Parmode} = $text =~ /NAME/ ? 'NAME' : 'Body';
  '';
}

sub cmd_head2 {
  my ($this, $attrs, $text) = @_;
  return if $text =~ /^The\s/; # heuristic to deal with GSL::CDF descriptive =head2
  return if !$this->{interested_head1s}{$this->{Mode} // ''};
  # A function can have multiple names (ex: zeros and zeroes),
  # so split at the commas
  my @funcs = split ',', $text;
  # Remove parentheses (so myfunc and myfunc() both work)
  my @names = map {$1 if m/\s*([^\s\(]+)\s*/} @funcs;
  barf "error parsing function list '$text'"
    unless @funcs == @names;
  # check for signatures
  my $sym = $this->{SYMHASH};
  for (@funcs) {
    $sym->{$1}{Module} = $this->{NAME} if m/\s*([^\s(]+)\s*/;
    $sym->{$1}{Sig} = $2               if m/\s*([^\s(]+)\s*\(\s*(.+)\s*\)\s*$/;
  }
  # make the first one the current function
  $sym->{$names[0]}{Names} = join(',',@names) if $#names > 0;
  my $name = shift @names;
  # Make the other names cross-reference the first name
  $sym->{$_}{Crossref} = $name for @names;
  my $sig = $sym->{$name}{Sig};
  # diagnostic output
  print "\nFunction '".join(',',($name,@names))."'\n" if $this->{verbose};
  print "\n\tSignature: $sig\n" if defined $sig && $this->{verbose};
  $this->{CURFUNC} = $name;
}

sub cmd_for {
  my ($this, $attrs, $text) = @_;
  return if !$this->{interested_head1s}{$this->{Mode} // ''};
  my $tgt = $attrs->{target};
  $tgt = 'opt' if $tgt eq 'options';
  $this->{Parmode} = ucfirst lc $tgt;
  print "switched now to '$tgt' mode\n" if $this->{verbose};
  print "\n\t$Title{$this->{Parmode}}\n"
    if $this->{Parmode} !~ /Body/ && $this->{verbose};
  '';
}

sub cmd_para {
  my ($this, $attrs, $text) = @_;
  return if $this->{Mode} ne 'NAME' and !$this->{interested_head1s}{$this->{Mode} // ''};
  $this->checkmode($text);
  $this->{Parmode} = 'Body'; # and reset parmode
}

sub checkmode {
  my ($this,$txt,$verbatim) = @_;
  if ($this->{Mode} =~ /NAME/ && $this->{Parmode} =~ /NAME/) {
    $this->{NAME} = $1 if $this->trim($txt) =~ /^\s*(\S+)\s*/;
    print "\nNAME\t$this->{NAME}\n" if $this->{verbose};
    $this->{Parmode} = 'Body';
    return;
  }
  unless ($this->{Parmode} =~ /Body/) {
    my $func = $this->{CURFUNC};
    die "no function defined\n" unless defined $func;
    $this->{SYMHASH}{$func}{$this->{Parmode}} .=
      $this->trim($txt,$verbatim);
    my $cr = ($verbatim && $this->{Parmode} ne 'Sig') ? "\n" : "";
    my $out = "\n\t\t$cr".$this->trim($txt,$verbatim);
    print "$out\n$cr" if $this->{verbose};
  }
  $this->{Parmode} = 'Body';
}

sub cmd_verbatim {
  my ($this, $attrs, $text) = @_;
  return if !$this->{interested_head1s}{$this->{Mode} // ''};
  $this->checkmode($text,1);
}

# this needs improvement
# and any formatting information should be removed?
# it probably depends
sub trim {
  my ($this,$txt,$verbatim) = @_;
  my $ntxt = "";
  $txt =~ s/(signature|usage):\s*//i if $this->{Parmode} eq 'Sig' ||
			   $this->{Parmode} eq 'Usage';
  if ($this->{Parmode} eq 'Sig') {
    $txt =~ s/^\s*//;
    $txt =~ s/\s*$//;
    while( $txt =~ s/^\((.*)\)$/$1/ ) {}; # Strip BALANCED brackets
  }
  for (split "\n", $txt) {
    s/^\s*(.*)\s*$/$1/ unless $verbatim;
    $ntxt .= "$_\n" unless m/^\s*$/;
  }
  # $txt =~ s/^\s*(.*)\s*$/$1/;
  chomp $ntxt;
  return $ntxt;
}

=head1 NAME

PDL::Doc - support for PDL online documentation

=head1 SYNOPSIS

  use PDL::Doc;
  $onlinedc = PDL::Doc->new($docfile);
  @match = $onlinedc->search('m/slice|clump/');

=head1 DESCRIPTION

An implementation of online docs for PDL.

=head1 Using PDL documentation

PDL::Doc's main use is in the "help" (synonym "?") and "apropos"
(synonym "??") commands in the perldl shell.  PDL::Doc provides the
infrastrucure to index and access PDL's documentation through these
commands.  There is also an API for direct access to the documentation
database (see below).

The PDL doc system is built on Perl's pod (Plain Old Documentation),
included inline with each module. The PDL core modules are
automatically indexed when PDL is built and installed, and there is
provision for indexing external modules as well.

To include your module's pod into the Perl::Doc index, you should
follow the documentation conventions below.

=head1 PDL documentation conventions

For a package like PDL that has I of functions it
is very desirable to have some form of online help to
make it easy for users to remind themselves of names,
calling conventions and typical usage of the multitude
of functions at their disposal. To make it straightforward
to extract the relevant information from the POD documentation
in source files that make up the PDL distribution
certain conventions have been adopted in formatting this
documentation.

The first convention says that all documentation for
PDL functions appears in the POD section introduced
by one of the following:

  =head1 FUNCTIONS
  =head1 OPERATORS
  =head1 METHODS
  =head1 CONSTRUCTORS

If you're documenting an object-oriented interface to a class
that your module defines, you should use METHODS and CONSTRUCTORS
as appropriate.  If you are simply adding functions to PDL,
use FUNCTIONS and OPERATORS as appropriate.

Individual functions or methods in these section are introduced by

  =head2 funcname

where signature is the argumentlist for a PP defined function as
explained in L. Generally, PDL documentation is in valid POD
format (see L) but uses the C<=for> directive in a
special (and non-conformant) way. The C<=for> directive is used to
flag to the PDL Pod
parser that information is following that will be used to generate
online help. In the POD standard, C<=for> is used to provide
information in I paragraph. PDL uses it to signal information
is in the I paragraph.

The PDL Pod parser recognises the following C<=for> directives:

=over 5

=item Ref

indicates that the one line reference for this function follows,
e.g.,

   =for ref

   Returns an ndarray of lags to parent.

=item Sig

the signature for the current function follows, e.g.,

   =for sig

      Signature: (a(n), [o]b(), [t]tmp(n))

=item Usage

an indication of the possible calling conventions for the current
function, e.g.,

   =for usage

      wpic($pdl,$filename[,{ options... }])

=item Options

lists options for the current function, e.g.,

   =for options

      CONVERTER  => 'ppmtogif',   # explicitly specify pbm converter
      FLAGS      => '-interlaced -transparent 0',  # flags for converter
      IFORM      => 'PGM',        # explicitly specify intermediate format
      XTRAFLAGS  => '-imagename iris', # additional flags to defaultflags
      FORMAT     => 'PCX',        # explicitly specify output image format
      COLOR      => 'bw',         # specify color conversion
      LUT        => $lut,         # use color table information


=item Example

gives examples of typical usage for the current function:

   =for example

       wpic $pdl, $file;
       $im->wpic('web.gif',{LUT => $lut});
       for (@images) {
         $_->wpic($name[0],{CONVERTER => 'ppmtogif'})
       }

=item Bad

provides information on how the function handles bad values. The
documentation under this directive should indicate if this function
accepts ndarrays with bad values and under what circumstances this function
might return ndarrays with bad values.

=back

The PDL podparser is implemented as a simple state machine. Any of
the above C<=for> statements switches the podparser into a state
where the following paragraph is accepted as information for the
respective field (C, C, C, C or C).
Only the text up to
the end of the current paragraph is accepted, for example:

  =for example

         ($x,$y) = $z->func(1,3);  # this is part of the accepted info
         $x = func($z,0,1);        # this as well

         $x = func($c,$d);         # but this isn't

To make the resulting pod documentation also easily digestible for the
existing pod filters (pod2man, pod2text, pod2html, etc) the actual
textblock of information must be separated from the C<=for> directive
by at least one blank line. Otherwise, the textblock will be lost in
the translation process when the "normal" podformatters are used. The
general idea behind this format is that it should be easy to extract
the information for online documentation, automatic generation of a
reference card, etc but at the same time the documentation should be
translated by the standard podformatters without loss of contents
(and without requiring any changes in the existing POD format).

The preceding explanations should be further explained by the
following example (extracted from PDL/IO/Misc/misc.pd):

   =head2 rcols()

   =for ref

   Read ASCII whitespaced cols from file into ndarrays efficiently.

   If no columns are specified all are assumed
   Will optionally only process lines matching a pattern.
   Can take file name or *HANDLE.

   =for usage

    Usage: ($x,$y,...) = rcols(*HANDLE|"filename", ["/pattern/",$col1, $col2,] ...)

   e.g.,

   =for example

     ($x,$y)    = rcols 'file1'
     ($x,$y,$z) = rcols 'file2', "/foo/",3,4
     $x = PDL->rcols 'file1';

   Note: currently quotes are required on the pattern.


which is translated by, e.g, the standard C converter into:

  rcols()

    Read ASCII whitespaced cols from file into ndarrays efficiently.

    If no columns are specified all are assumed Will optionally only
    process lines matching a pattern. Can take file name or *HANDLE.

      Usage: ($x,$y,...) = rcols(*HANDLE|"filename", ["/pattern/",$col1, $col2,] ...)

    e.g.,

      ($x,$y)    = rcols 'file1'
      ($x,$y,$z) = rcols 'file2', "/foo/",3,4
      $x = PDL->rcols 'file1';

    Note: currently quotes are required on the pattern.

It should be clear from the preceding example that readable output
can be obtained from this format using the standard converters and
the reader will hopefully get a feeling how they can easily intersperse
the special C<=for> directives with the normal POD documentation.

=head2 Which directives should be contained in the documentation

The module documentation should
start with the

  =head1 NAME

  PDL::Modulename -- do something with ndarrays

section (as anyway required by C) since the PDL podparser
extracts the name of the module this function belongs to from
that section.

Each function that is I only for internal use by the module
should be documented, introduced with the C<=head2> directive
in the C<=head1 FUNCTIONS> section. The only field that every function
documented along these lines should have is the I field preceding
a one line description of its intended functionality (suitable for
inclusion in a concise reference card). PP defined functions (see L)
should have a I field stating their signature. To facilitate
maintenance of this documentation for such functions the 'Doc' field
has been introduced into the definition of C (see again L)
which will take care that name and signature of the so defined function
are documented in this way (for examples of this usage see, for example,
L.
Similarly, the 'BadDoc' field provides a means of
specifying information on how the routine handles the presence of
bad values: this will be automatically created if
C is not supplied, or set to C.

Furthermore, the documentation for each function should contain
at least one of the I or I fields. Depending on the
calling conventions for the function under consideration presence
of both fields may be warranted.

If a function has options that should be given as a hash reference in
the form

   {Option => Value, ...}

then the possible options (and aproppriate values) should be explained
in the textblock following the C<=for Opt> directive (see example above
and, e.g., PDL::IO::Pic).

It is well possible that some of these conventions appear to be clumsy
at times and the author is keen to hear of any suggestions for better
alternatives.

=cut

package PDL::Doc;
use strict;
use warnings;
use PDL::Core '';
use File::Basename;
use File::Spec::Functions qw(file_name_is_absolute abs2rel rel2abs catdir catfile);
use Cwd (); # to help Debian packaging
use Config;
use Encode;

our $pager = $ENV{PERLDOC_PAGER} // $ENV{PAGER} // $Config{pager};

=head1 METHODS

=head2 new

  $onlinedc = PDL::Doc->new('file.pdl',[more files]);

=cut

sub new {
  my ($type,@files) = @_;
  my $this = bless {},$type;
  $this->{File} = [@files];
  $this->{Scanned} = [];
  $this->{Outfile} = $files[0];
  $this;
}

=head2 new_from_hash

  $onlinedc = PDL::Doc->new_from_hash(\%hash);

The hash must conform to the 3-level hash format.

=cut

sub new_from_hash {
  my ($type, $hash) = @_;
  my $this = bless {},$type;
  $this->{File} = [];
  $this->{Scanned} = [];
  $this->{SYMS} = $hash;
  $this;
}

=head2 addfiles

add another file to the online database associated with this object.

=cut

sub addfiles {
  my ($this,@files) = @_;
  push @{$this->{File}}, @files;
}

=head2 outfile

set the name of the output file for this online db

=cut

sub outfile {
  my ($this,$file) = @_;
  $this->{Outfile} = $file if defined $file;
  return $this->{Outfile};
}

=head2 ensuredb

Make sure that the database is slurped in

=cut

sub ensuredb {
  my ($this) = @_;
  while (my $fi = pop @{$this->{File}}) {
    open my $fh, $fi or barf "can't open database $fi, scan docs first";
    my $got_hash = decodedb($fh, $fi);
    merge_hash($this->{SYMS} ||= {}, $got_hash);
    push @{$this->{Scanned}}, $fi;
  }
  return $this->{SYMS};
}

=head2 savedb

save the database (i.e., the hash of PDL symbols) to the file associated
with this object.

=cut

sub savedb {
  my ($this) = @_;
  my $hash = $this->ensuredb;
  open my $fh, '>', $this->{Outfile} or barf "can't write to symdb $this->{Outfile}: $!";
  encodedb($hash, $fh, dirname($this->{Outfile}));
}

=head2 gethash

Return the PDL symhash (e.g. for custom search operations). To see what
it has stored in it in JSON format:

  perl -MPDL::Doc -MJSON::PP -e \
    'print encode_json +PDL::Doc->new(PDL::Doc::_find_inc([qw(PDL pdldoc.db)]))->gethash' |
    json_pp -json_opt pretty,canonical

The symhash is a multiply nested hash ref with the following structure:

 $symhash = {
     function_name => {
             module::name => {
                  Module => 'module::name',
                  Sig    => 'signature string',
                  Bad    => 'bad documentation string',
                  ...
             },
     },
     function_name => {
             module::name => {
                  Module => 'module::name',
                  Sig    => 'signature string',
                  Bad    => 'bad documentation string',
                  ...
             },
     },
 };

The three-layer structure is designed to allow the symhash (and the
underlying database) to handle functions that have the same name but
reside in different module namespaces.

The possible keys for each function/module entry include:

 Module   - module name
 Sig      - signature
 Crossref - the function name for the documentation, if it has multiple
            names (ex: the documentation for zeros is under zeroes)
 Names    - a comma-separated string of all the function's names
 Example  - example text (optional)
 Ref      - one-line reference string
 Opt      - options
 Usage    - short usage explanation
 Bad      - explanation of behavior when it encounters bad values

=cut

sub gethash { $_[0]->ensuredb }

=head2 search

Search a PDL symhash

=for usage

  $onldc->search($regex, $fields [, $sort])

Searching is by default case insensitive. Other flags can be
given by specifying the regexp in the form C
where C can be replaced with any other non-alphanumeric
character. $fields is an array reference for all hash fields
(or simply a string if you only want to search one field)
that should be matched against the regex. Valid fields are

  Name,    # name of the function
  Module,  # module the function belongs to
  Ref,     # the one-line reference description
  Example, # the example for this function
  Opt,     # options
  File,    # the path to the source file these docs have been extracted from

If you wish to have your results sorted by function name, pass a true
value for C<$sort>.

The results will be returned as an array of triplets in the form

 @results = (
  [funcname, module, {SYMHASH_ENTRY}],
  [funcname, module, {SYMHASH_ENTRY}],
  ...
 );

See the example at the end of the documentation to see how you might
use this.

=cut


sub search {
  my ($this,$pattern,$fields,$sort) = @_;
  $sort = 0 unless defined $sort;
  my $hash = $this->ensuredb;
  my @match = ();

  # Make a single scalar $fields work
  $fields = [$fields] if ref($fields) eq '';

  $pattern = $this->checkregex($pattern);

  while (my ($name,$mods_hash) = each %$hash) {
    while (my ($module,$val) = each %$mods_hash) {
      FIELD: for (@$fields) {
        if ($_ eq 'Name' and $name =~ /$pattern/i
            or defined $val->{$_} and $val->{$_} =~ /$pattern/i
        ) {
          $val = $hash->{$val->{Crossref}}{$module} #we're going to assume that any Crossref'd documentation is also in this module
            if defined $val->{Crossref} && defined $hash->{$val->{Crossref}}{$module};
          push @match, [$name,$module,$val];
          last FIELD;
        }
      }
    }
  }
  @match = sort {$a->[0] cmp $b->[0]} @match if (@match && $sort);
  return @match;
}


# parse a regexp in the form
#   m/^[a-z]+/ismx
# where the pairs of '/' can be replaced by any other pair of matching
# characters
# if the expression doesn't start with 'm' followed by a nonalphanumeric
# character,  return as-is
sub checkregex {
  my ($this,$regex) = @_;
  return "(?i)$regex" unless $regex =~ /^m[^a-z,A-Z,0-9]/;
  my $sep = substr($regex,1,1);
  substr($regex,0,2) = '';
  $sep = '(?

  my ($pattern,$mod) = split($sep,$regex,2);
  barf "unknown regex modifiers '$mod'" if $mod && $mod !~ /[imsx]+/;
  $pattern = "(?$mod)$pattern" if $mod;
  return $pattern;
}

=head2 scan

Scan a source file using the PDL podparser to extract information
for online documentation

=cut

sub scan {
  my ($this,$file,$verbose) = @_;
  barf "can't find file '$file'" unless -f $file;
  $file = Cwd::abs_path($file); # help Debian packaging
  $verbose = 0 unless defined $verbose;
  my $text = do { open my $infile, '<', $file or die "$file: $!"; local $/; <$infile> };
  # Handle RPM etc. case where we are building away from the final location
  my $file2 = $file;
  $file2 =~ s/^$ENV{BUILDROOTPREFIX}// if $ENV{BUILDROOTPREFIX};
  my $mod_hash = scantext($text, $file2, $verbose);
  merge_hash($this->{SYMS} ||= {}, $mod_hash);
  scalar values %$mod_hash; # how many functions found
}

=head2 scantree

Scan whole directory trees for online documentation in
C<.pm> (module definition) and C<*.pod> (general
documentation) files (using the File::Find module).

=cut

sub scantree {
  my ($this,$dir,$verbose) = @_;
  $verbose = 0 unless defined $verbose;
  require File::Find;
  print "Scanning $dir ... \n\n";
  my $ntot = 0;
  my $sub = sub {
    return if -d $File::Find::name;
    return if
      $File::Find::dir !~ /script$/ and
      $File::Find::name !~ /\.(?:pm|pod)$/;
    return if $File::Find::name =~ /(?:Index\.pod|PP\.pm)$/ or
      $File::Find::dir =~ m#/PP#;
    printf "%-20s", $_.'...';
    $ntot += my $n = $this->scan($File::Find::name,$verbose);
    print "\t$n functions\n";
  };
  File::Find::find({
    no_chdir => 1,
    wanted => $sub,
    preprocess => sub { sort @_ }
  }, $dir);
  print "\nfound $ntot functions\n";
  $ntot;
}


=head2 funcdocs

extract the complete documentation about a function from its
source file using the PDL::PodParser filter.

=cut

sub funcdocs {
  my ($this,$func,$module,$fout) = @_;
  my $hash = $this->ensuredb;
  barf "unknown function '$func'" unless defined($hash->{$func});
  barf "funcdocs now requires 3 arguments" if defined fileno $module;
  my $file = $hash->{$func}{$module}{File};
  my $dbf = $hash->{$func}{$module}{Dbfile};
  $file = Cwd::abs_path($file) if file_name_is_absolute($file);
  $dbf = Cwd::abs_path($dbf); # help Debian packaging
  $file = rel2abs($file, dirname($dbf))
    if !file_name_is_absolute($file) && $dbf;
  funcdocs_fromfile($func,$file,$fout);
}

=head1 FUNCTIONS

=head2 decodedb

  $hash = decodedb($fh, $filename);

Decode the 3-level hash out of a saved PDL::Doc database.

=cut

sub decodedb {
  my ($fh, $filename) = @_;
  binmode $fh;
  my %hash;
  while (read $fh, my $plen, 2) {
    my ($len) = unpack "v", $plen;
    read $fh, my($txt), $len;
    $txt = Encode::decode('UTF-8', $txt);
    my ($sym, $module, @a) = split chr(0), $txt;
    push @a, "" if @a % 2; # Add null string at end if necessary -- solves bug with missing REF section.
    $hash{$sym}{$module} = { @a, Dbfile => $filename }; # keep the origin pdldoc.db path
  }
  \%hash;
}

=head2 merge_hash

  merge_hash(\%pdldoc_into, \%pdldoc_from); # for 3-level hash only

Merge a 3-level PDL::Doc hash into another one.

=cut

sub merge_hash {
  my ($into, $from) = @_;
  for my $func (keys %$from) {
    my $val = $from->{$func};
    # copy the 3-layer hash/database structure: $into->{funcname}{'PDL::SomeModule'} = {Ref=>...}
    for my $func_mod (keys %$val) {
      $into->{$func}{$func_mod} = $val->{$func_mod};
    }
  }
}

=head2 encodedb

  encodedb($hash, $fh, $outdir);

=cut

sub encodedb {
  my ($hash, $fh, $outdir) = @_;
  binmode $fh;
  for my $name (sort keys %$hash) {
    my $mods_hash = $hash->{$name};
    for my $module (sort keys %$mods_hash) {
      my $val = $mods_hash->{$module};
      my $fi = $val->{File};
      $val->{File} = abs2rel($fi, $outdir)
        #store paths to *.pm files relative to pdldoc.db
        if file_name_is_absolute($fi) && -f $fi;
      delete $val->{Dbfile}; # no need to store Dbfile
      my $txt = Encode::encode('UTF-8', join chr(0),$name,$module,map +($_=>$val->{$_}), sort keys %$val);
      print $fh pack("v",length($txt)).$txt;
    }
  }
}

=head2 scantext

  $hash = scantext($module_text, $filename, $verbose);

Scan a single string (intended to be the contents of a file),
returning a hash of the functions found therein.

=cut

sub scantext {
  my ($text, $filename, $verbose) = @_;
  my $parser = PDL::PodParser->new;
  $parser->{verbose} = $verbose;
  open my $outfile, '>', \(my $outfile_text);
  $parser->output_fh($outfile);
  eval { $parser->parse_string_document($text) };
  warn "cannot parse: $@" if $@ and $@ ne "no function defined\n";
  my %hash;
  $_->{File} = $filename for values %{ $parser->{SYMHASH} };
  for my $key (sort keys %{ $parser->{SYMHASH} }) {
    my $val = $parser->{SYMHASH}{$key};
    #set up the 3-layer hash/database structure: $hash{funcname}{'PDL::SomeModule'} = $val
    if (defined($val->{Module})) {
      $hash{$key}{$val->{Module}} = $val;
    } else {
      warn "no Module for $key in $filename\n";
    }
  }
  # pass2 - scan for module name and function
  $parser = Pod::Simple::PullParser->new;
  $parser->set_source(\$text);
  my $title = eval { $parser->get_title };
  warn("cannot parse '$filename'"), return \%hash if $@;
  my ($name,$does) = split /\s*-+\s*/, $title, 2;
  $does = 'Hmmm ????' if $does and $does =~ /^\s*$/;
  my $type =
    $filename =~ /script/ ? 'Script:' :
    $filename =~ /\.pod$/ ? 'Manual:' :
      'Module:';
  $hash{$name}{$name} = {Ref=>"$type $does",File=>$filename} if $name and $name !~ /^\s*$/;
  \%hash;
}

sub funcdocs_fromfile {
  my ($func,$file) = @_;
  barf "can't find file '$file'" unless -f $file;
  local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager
  open my $in, '<', $file or barf "can't open file $file";
  my $out = $_[2];
  open $out, "| pod2text | $PDL::Doc::pager" if !defined $out;
  barf "can't open output handle" unless $out;
  getfuncdocs($func,$in,$out);
  print $out "Docs from $file\n\n";
}

sub getfuncdocs {
  my ($func,$in,$out) = @_;
  my $parser = PDL::Doc::SelectJustPod->new;
  $parser->select_head1s(qw(OPERATORS FUNCTIONS CONSTRUCTORS METHODS));
  $parser->select_head2($func);
  $parser->parse_from_file($in,$out);
}

=head2 add_module

=for usage

 use PDL::Doc;
 PDL::Doc::add_module("PDL::Stats"); # add PDL::Stats, PDL::Stats::GLM, ...

=for ref

The C function allows you to add POD from a particular Perl
module (and as of PDL 2.083, in fact all modules starting with that as
a prefix) that you've installed somewhere in C<@INC>. It searches for the
active PDL document database and the module's .pod and .pm files, and
scans and indexes the module(s) into the database.

C is meant to be added to your module's Makefile as part of the
installation script. This is done automatically by
L, but if the top level of your
distribution is Perl modules (like L), then add a
C manually in the F:

  use PDL::Core::Dev;
  sub MY::postamble {
    my $oneliner = PDL::Core::Dev::_oneliner(qq{exit if \$ENV{DESTDIR}; use PDL::Doc; eval { PDL::Doc::add_module(shift); }});
    qq|\ninstall :: pure_install\n\t$oneliner \$(NAME)\n|;
  }

=cut

sub _find_inc {
  my ($what, $want_dir) = @_;
  my @ret;
  for my $dir (@INC) {
    my $ent = $want_dir ? catdir($dir, @$what) : catfile($dir, @$what);
    push @ret, $ent if $want_dir ? -d $ent : -f $ent;
  }
  @ret;
}

sub add_module {
  my ($module) = @_;
  my ($file) = _find_inc([qw(PDL pdldoc.db)], 0);
  die "Unable to find docs database - therefore not updating it.\n" if !defined $file;
  die "No write permission for $file - not updating docs database.\n"
    if !-w $file;
  print "Found docs database $file\n";
  my $pdldoc = PDL::Doc->new($file);
  my @pkg = my @mfile = split /::/, $module;
  my $mlast = pop @mfile;
  my @found = map _find_inc([@mfile, $mlast.$_]), qw(.pm .pod);
  die "Unable to find a .pm or .pod file in \@INC for module $module\n" if !@found;
  $pdldoc->ensuredb;
  my $n = 0;
  $n += $pdldoc->scan($_) for @found;
  print "Added @found, $n functions.\n";
  $n += $pdldoc->scantree($_) for _find_inc(\@pkg, 1);
  eval { $pdldoc->savedb; };
  warn $@ if $@;
  print "PDL docs database updated - total $n functions.\n";
}

=head1 PDL::DOC EXAMPLE

Here's an example of how you might use the PDL Doc database in your
own code.

 use PDL::Doc;
 # Find the pdl documentation
 my ($file) = _find_inc([qw(PDL pdldoc.db)], 0);
 die "Unable to find docs database!\n" unless defined $file;
 print "Found docs database $file\n";
 my $pdldoc = PDL::Doc->new($file);
 # Print the reference line for zeroes:
 print map{$_->{Ref}} values %{$pdldoc->gethash->{zeroes}};
 # Or, if you remember that zeroes is in PDL::Core:
 print $pdldoc->gethash->{zeroes}{'PDL::Core'}{Ref};

 # Get info for all the functions whose examples use zeroes
 my @entries = $pdldoc->search('zeroes','Example',1,1);

 # All the functions that use zeroes in their example:
 print "Functions that use 'zeroes' in their examples include:\n";
 foreach my $entry (@entries) {
     # Unpack the entry
     my ($func_name, $module, $sym_hash) = @$entry;
     print "$func_name\n";
 }
 print "\n";

 #Or, more concisely:
 print map "$_->[0]\n", @entries;

 # Let's look at the function 'mpdl'
 @entries = $pdldoc->search('mpdl', 'Name');
 # I know there's only one:
 my $entry = $entries[0];
 my ($func_name, undef, $sym_hash) = @$entry;
 print "mpdl info:\n";
 foreach my $key (sort keys %$sym_hash) {
     # Unpack the entry
     print "---$key---\n$sym_hash->{$key}\n";
 }

=head2 Finding Modules

How can you tell if you've got a module for one of your entries?
The Ref entry will begin with 'Module:' if it's a module. In code:

 # Prints:
 #  Module: fundamental PDL functionality and vectorization/broadcasting
 print $pdldoc->gethash->{'PDL::Core'}{'PDL::Core'}{Ref}, "\n"

=head1 BUGS

Quite a few shortcomings which will hopefully be fixed following
discussions on the pdl-devel mailing list.

=head1 AUTHOR

Copyright 1997 Christian Soeller [e-mail]
and Karl Glazebrook [e-mail]

Further contributions copyright 2010 David Mertens
[e-mail]

Documentation database restructuring 2019 Derek Lamb

All rights reserved. There is no warranty. You are allowed
to redistribute this software / documentation under certain
conditions. For details, see the file COPYING in the PDL
distribution. If this file is separated from the PDL distribution,
the copyright notice should be included in the file.

=cut

1;