1=head1 NAME
2
3PDL::Doc::Perldl - commands for accessing PDL doc database from 'perldl' shell
4
5=head1 DESCRIPTION
6
7This module provides a simple set of functions to
8access the PDL documentation of database, for use
9from the I<perldl> or I<pdl2> shells as well as the
10I<pdldoc> command-line program.
11
12Autoload files are also matched, via a search of the PDLLIB autoloader
13tree.  That behavior can be switched off with the variable
14C<$PERLDL::STRICT_DOCS> (true: don't search autoload tree; false: search
15the autoload tree.)
16
17Currently, multiple matches are not handled very well.
18
19=head1 SYNOPSIS
20
21 use PDL::Doc::Perldl; # Load all documentation functions
22
23=head1 BUGS
24
25The description contains the misleading word "simple".
26
27=head1 FUNCTIONS
28
29=cut
30
31package PDL::Doc::Perldl;
32
33use Exporter;
34use strict;
35use vars qw(@ISA @EXPORT);
36
37@ISA = qw(Exporter);
38
39@EXPORT = qw( apropos aproposover usage help sig badinfo whatis );
40
41use PDL::Doc;
42use Pod::Select;
43use IO::File;
44use Pod::PlainText;
45
46$PDL::onlinedoc = undef;
47$PDL::onlinedoc = PDL::Doc->new(FindStdFile());
48
49use PDL::Config;
50my $bvalflag = $PDL::Config{WITH_BADVAL} || 0;
51
52# Find std file
53
54sub FindStdFile {
55  my ($d,$f);
56  for $d (@INC) {
57      $f = $d."/PDL/pdldoc.db";
58      if (-f $f) {
59         print "Found docs database $f\n" if $PDL::verbose;
60	 print "Type 'help' for online help\n" if $PDL::verbose;
61         return $f;
62      }
63  }
64  warn "Unable to find PDL/pdldoc.db in ".join(":",@INC)."\n";
65}
66
67# used to find out how wide the screen should be
68# for printmatch() - really should check for a
69# sensible lower limit (for printmatch >~ 40
70# would be my guess)
71#
72# taken from Pod::Text (v1.0203), then hacked to get it
73# to work (at least on my solaris and linux
74# machines)
75#
76sub screen_width() {
77    return $ENV{COLUMNS}
78       || (($ENV{TERMCAP} =~ /co#(\d+)/) and $1)
79       || ($^O ne 'MSWin32' and $^O ne 'dos' and
80	   (`stty -a 2>/dev/null` =~ /columns\s*=?\s*(\d+)/) and $1)
81       || 72;
82}
83
84sub printmatch {
85    my @match = @_;
86    if (@match) {
87	foreach my $t ( format_ref( @_ ) ) { print $t; }
88    } else {
89	print "no match\n\n";
90    }
91} # sub: print_match()
92
93# return a string containing a formated version of the Ref string
94# for the given matches
95#
96sub format_ref {
97  my @match = @_;
98  my @text = ();
99
100  my $width = screen_width()-17;
101  my $parser = new Pod::PlainText( width => $width, indent => 0, sentence => 0 );
102
103  for my $m (@match) {
104    my $ref = $m->[1]{Ref} ||
105      ( (defined $m->[1]{CustomFile})
106        ? "[No ref avail. for `".$m->[1]{CustomFile}."']"
107        : "[No reference available]"
108     );
109
110    $ref = $parser->interpolate( $ref );
111    $ref = $parser->reformat( $ref );
112
113    # remove last new lines (so substitution doesn't append spaces at end of text)
114    $ref =~ s/\n*$//;
115    $ref =~ s/\n/\n                /g;
116
117    my $name = $m->[0];
118    if ( length($name) > 15 ) {
119      push @text, sprintf "%s ...\n                %s\n", $name, $ref;
120    } else {
121      push @text, sprintf "%-15s %s\n", $name, $ref;
122    }
123  }
124  return wantarray ? @text : $text[0];
125
126} # sub: format_ref()
127
128=head2 apropos
129
130=for ref
131
132Regex search PDL documentation database
133
134=for usage
135
136 apropos 'text'
137
138=for example
139
140 pdl> apropos 'pic'
141 rpic            Read images in many formats with automatic format detection.
142 rpiccan         Test which image formats can be read/written
143 wmpeg           Write an image sequence ((x,y,n) piddle) as an MPEG animation.
144 wpic            Write images in many formats with automatic format selection.
145 wpiccan         Test which image formats can be read/written
146
147To find all the manuals that come with PDL, try
148
149  apropos 'manual:'
150
151and to get quick info about PDL modules say
152
153  apropos 'module:'
154
155You get more detailed info about a PDL function/module/manual
156with the C<help> function
157
158=cut
159
160sub aproposover {
161    die "Usage: aproposover \$funcname\n" unless $#_>-1;
162    die "no online doc database" unless defined $PDL::onlinedoc;
163    my $func = shift;
164    $func =~ s:\/:\\\/:g;
165    search_docs("m/$func/",['Name','Ref','Module'],1);
166
167}
168
169sub apropos  {
170    die "Usage: apropos \$funcname\n" unless $#_>-1;
171    die "no online doc database" unless defined $PDL::onlinedoc;
172    my $func = shift;
173    printmatch aproposover $func;
174}
175
176=head2 PDL::Doc::Perldl::search_docs
177
178=for ref
179
180Internal routine to search docs database and autoload files
181
182=cut
183
184sub search_docs {
185    my ($func,$types,$sortflag,$exact) = @_;
186    my @match;
187
188    @match = $PDL::onlinedoc->search($func,$types,$sortflag);
189    push(@match,find_autodoc( $func, $exact ) );
190
191    @match;
192}
193
194
195
196=head2 PDL::Doc::Perldl::finddoc
197
198=for ref
199
200Internal interface to the PDL documentation searcher
201
202=cut
203
204sub finddoc  {
205    local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager
206
207    die 'Usage: doc $topic' unless $#_>-1;
208    die "no online doc database" unless defined $PDL::onlinedoc;
209    my $topic = shift;
210
211    # See if it matches a PDL function name
212
213    my $subfield = $1
214      if( $topic =~ s/\[(\d*)\]$// );
215
216    (my $t2 = $topic) =~ s/([^a-zA-Z0-9_])/\\$1/g;
217
218    my @match = search_docs("m/^(PDL::)?".$t2."\$/",['Name'],0);
219
220    unless(@match) {
221
222      print "No PDL docs for '$topic'. Using 'whatis'. (Try 'apropos $topic'?)\n\n";
223      whatis($topic);
224      return;
225
226    }
227
228    # print out the matches
229
230    my $out = IO::File->new( "| pod2text | $PDL::Doc::pager" );
231
232    if($subfield) {
233      if($subfield <= @match) {
234	@match = ($match[$subfield-1]);
235	$subfield = 0;
236      } else {
237	print $out "\n\n=head1 PDL HELP: Ignoring out-of-range selector $subfield\n\n=head1\n\n=head1 --------------------------------\n\n";
238	$subfield = undef;
239      }
240    }
241
242    my $num_pdl_pod_matches = scalar @match;
243    my $pdl_pod_matchnum = 0;
244
245    while (@match) {
246       $pdl_pod_matchnum++;
247
248       if (  @match > 1   and   !$subfield  ) {
249          print $out "\n\n=head1 MULTIPLE MATCHES FOR HELP TOPIC '$topic':\n\n=head1\n\n=over 3\n\n";
250          my $i=0;
251          for my $m ( @match ) {
252             printf $out "\n=item [%d]\t%-30s %s%s\n\n", ++$i, $m->[0], $m->[1]{Module} && "in ", $m->[1]{CustomFile} || $m->[1]{Module};
253          }
254          print $out "\n=back\n\n=head1\n\n To see item number \$n, use 'help ${topic}\[\$n\]'. \n\n=cut\n\n";
255       }
256
257       if (@match > 0 and $num_pdl_pod_matches > 1) {
258          print $out "\n=head1 Displaying item $pdl_pod_matchnum:\n\n=head1 --------------------------------------\n\n=cut\n\n";
259       }
260
261       my $m = shift @match;
262
263       my $Ref = $m->[1]{Ref};
264       if ( $Ref =~ /^(Module|Manual|Script): / ) {
265	   # We've got a file name and we have to open it.  With the relocatable db, we have to reconstitute the absolute pathname.
266	   my $relfile = $m->[1]{File};
267	   my $absfile = undef;
268	   my @scnd = @{$PDL::onlinedoc->{Scanned}};
269	   for my $dbf(@scnd){
270	       $dbf =~ s:\/[^\/]*$::; # Trim file name off the end of the database file to get just the directory
271	       $dbf .= "/$relfile";
272	       $absfile = $dbf if( -e $dbf );
273	   }
274	   unless ($absfile) {
275	       die "Documentation error: couldn't find absolute path to $relfile\n";
276	   }
277	   my $in = IO::File->new("<$absfile");
278	   print $out join("",<$in>);
279       } else {
280          if(defined $m->[1]{CustomFile}) {
281
282             my $parser= Pod::Select->new;
283             print $out "=head1 Autoload file \"".$m->[1]{CustomFile}."\"\n\n";
284             $parser->parse_from_file($m->[1]{CustomFile},$out);
285             print $out "\n\n=head2 Docs from\n\n".$m->[1]{CustomFile}."\n\n";
286
287          } else {
288
289             print $out "=head1 Module ",$m->[1]{Module}, "\n\n";
290             $PDL::onlinedoc->funcdocs($m->[0],$out);
291
292          }
293
294       }
295    }
296  }
297
298
299=head2 find_autodoc
300
301=for ref
302
303Internal helper routine that finds and returns documentation in the autoloader
304path, if it exists.  You feed in a topic and it searches for the file
305"${topic}.pdl".  If that exists, then the filename gets returned in a
306match structure appropriate for the rest of finddoc.
307
308=cut
309
310# Yuck.  Sorry.  At least it works.  -CED
311
312sub find_autodoc {
313    my $topic = shift;
314    my $exact = shift;
315    my $matcher;
316    # Fix up regexps and exact matches for the special case of
317    # searching the autoload dirs...
318    if($exact) {
319	$topic =~ s/\(\)$//;  # "func()" -> "func"
320	$topic .= ".pdl" unless $topic =~ m/\.pdl$/;
321    } else {
322
323	$topic =~ s:([^\$])(.)$:$1\.\*\$$2:; # Include explicit ".*$" at end of
324	                                   # vague matches -- so that we can
325	                                   # make it a ".*\.pdl$" below.
326
327	$topic =~ s:\$(.)$:\.pdl\$$1:; # Force ".pdl" at end of file match
328
329	$matcher = eval "sub { ${topic}i && \$\_ };";  # Avoid multiple compiles
330    }
331
332    my @out;
333
334    return unless(@main::PDLLIB);
335    @main::PDLLIB_EXPANDED = PDL::AutoLoader::expand_path(@main::PDLLIB)
336	unless(@main::PDLLIB_EXPANDED);
337
338    for my $dir(@main::PDLLIB_EXPANDED) {
339	if($exact) {
340	    my $file = $dir . "/" . "$topic";
341	    push(@out,
342	          [$file, {CustomFile => "$file", Module => "file '$file'"}]
343		 )
344		if(-e $file);
345	} else {
346	    opendir(FOO,$dir) || next;
347	    my @dir = readdir(FOO);
348	    closedir(FOO);
349	    for my $file( grep( &$matcher, @dir ) ) {
350		push(@out,
351		     [$file, {CustomFile => "$dir/$file", Module => "file '$dir/$file'"}]
352		     );
353	    }
354
355	}
356    }
357    @out;
358}
359
360
361=head2 usage
362
363=for ref
364
365Prints usage information for a PDL function
366
367=for usage
368
369 Usage: usage 'func'
370
371=for example
372
373   pdl> usage 'inner'
374
375   inner           inner prodcuct over one dimension
376                   (Module PDL::Primitive)
377
378   Signature: inner(a(n); b(n); [o]c(); )
379
380
381=cut
382
383sub usage {
384    die 'Usage: usage $funcname' unless $#_>-1;
385    die "no online doc database" unless defined $PDL::onlinedoc;
386    print usage_string(@_);
387}
388sub usage_string{
389    my $func = shift;
390    my $str = "";
391    my @match = search_docs("m/^(PDL::)?$func\$/",['Name']);
392
393    unless (@match) { $str = "\n  no match\n" }
394    else {
395	$str .= "\n" . format_ref( $match[0] );
396	my ($name,$hash) = @{$match[0]};
397	$str .= sprintf ( (' 'x16)."(Module %s)\n\n", $hash->{Module} );
398	die "No usage info found for $func\n"
399	    if !defined $hash->{Example} && !defined $hash->{Sig} &&
400		!defined $hash->{Usage};
401	$str .= "  Signature: $name($hash->{Sig})\n\n" if defined $hash->{Sig};
402	for (['Usage','Usage'],['Opt','Options'],['Example','Example']) {
403	    $str .= "  $_->[1]:\n\n".&allindent($hash->{$_->[0]},10)."\n\n"
404		if defined $hash->{$_->[0]};
405	}
406    }
407    return $str;
408}
409
410=head2 sig
411
412=for ref
413
414prints signature of PDL function
415
416=for usage
417
418 sig 'func'
419
420The signature is the normal dimensionality of the
421function's arguments.  Calling with different dimensions
422doesn't break -- it causes threading.  See L<PDL::PP|PDL::PP> for details.
423
424=for example
425
426  pdl> sig 'outer'
427    Signature: outer(a(n); b(m); [o]c(n,m); )
428
429
430=cut
431
432sub sig {
433	die "Usage: sig \$funcname\n" unless $#_>-1;
434	die "no online doc database" unless defined $PDL::onlinedoc;
435	my $func = shift;
436	my @match = search_docs("m/^(PDL::)?$func\$/",['Name']);
437	unless (@match) { print "\n  no match\n" } else {
438         my ($name,$hash) = @{$match[0]};
439	 die "No signature info found for $func\n"
440            if !defined $hash->{Sig};
441         print "  Signature: $name($hash->{Sig})\n" if defined $hash->{Sig};
442        }
443}
444
445sub allindent {
446	my ($txt,$n) = @_;
447	my ($ntxt,$tspc) = ($txt,' 'x8);
448	$ntxt =~ s/^\s*$//mg;
449	$ntxt =~ s/\t/$tspc/g;
450	my $minspc = length $txt;
451	for (split '\n', $txt) { if (/^(\s*)/)
452          { $minspc = length $1 if length $1 < $minspc } }
453	$n -= $minspc;
454	$tspc = ' 'x abs($n);
455	$ntxt =~ s/^/$tspc/mg if $n > 0;
456	return $ntxt;
457}
458
459
460=head2 whatis
461
462=for ref
463
464Describe a perl and/or PDL variable or expression.  Useful for
465determining the type of an expression, identifying the keys in a hash
466or a data structure, or examining WTF an unknown object is.
467
468=for usage
469
470 Usage: whatis $var
471        whatis <expression>
472
473=cut
474
475sub whatis {
476  my $topic;
477
478  if(@_ > 1) {
479    whatis_r('',0,[@_]);
480  } else {
481    whatis_r('',0,shift);
482  }
483}
484
485$PDL::Doc::Perldl::max_strlen = 55;
486$PDL::Doc::Perldl::max_arraylen = 1;
487$PDL::Doc::Perldl::max_keylen = 8;
488$PDL::Doc::Perldl::array_indent=5;
489$PDL::Doc::Perldl::hash_indent=3;
490
491sub whatis_r {
492  my $prefix = shift;
493  my $indent = shift;
494  my $a = shift;
495
496  unless(defined $a) {
497    print $prefix,"<undef>\n";
498    return;
499  }
500
501  unless(ref $a) {
502    print "${prefix}'".
503      substr($a,0,$PDL::Doc::Perldl::max_strlen).
504      "'".((length $a > $PDL::Doc::Perldl::max_strlen) && '...').
505      "\n";
506    return;
507  }
508
509  if(ref $a eq 'ARRAY') {
510    print "${prefix}Array (".scalar(@$a)." elements):\n";
511
512    my($el);
513    for $el(0..$#$a) {
514      my $pre = sprintf("%s  %2d: "," "x$indent,$el);
515      whatis_r($pre,$indent + $PDL::Doc::Perldl::array_indent, $a->[$el]);
516      last if($el == $PDL::Doc::Perldl::max_arraylen);
517    }
518    printf "%s   ... \n"," " x $indent
519      if($#$a > $PDL::Doc::Perldl::max_arraylen);
520
521    return;
522  }
523
524  if(ref $a eq 'HASH') {
525    print "${prefix}Hash (".scalar(keys %$a)." elements)\n";
526    my $key;
527    for $key(sort keys %$a) {
528      my $pre = " " x $indent .
529	        " $key: " .
530		(" "x($PDL::Doc::Perldl::max_keylen - length($key))) ;
531
532      whatis_r($pre,$indent + $PDL::Doc::Perldl::hash_indent, $a->{$key});
533    }
534    return;
535  }
536
537  if(ref $a eq 'CODE') {
538    print "${prefix}Perl CODE ref\n";
539    return;
540  }
541
542  if(ref $a eq 'SCALAR' | ref $a eq 'REF') {
543    whatis_r($prefix." Ref -> ",$indent+8,$$a);
544    return;
545  }
546
547  if(UNIVERSAL::can($a,'px')) {
548    my $b;
549    local $PDL::debug = 1;
550
551    $b = ( (UNIVERSAL::isa($a,'PDL') && $a->nelem < 5 && $a->ndims < 2)
552	   ?
553	   ": $a" :
554	   ": *****"
555	   );
556
557    $a->px($prefix.(ref $a)." %7T (%D) ".$b);
558
559  } else {
560
561    print "${prefix}Object: ".ref($a)."\n";
562
563  }
564}
565
566=head2 help
567
568=for ref
569
570print documentation about a PDL function or module or show a PDL manual
571
572In the case of multiple matches, the first command found is printed out,
573and the remaining commands listed, along with the names of their modules.
574
575
576=for usage
577
578 Usage: help 'func'
579
580=for example
581
582 pdl> help 'PDL::Tutorials' # show the guide to PDL tutorials
583 pdl> help 'PDL::Slices'    # show the docs in the PDL::Slices module
584 pdl> help 'slice'          # show docs on the 'slice' function
585
586=cut
587
588sub help_url {
589    local $_;
590    foreach(@INC) {
591	my $a = "$_/PDL/HtmlDocs/PDL/Index.html";
592	if(-e $a) {
593	    return "file://$a";
594	}
595    }
596}
597
598sub help {
599  if ($#_>-1) {
600      require PDL::Dbg;
601      my $topic = shift;
602      if (PDL::Core::blessed($topic) && $topic->can('px')) {
603	  local $PDL::debug = 1;
604	  $topic->px('This variable is');
605      } else {
606	  $topic = 'PDL::Doc::Perldl' if $topic =~ /^\s*help\s*$/i;
607	  if ($topic =~ /^\s*vars\s*$/i) {
608	      PDL->px((caller)[0]);
609	  } elsif($topic =~ /^\s*url\s*/i) {
610	      my $a = help_url();
611	      if($a) {
612		  print $a;
613	      } else {
614		  print "Hmmm. Curious: I couldn't find the HTML docs anywhere in \@INC...\n";
615	      }
616	  } elsif($topic =~ /^\s*www(:([^\s]+))?\s*/i) {
617	      my $browser;
618	      my $url = help_url();
619	      if($2) {
620		  $browser = $2;
621	      } elsif($ENV{PERLDL_WWW}) {
622		  $browser = $ENV{PERLDL_WWW};
623	      } else {
624		  $browser = 'mozilla';
625	      }
626	      chomp($browser = `which $browser`);
627	      if(-e $browser && -x $browser) {
628		  print "Spawning \"$browser $url\"...\n";
629		  `$browser $url`;
630	      }
631	  } else {
632	      finddoc($topic);
633	  }
634      }
635  } else {
636	print <<'EOH';
637
638The following commands support online help in the perldl shell:
639
640 help 'thing'   -- print docs on 'thing' (func, module, manual, autoload-file)
641 help vars      -- print information about all current piddles
642 help url       -- locate the HTML version of the documentation
643 help www       -- View docs with default web browser (set by env: PERLDL_WWW)
644
645 whatis <expr>  -- Describe the type and structure of an expression or piddle.
646 apropos 'word' -- search for keywords/function names
647 usage          -- print usage information for a given PDL function
648 sig            -- print signature of PDL function
649
650 ('?' is an alias for 'help';  '??' is an alias for 'apropos'.)
651EOH
652
653print "  badinfo         -- information on the support for bad values\n"
654   if $bvalflag;
655
656print <<'EOH';
657
658Quick start:
659  apropos 'manual:' -- Find all the manual documents
660  apropos 'module:' -- Quick summary of all PDL modules
661  help 'help'       -- details about PDL help system
662  help 'perldl'     -- help about this shell
663
664EOH
665  }
666}
667
668=head2 badinfo
669
670=for ref
671
672provides information on the bad-value support of a function
673
674And has a horrible name.
675
676=for usage
677
678 badinfo 'func'
679
680=cut
681
682# need to get this to format the output - want a format_bad()
683# subroutine that's like - but much simpler - than format_ref()
684#
685sub badinfo {
686    my $func = shift;
687    die "Usage: badinfo \$funcname\n" unless defined $func;
688
689    die "PDL has not been compiled with support for bad values.\n" .
690	"Recompile with WITH_BADVAL set to 1 in config file!.\n"
691	    unless $bvalflag;
692
693    die "no online doc database" unless defined $PDL::onlinedoc;
694
695    local $SIG{PIPE}= sub {}; # Prevent crashing if user exits the pager
696
697    my @match = search_docs("m/^(PDL::)?$func\$/",['Name']);
698    if ( @match ) {
699	my ($name,$hash) = @{$match[0]};
700	my $info = $hash->{Bad};
701
702	if ( defined $info ) {
703	    my $out = new IO::File "| pod2text | $PDL::Doc::pager";
704	    print $out "=head1 Bad value support for $name\n\n$info\n";
705	} else {
706	    print "\n  No information on bad-value support found for $func\n";
707	}
708    } else {
709	print "\n  no match\n";
710    }
711} # sub: badinfo()
712
7131; # OK
714