<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># Subroutines for building R documentation

# Copyright (C) 1997-2000 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@lists.r-project.org


use Cwd;
use File::Basename;

require "$R_HOME/etc/html-layout.pl";


if($opt_dosnames){
    $HTML="htm";
}
else{
    $HTML="html";
}

$dir_mod = 0755;#- Permission ('mode') of newly created directories.

# determine of pkg and lib directory are accessible; chdir to pkg man dir
# and return pkg name, full path to lib dir and contents of mandir

sub buildinit {

    my $pkg = $ARGV[0];
    my $lib = $ARGV[1];

    my $currentdir = getcwd();

    if($pkg){
	die("Package $pkg does not exist\n") unless (-d $pkg);
    }
    else{
	$pkg="$R_HOME/src/library/base";
    }

    chdir $currentdir;

    if($lib){
        mkdir "$lib", $dir_mod || die "Could not create $lib: $!\n";
	chdir $lib;
	$lib=getcwd();
	chdir $currentdir;
    }
    else{
	$lib="$R_HOME/library";
    }

    chdir $currentdir;

    chdir($pkg) or die("Cannot change to $pkg\n");
    $tmp = getcwd();
    if($OSdir eq "windows") {
	$tmp =~ s+\\+/+g; # need Unix-style path here
    }
    $pkg = basename($tmp);
#    $pkg = basename(getcwd());

    chdir "man" or die("There are no man pages in $pkg\n");
    opendir man, '.';
    @mandir = sort(readdir(man));
    closedir man;

    if(-d $OSdir) {
	foreach $file (@mandir) { $Rds{$file} = $file; }
	opendir man, $OSdir;
	foreach $file (readdir(man)) {
	    delete $Rds{$file};
	    $RdsOS{$file} = $OSdir."/".$file;
	}
	@mandir = sort(values %Rds);
	push @mandir, sort(values %RdsOS);
    }

    ($pkg, $lib, @mandir);
}


### Read the titles of all installed packages into an hash array

sub read_titles {

    my $lib = $_[0];

    my %tit;
    my $pkg;

    opendir lib, $lib;
    my @libs = readdir(lib);
    closedir lib;

    foreach $pkg (@libs) {
	if(-d "$lib/$pkg"){
	    if(! ( ($pkg =~ /^CVS$/) || ($pkg =~ /^\.+$/))){
		if(-r "$lib/$pkg/TITLE"){
		    open rtitle, "&lt; $lib/$pkg/TITLE";
		    $_ = &lt;rtitle&gt;;
		    /^(\S*)\s*(.*)/;
		    my $pkgname = $1;
		    $tit{$pkgname} = $2;
		    while(&lt;rtitle&gt;){
			/\s*(.*)/;
			$tit{$pkgname} = $tit{$pkgname} . "\n" .$1;
		    }
		    close rtitle;
		}
	    }
	}
    }

    close titles;
    %tit;
}

### Read the titles of all installed functions into an hash array

sub read_functiontitles {

    my $lib = $_[0];

    my %tit;
    my $pkg;

    opendir lib, $lib;
    my @libs = readdir(lib);
    closedir lib;

    foreach $pkg (@libs) {
	if(-d "$lib/$pkg"){
	    if(! ( ($pkg =~ /^CVS$/) || ($pkg =~ /^\.+$/))){
		if(-r "$lib/$pkg/TITLE"){
		    open rtitle, "&lt; $lib/$pkg/help/00Titles";
		    while(&lt;rtitle&gt;){
			/^([^\t]*)\s*(.*)/;
			my $alias = $1;
			$tit{$alias} = $2 . " ($pkg)";
		    }
		    close rtitle;
		}
	    }
	}
    }

    close titles;
    %tit;
}


### Read all aliases into two hash arrays with basenames and
### (relative) html-paths.


sub read_htmlindex {

    my $lib = $_[0];

    my $pkg, %htmlindex;

    opendir lib, $lib;
    my @libs = readdir(lib);
    closedir lib;

    foreach $pkg (@libs) {
	if(-d "$lib/$pkg"){
	    if(! ( ($pkg =~ /^CVS$/) || ($pkg =~ /^\.+$/))){
		if(-r "$lib/$pkg/help/AnIndex"){
		    open ranindex, "&lt; $lib/$pkg/help/AnIndex";
		    while(&lt;ranindex&gt;){
			/^([^\t]*)\s*\t(.*)/;
			$htmlindex{$1} = "$pkg/html/$2.$HTML";
		    }
		    close ranindex;
		}
	    }
	}
    }
    %htmlindex;
}

sub read_anindex {

    my $lib = $_[0];

    my $pkg, %anindex;

    opendir lib, $lib;
    my @libs = readdir(lib);
    closedir lib;

    foreach $pkg (@libs) {
	if(-d "$lib/$pkg"){
	    if(! ( ($pkg =~ /^CVS$/) || ($pkg =~ /^\.+$/))){
		if(-r "$lib/$pkg/help/AnIndex"){
		    open ranindex, "&lt; $lib/$pkg/help/AnIndex";
		    while(&lt;ranindex&gt;){
			/^([^\t]*)\s*\t(.*)/;
			$anindex{$1} = $2;
		    }
		    close ranindex;
		}
	    }
	}
    }
    %anindex;
}



### Build $R_HOME/doc/html/packages.html from the $pkg/TITLE files

sub build_htmlpkglist {

    my $lib = $_[0];

    my %htmltitles = read_titles($lib);
    my $key;

    open(htmlfile, "&gt;$R_HOME/doc/html/packages.$HTML");

    print htmlfile html_pagehead("Package Index", ".",
				 "index.$HTML", "Top",
				 "", "",
				 "function.$HTML", "Functions");

    print htmlfile "&lt;P&gt;&lt;TABLE align=center&gt;\n";

    foreach $key (sort(keys %htmltitles)) {
	print htmlfile "&lt;TR ALIGN=LEFT VALIGN=TOP&gt;\n";
	print htmlfile "&lt;TD&gt;&lt;A HREF=\"../../library/$key/html/00Index.$HTML\"&gt;";
	print htmlfile "$key&lt;/A&gt;&lt;TD&gt;";
	print htmlfile $htmltitles{$key};
    }

    print htmlfile "&lt;/TABLE&gt;\n";
    print htmlfile "&lt;/BODY&gt;&lt;/HTML&gt;\n";

    close htmlfile;
}

sub striptitle { # text
    my $text = $_[0];
    $text =~ s/\\//go;
    $text =~ s/---/-/go;
    $text =~ s/--/-/go;
    return $text;
}

sub build_index {

    if(! -d $lib){
        mkdir "$lib", $dir_mod || die "Could not create directory $lib: $!\n";
    }

    if(! -d "$dest"){
        mkdir "$dest", $dir_mod || die "Could not create directory $dest: $!\n";
    }

    open title, "&lt;../TITLE";
#    open out, "&gt;$dest/TITLE";
    $title = &lt;title&gt;;
#    print out "$title";
    close title;
#    close out;
    $title =~ s/^\S*\s*(.*)/$1/;

    mkdir "$dest/help", $dir_mod || die "Could not create $dest/help: $!\n";
    mkdir "$dest/html", $dir_mod || die "Could not create $dest/html: $!\n";

    $anindex = "$lib/$pkg/help/AnIndex";

    my %alltitles;
    my $naliases;
    my $nmanfiles;

    foreach $manfile (@mandir) {
	if($manfile =~ /\.Rd$/i){

	    my $rdname = basename($manfile, (".Rd", ".rd"));

	    if($opt_dosnames){
		$manfilebase = "x" . $nmanfiles++;
	    }
	    else{
		$manfilebase = $rdname;
	    }

	    open(rdfile, "&lt;$manfile");
	    undef $text;
	    while(&lt;rdfile&gt;){  # skip comment lines
		if(!/^%/) { $text .= $_; }
	    }
	    close rdfile;
	    $text =~ /\\title\{\s*([^\}]+)\s*\}/s;
	    my $rdtitle = $1;
	    $rdtitle =~ s/\n/ /sg;
	    $rdtitle =~ s/\\R/R/g; # don't use \R in titles

	    $filenm{$rdname} = $manfilebase;
	    if($opt_chm) {$title2file{$rdtitle} = $manfilebase;}

	    while($text =~ s/\\(alias|name)\{\s*(.*)\s*\}//){
		$alias = $2;
		$alias =~ s/\\%/%/g;
		my $an = $aliasnm{$alias};
		if ($an) {
		    if($an ne $manfilebase) {
			warn "\\$1\{$alias\} already in $an.Rd -- " .
			  "skipping the one in $manfilebase.Rd\n";
		    }
		} else {
		    $alltitles{$alias} = $rdtitle;
		    $aliasnm{$alias} = $manfilebase;
		    $naliases++;
		}
	    }
	}
    }

    sub foldorder {uc($a) cmp uc($b) or $a cmp $b;}

    open(anindex, "&gt;${anindex}");
    foreach $alias (sort foldorder keys %aliasnm) {
	print anindex "$alias\t$aliasnm{$alias}\n";
    }
    close anindex;


    open(anindex, "&lt;$anindex");
    open(titleindex, "&gt;$lib/$pkg/help/00Titles");
    open(htmlfile, "&gt;$lib/$pkg/html/00Index.$HTML");
    if($opt_chm) {open(chmfile, "&gt;$chmdir/00Index.$HTML");}

    print htmlfile html_pagehead("$title", "../../../doc/html",
				 "../../../doc/html/index.$HTML", "Top",
				 "../../../doc/html/packages.$HTML",
				 "Package List");

    if($opt_chm) {print chmfile chm_pagehead("$title");}


    if($naliases&gt;100){
	print htmlfile html_alphabet();
	if($opt_chm) {print chmfile html_alphabet();}
   }

    print htmlfile "\n&lt;p&gt;\n&lt;table width=\"100%\"&gt;\n";
    if($opt_chm) {print chmfile "\n&lt;p&gt;\n&lt;table width=\"100%\"&gt;\n";}

    my $firstletter = "";
    my $current = "", $currentfile = "", $file, $generic;
    while(&lt;anindex&gt;){
        chomp;  ($alias, $file) = split /\t/;
        $aliasfirst = uc substr($alias, 0, 1);
	if($aliasfirst lt "A") { $aliasfirst = ""; }
	if($aliasfirst gt "Z") { $aliasfirst = "misc"; }
	if( ($naliases &gt; 100) &amp;&amp; ($aliasfirst ne $firstletter) ) {
	    print htmlfile "&lt;/table&gt;\n";
	    print htmlfile html_title2("&lt;a name=\"$aliasfirst\"&gt;-- $aliasfirst --&lt;/a&gt;");
	    print htmlfile "&lt;table width=\"100%\"&gt;\n";
	    if($opt_chm) {
		print chmfile "&lt;/table&gt;\n";
		print chmfile html_title2("&lt;a name=\"$aliasfirst\"&gt;-- $aliasfirst --&lt;/a&gt;");
		print chmfile "&lt;table width=\"100%\"&gt;\n";
	    }
	    $firstletter = $aliasfirst;
	}
# skip method aliases.
	$generic = $alias;  
	$generic =~ s/\.data\.frame$/.dataframe/o;
	$generic =~ s/\.model\.matrix$/.modelmatrix/o;
	$generic =~ s/\.[^.]+$//o;
#	print "   $alias, $generic, $file, $currentfile\n";
	next if $alias =~ /&lt;-$/o || $generic =~ /&lt;-$/o;
	if ($generic ne "" &amp;&amp; $generic eq $current &amp;&amp; 
	    $file eq $currentfile &amp;&amp; $generic ne "ar") { 
#	    print "skipping $alias\n";
	    next; 
	} else { $current = $alias; $currentfile = $file;}

	print titleindex "$alias\t$alltitles{$alias}\n";
	$htmlalias = $alias;
	$htmlalias =~ s/&lt;/&amp;lt;/go;
	$htmlalias =~ s/&gt;/&amp;gt;/go;
	my $title = striptitle($alltitles{$alias});
	print htmlfile "&lt;TR&gt;&lt;TD width=\"25%\"&gt;&lt;A HREF=\"$file.$HTML\"&gt;" .
	    "$htmlalias&lt;/A&gt;&lt;/TD&gt;\n&lt;TD&gt;$title&lt;/TD&gt;&lt;/TR&gt;\n";
	if($opt_chm) {
	    print chmfile "&lt;TR&gt;&lt;TD width=\"25%\"&gt;&lt;A HREF=\"$file.$HTML\"&gt;" .
		"$htmlalias&lt;/A&gt;&lt;/TD&gt;\n&lt;TD&gt;$title&lt;/TD&gt;&lt;/TR&gt;\n";}
    }

    print htmlfile "&lt;/TABLE&gt;\n";
    print htmlfile "&lt;/BODY&gt;&lt;/HTML&gt;\n";
    if($opt_chm) {print chmfile "&lt;/table&gt;\n&lt;/body&gt;&lt;/HTML&gt;\n";}

    close titleindex;
    close htmlfile;
    if($opt_chm) {close chmfile;}
    close anindex;

#    build_htmlpkglist($lib);
}


sub build_htmlfctlist {

    my $lib = $_[0];

    my %htmltitles = read_functiontitles($lib);
    my $key;

    open(htmlfile, "&gt;$R_HOME/doc/html/function.$HTML");

    print htmlfile html_pagehead("Functions installed in R_HOME", ".",
				 "index.$HTML", "Top",
				 "packages.$HTML", "Packages");

    print htmlfile html_alphabet();

    print htmlfile html_title2("-- Operators, Global Variables, ... --");
    print htmlfile "\n&lt;p&gt;\n&lt;table width=\"100%\"&gt;\n";
    foreach $alias (sort foldorder keys %htmltitles) {
	print htmlfile "&lt;TR&gt;&lt;TD width=\"25%\"&gt;" .
	    "&lt;A HREF=\"../../library/$htmlindex{$alias}\"&gt;" .
	    "$alias&lt;/A&gt;&lt;/TD&gt;\n&lt;TD&gt;$htmltitles{$alias}&lt;/TD&gt;&lt;/TR&gt;\n"
		unless $alias =~ /^[a-zA-Z]/;
    }
    print htmlfile "\n&lt;/table&gt;\n&lt;p&gt;\n&lt;table width=\"100%\"&gt;\n";

    my $firstletter = "";
    my $current = "", $currentfile = "", $file, $generic;
    foreach $alias (sort foldorder keys %htmltitles) {
	$aliasfirst = uc substr($alias, 0, 1);
	if($aliasfirst =~ /[A-Z]/){
	    if($aliasfirst ne $firstletter){
		print htmlfile "&lt;/table&gt;\n";
		print htmlfile "&lt;a name=\"" . uc $aliasfirst . "\"&gt;\n";
		print htmlfile html_title2("-- " . uc $aliasfirst . " --");
		print htmlfile "&lt;table width=\"100%\"&gt;\n";
		$firstletter = $aliasfirst;
	    }
# skip method aliases.
	    $file = $htmlindex{$alias};
	    $generic = $alias;  
	    $generic =~ s/\.data\.frame$/.dataframe/o;
	    $generic =~ s/\.model\.matrix$/.modelmatrix/o;
	    $generic =~ s/\.[^.]+$//o;
# omit all replacement functions and all plot and print methods
	    next if $alias =~ /&lt;-$/o || $generic =~ /&lt;-$/o;
	    next if $alias =~ /plot\./o;
	    next if $alias =~ /print\./o;
	    if ($generic ne "" &amp;&amp; $generic eq $current &amp;&amp; 
		$file eq $currentfile &amp;&amp; $generic ne "ar") { 
		next;
	    } else { $current  = $alias; $currentfile = $file;}
	    my $title = striptitle($htmltitles{$alias});
	    print htmlfile "&lt;TR&gt;&lt;TD width=\"25%\"&gt;" .
		"&lt;A HREF=\"../../library/$file\"&gt;" .
		    "$alias&lt;/A&gt;&lt;/TD&gt;\n&lt;TD&gt;$title&lt;/TD&gt;&lt;/TR&gt;\n";
	}
    }

    print htmlfile "&lt;/TABLE&gt;\n";
    print htmlfile "&lt;/BODY&gt;\n";

    close htmlfile;
}

sub fileolder { #(filename, age)
    my($file, $age) = @_;
    #- return ``true'' if file exists and is older than $age
    (! ((-f $file) &amp;&amp; ((-M $file) &lt; $age)))
}

1;
# Local variables: **
# perl-indent-level: 4 **
# cperl-indent-level: 4 **
# End: **
</pre></body></html>