move tlperl to tlperl.old

git-svn-id: svn://tug.org/texlive/trunk@18209 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 0 insertions, 430 deletions

diff --git a/Master/tlpkg/tlperl/lib/B/Xref.pm b/Master/tlpkg/tlperl/lib/B/Xref.pm
deleted file mode 100644
index f727dc766b5..00000000000
--- a/Master/tlpkg/tlperl/lib/B/Xref.pm
+++ /dev/null
@@ -1,430 +0,0 @@
-package B::Xref;
-
-our $VERSION = '1.01';
-
-=head1 NAME
-
-B::Xref - Generates cross reference reports for Perl programs
-
-=head1 SYNOPSIS
-
-perl -MO=Xref[,OPTIONS] foo.pl
-
-=head1 DESCRIPTION
-
-The B::Xref module is used to generate a cross reference listing of all
-definitions and uses of variables, subroutines and formats in a Perl program.
-It is implemented as a backend for the Perl compiler.
-
-The report generated is in the following format:
-
-    File filename1
-      Subroutine subname1
-	Package package1
-	  object1        line numbers
-	  object2        line numbers
-	  ...
-	Package package2
-	...
-
-Each B<File> section reports on a single file. Each B<Subroutine> section
-reports on a single subroutine apart from the special cases
-"(definitions)" and "(main)". These report, respectively, on subroutine
-definitions found by the initial symbol table walk and on the main part of
-the program or module external to all subroutines.
-
-The report is then grouped by the B<Package> of each variable,
-subroutine or format with the special case "(lexicals)" meaning
-lexical variables. Each B<object> name (implicitly qualified by its
-containing B<Package>) includes its type character(s) at the beginning
-where possible. Lexical variables are easier to track and even
-included dereferencing information where possible.
-
-The C<line numbers> are a comma separated list of line numbers (some
-preceded by code letters) where that object is used in some way.
-Simple uses aren't preceded by a code letter. Introductions (such as
-where a lexical is first defined with C<my>) are indicated with the
-letter "i". Subroutine and method calls are indicated by the character
-"&".  Subroutine definitions are indicated by "s" and format
-definitions by "f".
-
-=head1 OPTIONS
-
-Option words are separated by commas (not whitespace) and follow the
-usual conventions of compiler backend options.
-
-=over 8
-
-=item C<-oFILENAME>
-
-Directs output to C<FILENAME> instead of standard output.
-
-=item C<-r>
-
-Raw output. Instead of producing a human-readable report, outputs a line
-in machine-readable form for each definition/use of a variable/sub/format.
-
-=item C<-d>
-
-Don't output the "(definitions)" sections.
-
-=item C<-D[tO]>
-
-(Internal) debug options, probably only useful if C<-r> included.
-The C<t> option prints the object on the top of the stack as it's
-being tracked. The C<O> option prints each operator as it's being
-processed in the execution order of the program.
-
-=back
-
-=head1 BUGS
-
-Non-lexical variables are quite difficult to track through a program.
-Sometimes the type of a non-lexical variable's use is impossible to
-determine. Introductions of non-lexical non-scalars don't seem to be
-reported properly.
-
-=head1 AUTHOR
-
-Malcolm Beattie, mbeattie@sable.ox.ac.uk.
-
-=cut
-
-use strict;
-use Config;
-use B qw(peekop class comppadlist main_start svref_2object walksymtable
-         OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
-        );
-
-sub UNKNOWN { ["?", "?", "?"] }
-
-my @pad;			# lexicals in current pad
-				# as ["(lexical)", type, name]
-my %done;			# keyed by $$op: set when each $op is done
-my $top = UNKNOWN;		# shadows top element of stack as
-				# [pack, type, name] (pack can be "(lexical)")
-my $file;			# shadows current filename
-my $line;			# shadows current line number
-my $subname;			# shadows current sub name
-my %table;			# Multi-level hash to record all uses etc.
-my @todo = ();			# List of CVs that need processing
-
-my %code = (intro => "i", used => "",
-	    subdef => "s", subused => "&",
-	    formdef => "f", meth => "->");
-
-
-# Options
-my ($debug_op, $debug_top, $nodefs, $raw);
-
-sub process {
-    my ($var, $event) = @_;
-    my ($pack, $type, $name) = @$var;
-    if ($type eq "*") {
-	if ($event eq "used") {
-	    return;
-	} elsif ($event eq "subused") {
-	    $type = "&";
-	}
-    }
-    $type =~ s/(.)\*$/$1/g;
-    if ($raw) {
-	printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
-	    $file, $subname, $line, $pack, $type, $name, $event;
-    } else {
-	# Wheee
-	push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
-	    $line);
-    }
-}
-
-sub load_pad {
-    my $padlist = shift;
-    my ($namelistav, $vallistav, @namelist, $ix);
-    @pad = ();
-    return if class($padlist) eq "SPECIAL";
-    ($namelistav,$vallistav) = $padlist->ARRAY;
-    @namelist = $namelistav->ARRAY;
-    for ($ix = 1; $ix < @namelist; $ix++) {
-	my $namesv = $namelist[$ix];
-	next if class($namesv) eq "SPECIAL";
-	my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
-	$pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
-    }
-    if ($Config{useithreads}) {
-	my (@vallist);
-	@vallist = $vallistav->ARRAY;
-	for ($ix = 1; $ix < @vallist; $ix++) {
-	    my $valsv = $vallist[$ix];
-	    next unless class($valsv) eq "GV";
-	    # these pad GVs don't have corresponding names, so same @pad
-	    # array can be used without collisions
-	    $pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
-	}
-    }
-}
-
-sub xref {
-    my $start = shift;
-    my $op;
-    for ($op = $start; $$op; $op = $op->next) {
-	last if $done{$$op}++;
-	warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
-	warn peekop($op), "\n" if $debug_op;
-	my $opname = $op->name;
-	if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
-	    xref($op->other);
-	} elsif ($opname eq "match" || $opname eq "subst") {
-	    xref($op->pmreplstart);
-	} elsif ($opname eq "substcont") {
-	    xref($op->other->pmreplstart);
-	    $op = $op->other;
-	    redo;
-	} elsif ($opname eq "enterloop") {
-	    xref($op->redoop);
-	    xref($op->nextop);
-	    xref($op->lastop);
-	} elsif ($opname eq "subst") {
-	    xref($op->pmreplstart);
-	} else {
-	    no strict 'refs';
-	    my $ppname = "pp_$opname";
-	    &$ppname($op) if defined(&$ppname);
-	}
-    }
-}
-
-sub xref_cv {
-    my $cv = shift;
-    my $pack = $cv->GV->STASH->NAME;
-    $subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
-    load_pad($cv->PADLIST);
-    xref($cv->START);
-    $subname = "(main)";
-}
-
-sub xref_object {
-    my $cvref = shift;
-    xref_cv(svref_2object($cvref));
-}
-
-sub xref_main {
-    $subname = "(main)";
-    load_pad(comppadlist);
-    xref(main_start);
-    while (@todo) {
-	xref_cv(shift @todo);
-    }
-}
-
-sub pp_nextstate {
-    my $op = shift;
-    $file = $op->file;
-    $line = $op->line;
-    $top = UNKNOWN;
-}
-
-sub pp_padsv {
-    my $op = shift;
-    $top = $pad[$op->targ];
-    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
-}
-
-sub pp_padav { pp_padsv(@_) }
-sub pp_padhv { pp_padsv(@_) }
-
-sub deref {
-    my ($op, $var, $as) = @_;
-    $var->[1] = $as . $var->[1];
-    process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
-}
-
-sub pp_rv2cv { deref(shift, $top, "&"); }
-sub pp_rv2hv { deref(shift, $top, "%"); }
-sub pp_rv2sv { deref(shift, $top, "\$"); }
-sub pp_rv2av { deref(shift, $top, "\@"); }
-sub pp_rv2gv { deref(shift, $top, "*"); }
-
-sub pp_gvsv {
-    my $op = shift;
-    my $gv;
-    if ($Config{useithreads}) {
-	$top = $pad[$op->padix];
-	$top = UNKNOWN unless $top;
-	$top->[1] = '$';
-    }
-    else {
-	$gv = $op->gv;
-	$top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
-    }
-    process($top, $op->private & OPpLVAL_INTRO ||
-                  $op->private & OPpOUR_INTRO   ? "intro" : "used");
-}
-
-sub pp_gv {
-    my $op = shift;
-    my $gv;
-    if ($Config{useithreads}) {
-	$top = $pad[$op->padix];
-	$top = UNKNOWN unless $top;
-	$top->[1] = '*';
-    }
-    else {
-	$gv = $op->gv;
-	$top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
-    }
-    process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
-}
-
-sub pp_const {
-    my $op = shift;
-    my $sv = $op->sv;
-    # constant could be in the pad (under useithreads)
-    if ($$sv) {
-	$top = ["?", "",
-		(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
-		? cstring($sv->PV) : "?"];
-    }
-    else {
-	$top = $pad[$op->targ];
-	$top = UNKNOWN unless $top;
-    }
-}
-
-sub pp_method {
-    my $op = shift;
-    $top = ["(method)", "->".$top->[1], $top->[2]];
-}
-
-sub pp_entersub {
-    my $op = shift;
-    if ($top->[1] eq "m") {
-	process($top, "meth");
-    } else {
-	process($top, "subused");
-    }
-    $top = UNKNOWN;
-}
-
-#
-# Stuff for cross referencing definitions of variables and subs
-#
-
-sub B::GV::xref {
-    my $gv = shift;
-    my $cv = $gv->CV;
-    if ($$cv) {
-	#return if $done{$$cv}++;
-	$file = $gv->FILE;
-	$line = $gv->LINE;
-	process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
-	push(@todo, $cv);
-    }
-    my $form = $gv->FORM;
-    if ($$form) {
-	return if $done{$$form}++;
-	$file = $gv->FILE;
-	$line = $gv->LINE;
-	process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
-    }
-}
-
-sub xref_definitions {
-    my ($pack, %exclude);
-    return if $nodefs;
-    $subname = "(definitions)";
-    foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
-		      strict vars FileHandle Exporter Carp PerlIO::Layer
-		      attributes utf8 warnings)) {
-        $exclude{$pack."::"} = 1;
-    }
-    no strict qw(vars refs);
-    walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
-}
-
-sub output {
-    return if $raw;
-    my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
-	$perpack, $pername, $perev);
-    foreach $file (sort(keys(%table))) {
-	$perfile = $table{$file};
-	print "File $file\n";
-	foreach $subname (sort(keys(%$perfile))) {
-	    $persubname = $perfile->{$subname};
-	    print "  Subroutine $subname\n";
-	    foreach $pack (sort(keys(%$persubname))) {
-		$perpack = $persubname->{$pack};
-		print "    Package $pack\n";
-		foreach $name (sort(keys(%$perpack))) {
-		    $pername = $perpack->{$name};
-		    my @lines;
-		    foreach $ev (qw(intro formdef subdef meth subused used)) {
-			$perev = $pername->{$ev};
-			if (defined($perev) && @$perev) {
-			    my $code = $code{$ev};
-			    push(@lines, map("$code$_", @$perev));
-			}
-		    }
-		    printf "      %-16s  %s\n", $name, join(", ", @lines);
-		}
-	    }
-	}
-    }
-}
-
-sub compile {
-    my @options = @_;
-    my ($option, $opt, $arg);
-  OPTION:
-    while ($option = shift @options) {
-	if ($option =~ /^-(.)(.*)/) {
-	    $opt = $1;
-	    $arg = $2;
-	} else {
-	    unshift @options, $option;
-	    last OPTION;
-	}
-	if ($opt eq "-" && $arg eq "-") {
-	    shift @options;
-	    last OPTION;
-	} elsif ($opt eq "o") {
-	    $arg ||= shift @options;
-	    open(STDOUT, ">$arg") or return "$arg: $!\n";
-	} elsif ($opt eq "d") {
-	    $nodefs = 1;
-	} elsif ($opt eq "r") {
-	    $raw = 1;
-	} elsif ($opt eq "D") {
-            $arg ||= shift @options;
-	    foreach $arg (split(//, $arg)) {
-		if ($arg eq "o") {
-		    B->debug(1);
-		} elsif ($arg eq "O") {
-		    $debug_op = 1;
-		} elsif ($arg eq "t") {
-		    $debug_top = 1;
-		}
-	    }
-	}
-    }
-    if (@options) {
-	return sub {
-	    my $objname;
-	    xref_definitions();
-	    foreach $objname (@options) {
-		$objname = "main::$objname" unless $objname =~ /::/;
-		eval "xref_object(\\&$objname)";
-		die "xref_object(\\&$objname) failed: $@" if $@;
-	    }
-	    output();
-	}
-    } else {
-	return sub {
-	    xref_definitions();
-	    xref_main();
-	    output();
-	}
-    }
-}
-
-1;