#!/usr/bin/perl -w
#-------------------------------------------------------------------------------
# perlvar.pl                                (C) 2003-2005 T.Birnthaler OSTC GmbH
# Aus "perldoc perlvar" alle Variablen extrahieren.
#-------------------------------------------------------------------------------
use strict;

# Variablendeklarationen
my (@vars);
my ($opt, $all, $count, $debug, $normal, $special) = ("", 1, 0, 0, 0, 0);

#-------------------------------------------------------------------------------
# Vergleichsfunktionen
#-------------------------------------------------------------------------------
# Kompletten Variablennamen vergleichen (inkl. Präfix)
my $cmpfunc = sub { $a cmp $b };

# Reinen Textanteil des Variablennamens vergleichen
# (falls gleich, kompletten Variablennamen verwenden!)
my $cmpalpha = sub {                    # Gross/Kleinschreibung egal
	my ($aa, $bb);                      # KEINER -> ganz vorne
	($aa = uc($a)) =~ s/^[\W_]+//;      # Underscore = Buchstabe!
	($bb = uc($b)) =~ s/^[\W_]+//;      # Underscore = Buchstabe!
	if ($aa ne "" and $bb ne "") {      # 2x Textanteil?
		$aa cmp $bb or
		$a  cmp $b;
	}
	elsif ($aa eq "" and $bb eq "") {   # Keinmal Textanteil?
		$a cmp $b;
	}
	else {                              # Mischung?
		$aa cmp $bb;
	}
};

# Variablenlänge vergleichen
# (falls gleich, kompletten Variablennamen verwenden!)
my $cmplen = sub {
	length($a) <=> length($b) or
	$a cmp $b;
};

#-------------------------------------------------------------------------------
# Usage-Meldung (mit Strichpunkt auf EXTRA Zeile absetzen!)
#-------------------------------------------------------------------------------
my $usage = <<EOF
usage: $0 [OPTIONS]

       Alle Perl-Variablen aus 'perldoc perlvar' ausgeben
       (Std: Sortiert nach Variablenname incl. Präfix).

       -a Alphabetisch sortieren ohne Präfix zu beachten [alpha]
       -a Variablen zählen [count]
       -h Diese Meldung anzeigen [help]
       -l Nach Länge sortieren [length]
       -n Nur normale Bezeichner [words]
       -s Nur spezielle Bezeichner [special]
       -d Ablaufmeldungen [debug]
EOF
;   # Nicht vergessen!

#-------------------------------------------------------------------------------
# Optionen erkennen
#-------------------------------------------------------------------------------
while (defined($ARGV[0]) && $ARGV[0] =~ /^-/) {
	$opt = shift @ARGV;
	if ($opt eq "-a") {
		$cmpfunc = $cmpalpha;
	}
	elsif ($opt eq "-c") {
		$count = 1;
	}
	elsif ($opt eq "-d") {
		$debug = 1;
	}
	elsif ($opt eq "-l") {
		$cmpfunc = $cmplen;
	}
	elsif ($opt eq "-h") {
		die "$usage\n";
	}
	elsif ($opt eq "-n") {
		$all     = 0;
		$normal  = 1;
	}
	elsif ($opt eq "-s") {
		$all     = 0;
		$special = 1;
	}
	else {
		die "error: wrong option $opt\n$usage\n";
	}
}

# Nichts darf übergeben werden!
@ARGV == 0 or
	die "error: no arguments allowed\n$usage\n";

#-------------------------------------------------------------------------------
# Variablen suchen, die Zeile muß folgende Form haben (vorher NEWLINE und
# Hervorhebungen der Form ZEICHEN BACKSPACE entfernen, BACKSPACE = Strg-H):
# * Einen der folgenden Fälle:
#   + Erst 7 SPACES
#     - Dann eines der Zeichen $ @ %
#     - Dann
#       . Ein BEZEICHNER (Wort)
#       . 1 Sonderzeichen
#       . 2 Sonderzeichen
#       . 1 Sonderzeichen und 1 Wortzeichen
#       . "{^" BEZEICHNER "}"
#       . TEXT "<digits>"
#       . Bezeichner "a" oder "b" (1 Zeichen)
#   + BEZEICHNER aus mind. 2 Großbuchstaben (Wort)
#   + Beginnend mit "HANDLE->"
#   + Beginnend mit "IO::Handle->"
# * Dann WHITESPACE oder Zeilenende
#-------------------------------------------------------------------------------
print "# Lese 'perldoc perlvar'...\n" if ($debug);
foreach (`perldoc perlvar`) {
	print if ($debug);
	chomp;                      # NEWLINE entfernen
	s/.\cH//g;                  # Zeichen+BACKSPACE entfernen (Hervorhebung)
	next unless (m/             # Keine Variable am Zeilenanfang -> nächste Zl.
		^                       # Zeilenanfang
		\s{7}                   # 7 Leerzeichen
		(
			[\$@%]              # Variablenpräfix $@%
			(
				\b\w+\b   |     # Bezeichner (Wort) ODER
				\W        |     # 1 Sonderzeichen ODER
				\W\W      |     # 2 Sonderzeichen ODER
				\W\w      |     # 1 Sonderzeichen und 1 Wortzeichen ODER
				\{\^\w+\} |     # {^BEZEICHNER} ODER
				<digits>  |     # Untermuster-Match-Variablen $1, $2, ...
				[ab]            # Bezeichner $a oder $b
			)           |
			[A-Z][A-Z]+ |       # Bezeichner aus mind. 2 Großbuchstaben
			HANDLE->.*  |       # Bezeichner beginnend mit HANDLE->
			IO::Handle->.*      # Bezeichner beginnend mit IO::Handle->
		)
		(:?
				\s |            # Whitespace ODER
				$               # Zeilenende
		)
		/x);
	push @vars, $1;             # Gefundene Perlvariable merken
	print "# $1 gefunden\n" if ($debug);
}

#-------------------------------------------------------------------------------
# Variablen sortiert ausgeben (mehrfach vorkommende nur 1x)
#-------------------------------------------------------------------------------
my $last   = "";
my $nr     = 0;
my $double = 0;
foreach (sort $cmpfunc @vars) {
	++$double if ($_ eq $last);
	print "# $_ doppelt\n" if ($debug and $_ eq $last);
	next if ($_ eq $last);
	$last = $_;
	if ($all or
	    $normal  and $_ =~ /[\$@%][A-Za-z]\w+/ or
	    $special and $_ !~ /[\$@%][A-Za-z]\w+/) {
		++$nr;
		print "$_\n";
	}
}

#-------------------------------------------------------------------------------
# Statistik ausgeben
#-------------------------------------------------------------------------------
print "# ", scalar @vars, " Variablen (einschließlich doppelte)\n" if ($debug);
print "# ", $double, " doppelt\n" if ($debug);
if ($count or $debug) {
	print "# " if ($debug);
	print "$nr ";
	print "englische " if ($normal);
	print "spezielle " if ($special);
	print "Variablen\n";
}