<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#-*- perl -*-

## Copyright (C) 2000-2003 R Development Core Team
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2, or (at your option)
## any later version.
##
## This program is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
## General Public License for more details.
##
## A copy of the GNU General Public License is available via WWW at
## http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by
## writing to the Free Software Foundation, Inc., 59 Temple Place,
## Suite 330, Boston, MA  02111-1307  USA.
##
## Send any bug reports to r-bugs@r-project.org

use Getopt::Long;
use FileHandle;
use R::Rdtools;
use R::Utils;
use R::Vars;

my $revision = ' $Revision: 1.17 $ ';
my $version;
my $name;

$revision =~ / ([\d\.]*) /;
$version = $1;
($name = $0) =~ s|.*/||;

sub usage {
    print STDERR &lt;&lt;END;
Usage: [R CMD] perl /path/to/extract-usage.pl [options] FILE OUT

Extract usage information for use by codoc from the Rd source files
listed in FILE, writing results to OUT.

Options:
  -h, --help            print short help message and exit
  -v, --version         print version info and exit
      --mode=MODE       use operation mode MODE (codoc, args or style)
      --os=NAME         use OS type NAME (unix, mac or windows)
      --OS=NAME         the same as '--os'
  -V, --verbose         print more information about progress

Email bug reports to &lt;r-bugs\@r-project.org&gt;.
END
  exit 0;
}

my $opt_OS = $R::Vars::OSTYPE;
my $opt_mode = "codoc";
my $opt_version;
my $opt_verbose;

GetOptions("h|help"    =&gt; \&amp;usage,
	   "v|version" =&gt; \$opt_version,
	   "os|OS:s"   =&gt; \$opt_OS,
	   "mode=s"    =&gt; \$opt_mode,
	   "V|verbose" =&gt; \$opt_verbose
	  ) or &amp;usage();

&amp;R_version($name, $version) if $opt_version;

open(INFILE, "&lt; $ARGV[0]")
  or die "Error: cannot open '$ARGV[0]' for reading\n";
my $out = new FileHandle("&gt; $ARGV[1]")
  or die "Error: cannot open '$ARGV[1]' for writing\n";

while (&lt;INFILE&gt;) {
    chomp;
    open(RDFILE, "&lt; $_")
	or die "Error: cannot open '$_' for reading\n";
    my @chunks = split(/\\eof/, &amp;Rdpp($_, $opt_OS));
    ## &lt;FIXME&gt;
    my $is_new_style_Rd_list = (scalar(@chunks) &gt; 1);
    ## &lt;NOTE&gt;
    ## If we found '\eof', we have a new-style list of Rd files.
    ## If not, we could still have an old-style one obtained by simply
    ## concatenating all Rd files.  In this case, we split on \name, and
    ## keep our fingers crossed ...
    ## Note that this is really dangerous, and defensive programming
    ## would (at least) put things back into one text chunk if \name was
    ## found only once ...
    if($is_new_style_Rd_list) {
	pop(@chunks);		# last element must be 'empty' ...
    }
    else {
	@chunks = split(/\\name/, $chunks[0]);
    }
    ## &lt;/NOTE&gt;
    foreach my $text (@chunks) {
	## If not a new-style Rd list, we split on \name (see above),
	## and hence put this back in front as get_usages() needs it.
	$text = "\\name" . $text unless($is_new_style_Rd_list);

	## Determine the \name of the documentation object.  Note:
	## contrary to Rd::info() or Rdtools::get_section(), this goes
	## for non-empty matches right away.
	next if($text !~ /\\name\s*{\s*([^}]*[^}\s])\s*}.*/);

	$out-&gt;print("# usages in documentation object $1\n");
	$out-&gt;print("# arglist: ", join(" ", get_arglist($text)), "\n")
	  unless($opt_mode eq "codoc");

	my %usages = get_usages($text, $opt_mode, $opt_verbose);

	if($opt_mode eq "codoc") {
	    $out-&gt;print("# variables: ",
			join(" ", @{$usages{"variables"}}),
			"\n");
	    $out-&gt;print("# data sets: ",
			join(" ", @{$usages{"data_sets"}}),
			"\n");
	}

	if($opt_mode eq "args") {
	    $out-&gt;print("# aliases: ",
			join(" ",
			     map(substr($_, 1, -1),
				 get_section($text, "alias"))),
			"\n");
	}

	my %functions = @{$usages{"functions"}};
	foreach my $key (keys(%functions)) {
	    $functions{$key} =~ s/ *\\.?dots/ .../g;
	    if ($key !~ /^&lt;/) {
		$out-&gt;print("\"${key}\" &lt;- ",
			    "function$functions{$key} NULL\n");
	    }
	}

	if($opt_mode ne "style") {
	    my %S4methods = @{$usages{"S4methods"}};
	    foreach my $key (keys(%S4methods)) {
		$S4methods{$key} =~ s/ *\\.?dots/ .../g;
		$out-&gt;print("\"\\${key}\" &lt;- ",
			    "function$S4methods{$key} NULL\n");
	    }
	}

	## Add the \usage text, currently only for mode 'args'.
	if($opt_mode eq "args") {
	    $out-&gt;print("\".__Usage__.\" &lt;- ");
	    my @usages = get_section($text, "usage");
	    $text = substr(shift(@usages), 1, -1);
	    $text =~ s/\\/\\\\/g;
	    $text =~ s/\"/\\\"/g;
	    $text =~ s/\n/\\\n/g;
	    $text =~ s/\r//g;
	    $out-&gt;print("\"${text}\"\n");
	}

	$out-&gt;print("\n");
    }
}
</pre></body></html>