utils/p-class.pl - metacpan.org

#!/usr/bin/perl -w
#
#  Copyright (c) 1997-2004 Dmitry Karasik
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
# $Id$
#
# dumps hierarchy of widget classes. 
#
# Used by podview ( see File/Run/p-class )
#
use strict;

my $glob_path;
my $debug = 0;
my $want_all;
my $want_hier;
my @want_class;
my $otype_pod = 1;
my $ftype_pod = 0;

for ( @ARGV) {
	if ( m/^--help$/ || m/^-h$/) {
		usage();
	} if ( m/^--debug/ || m/^-d$/) {
		$debug = 1;
	} elsif ( m/^--path=(.+)$/) {
		$glob_path = $1;
	} elsif ( m/^--perldoc$/ || m/^-c$/) {
		$ftype_pod = 2;
	} elsif ( m/^--podview$/ || m/^-p$/) {
		$ftype_pod = 1;
	} elsif ( m/^--text$/ || m/^-t$/) {
		$otype_pod = 0;
	} elsif ( m/^--hier$/) {
		$want_hier = 1;
	} elsif ( m/^--all$/) {
		$want_all = 1;
	} elsif ( !m/^-/) {
		$_ = "Prima::$_" unless /^Prima::/;
		push @want_class, $_;
	} else {
		die "Unknown option `$_'\n";
	}
}

die "The '--all' option and explicit classes names cannnot be set together\n" 
if $want_all && @want_class;

usage() if !$want_all && !@want_class;

sub usage
{
		print <<HELP;

p-class - generates documentation on Prima classes hierarchy 

format:
   p-class [--option] [--option=VALUE] class_name

options:
  --path=PATH    - search Prima installation in the path, instead of \@INC
  [-t|--text]    - output in text format, instead of pod ( default )
  [-d|--debug]   - verbose debug info
  [-h|--help]    - display help
  --all          - dump information for all Prima classes found
  --hier         - produce only hierarchy tree
  [-p|--podview] - run podview
  [-c|--perldoc] - run perldoc

examples:
    p-class -p Edit 
    p-class -t --hier Button
    p-class --all --hier -c
   
HELP
		exit;
}

unless ( $glob_path) {
	for ( '../..', '..', '.', @INC) {
		next unless -f "$_/Prima.pm";
		$glob_path = $_;
		last;
	}
}

die "Cannot find Prima.pm\n" unless defined $glob_path;
print "Using $glob_path as root\n" if $debug;

my %paths = (
	'pod/Prima/*.pod' => { # source tree 
		type      => 'pod',
		classes   => 'kernel',
		exclude   => qr/\/([a-z]|X11)[^\s\/]*\.pod$/, # no lowercase
		invariant => 1,
	},
	'Prima/*.pod' => { # installed
		type      => 'pod',
		classes   => 'kernel',
		exclude   => qr/\/([a-z]|X11)[^\s\/]*\.pod$/, # no lowercase
		invariant => 1,
	},
	'Prima/*.pm' => {
		type     => 'pm',
		classes  => 'user',
		exclude  => qr/\b(Classes|Application|Make|Themes|Tie|Const|IniFile|noX11|StdBitmap|Stress|Utils|StartupWindow|Config|EventHook|MsgBox|Utils|Gencls)\.pm$/,
	},
	'Prima/Classes.pm' => {
		type     => 'pm',
		classes  => 'kernel',
	},
	'Prima/Application.pm' => {
		type     => 'pm',
		classes  => 'kernel',
	},
	'Prima/PS/*.pm' => {
		type     => 'pm',
		classes  => 'user',
		exclude  => qr/(Setup|Fonts|Encodings)\.pm$/,
	},
);

# the script deduces the property type from the head name, but sometimes fails.
# here are the hints to proper types
my @hints = (
	{
		match    => qr/Prima\/Object.pod\/Events/,
		property => undef,
	},
);

my ( $pod_root, @itemgroups, @stack, %invariants);
my (%ascendants, %class_priority, %all_items, %pods);

sub new_entry
{
	my $entry = { @_, children => [] };
	$entry->{path} = join('/', map { $_->{topic}} @stack);
	$entry->{pod_root} = $pod_root;
	push @itemgroups, $entry;
	$entry;
}

# load pod content from files
while ( my ($path, $path_hints) = each %paths) {

	# check invariant paths
	next if $path_hints->{invariant} && $invariants{$path_hints->{invariant}};
	my @glob = glob "$glob_path/$path";
	next unless @glob;
	$invariants{$path_hints->{invariant}} = 1 if $path_hints->{invariant};
	
	for ( @glob) {
		next if $path_hints->{exclude} && m/$path_hints->{exclude}/;
		my $filename = $_;
		open F, $filename or die "Cannot open $filename:$!\n";

		print "FILE $filename\n" if $debug;
		my $root = {
			type     => 'pod',
			topic    => $filename,
			children => [],
			path     => $filename,
		};
		my $cap_name = 0;
		$pod_root = $filename;
		$pod_root =~ s/^.*?(Prima)/$1/;
		$pod_root =~ s/\//::/g;
		$pod_root =~ s/\.[\w]+$//;
		my $class_priority = (( $path_hints->{classes} eq 'kernel' ) ? 1 : 0);
	
		@stack = ($root);
		my $over = 0;
		@itemgroups = ($root);
		my $last_package;
		
		while (<F>) {
			if ( $path_hints->{type} ne 'pod') {
				unless ( m/^=(pod|head)/ .. m/^=cut/) {
					if ( m/package (Prima::.*);/) {
						$last_package = $1;
					} elsif ( defined $last_package && m/\@ISA\s*=\s*qw\s*\(([^\)]*)\)/) {
						$ascendants{$last_package} = [ grep { /^Prima/} split ' ', $1];
						$class_priority{$last_package} = $class_priority;
						print "=> $path_hints->{classes} $last_package inherits @{$ascendants{$last_package}}\n"
							if $debug;
					}
					next;
				}
			}
	
			# store pod commands in a hierarchy
			my ($head,$topic,$parent,$entry); # any entry created?
			if ( m/^=(\S+)\s*(.*?)\s*$/) {
				( $head, $topic) = ( $1, $2);
				# print "$1 $2\n";
				if ( $head eq 'head1' && $topic eq 'NAME') {
					$cap_name = 1;
					next;
				}

				if ( $head eq 'head1') {
					$entry = new_entry( type => 'head1', topic => $topic );
					$parent = $root;
					@stack = ($root, $entry);
				} elsif ( $head eq 'head2') {
					pop @stack while @stack && $stack[-1]->{type} !~ /head1|pod/;
					$entry = new_entry( type => 'head2', topic => $topic);
					$parent = $stack[-1];
					push @stack, $entry;
				} elsif ( $head eq 'over') {
					$parent = $stack[-1];
					$entry = new_entry( type => 'over', topic => 'over', depth => $over++);
					push @stack, $entry;
				} elsif ( $head eq 'back') {
					$over--;
					pop @stack;
				} elsif ( $head eq 'item') {
					push @{$stack[-1]->{children}}, $topic;
				} elsif ( $head =~ m/for|cut|pod/ ) {
				} else {
					warn "unknown pod directive '$head'\n";
				}
			} else {
				# extract the full name from =head1 NAME
				if ( $cap_name) {
					next unless m/^\S+/m;
					chomp;
					$cap_name = 0;
					
					$entry = new_entry( type => 'head1', topic => $topic = $_, root_class => 1);
					$parent = $root;
				}
			}

			# check various dependencies in $entry
			if ( $entry) {
				# hierarchy
				push @{$parent->{children}}, $entry;

				# property
				if ( $topic =~ /(method)|(propert)|(event)/oi) {
					$entry->{property} = ( $1 ? 'Methods' : ( $2 ? 'Properties' : 'Events'));
				} elsif ( defined $parent->{property}) {
					$entry->{property} = $parent->{property} 
				}

				# classes
				if ( $topic =~ /(Prima::[\w\d_\:]+)/) {
					$entry->{class} = $1;
					$pods{$1} = $pod_root;
				} elsif ( defined $parent->{class}) {
					$entry->{class} = $parent->{class};
					$pods{$entry->{class}} = $pod_root;
				}
				if ( $entry->{class} && $entry->{root_class}) {
					$parent->{class} = $entry->{class}; # for =head1 NAME
				}

				# apply hints
				for my $hint ( @hints) {
					if ( $entry->{path} =~ /$hint->{match}/) {
						$entry->{property} = $hint->{property} if exists $hint->{property};
					}
				}
			}
		}
		close F;
		# pod stream parse over - now parse dom

		# run
		for ( @itemgroups) {
			my $i = $_;
			my ( $prop, $class, $d_prop);
			if ( $debug) {
				print "$i->{path} $i->{topic}\n";
				$d_prop  = $i->{property} || '??';
				$class   = $i->{class} || '**';
				$d_prop  = '--' if $i->{type} eq 'over' && $i->{depth} > 0;
			} else {
				next if !defined $i->{property} || !defined $i->{class} ||
								($i->{type} eq 'over' && $i->{depth} > 0);
				$class = $i->{class};
			}
			$prop = $i->{property};
			
			for (@{$_->{children}}) {
				next if ref($_) eq 'HASH';
				if ( $otype_pod) {
					s/</\0xff/g;
					s/>/\0xfe/g;
					s/\0xff/E<lt>/g;
					s/\0xfe/E<gt>/g;
				}
				my $topic = $_;
				s/\s.*$//;
				my $link = $_;
				print " $d_prop  $class\:\:$topic => $pod_root/$link\n" if $debug;
				push @{$all_items{$class}->{$prop}}, [ $topic, $pod_root, $link ]
					if defined $prop; # just when debugging
				$pods{$class} = $pod_root;
			}
		}
	}
}

# inheritance tree
my %descendants;
while ( my ( $class, $inh) = each %ascendants) {
	print "$class => @$inh\n" if $debug;
	for ( @$inh) {
		push @{$descendants{$_}}, $class;
	}
}

# hacks hacks!
$class_priority{'Prima::Object'} = 2;
$class_priority{'Prima::Widget'} = 1;
$pods{'Prima::AbstractMenu'} = $pods{'Prima::Menu'};
$pods{'Prima::ReplaceDialog'} = $pods{'Prima::FindDialog'};

my $prio = 3;
my %processed_classes;

for ( keys %descendants) {
	$class_priority{$_} = -1 unless defined $class_priority{$_}; # roots except Prima::Object
}

my $header;
my $links_body;# = ( $otype_pod ? "=head1 HIERARCHY\n\n" : '');
my @classes;

if ( @want_class) {
	for ( @want_class) {
		if ( $all_items{$_} || $descendants{$_} || $ascendants{$_}) {
			$header = "$_ - hierarchy";
			push @classes, $_;
		} else {
			print "No information for `$_'\n";
			exit;
		}
	}
} else {
	$header = "Prima - hierarchy of Prima classes";
	while ( $prio-- >= 0) {
		for ( grep { $class_priority{$_} == $prio } keys %descendants) {
			my @big_class_list = ($_);
			while ( $_ = shift @big_class_list) {
				next if $processed_classes{$_};
				next if ($class_priority{$_} < $prio - 1);
				$processed_classes{$_} = 1;
				push @big_class_list, @{$descendants{$_}} if $descendants{$_};
				# print "$_ => @{$descendants{$_}} \n" if $descendants{$_};
				push @classes, $_;
			}
		}
	}
}

sub dump_class
{
	my $class = $_[0];
	my %items; 
	my @traverse = ( $class);
	my @all_classes;
	# run inheritance traversal
	print "Traverse $class\n" if $debug;
	$links_body .= "=head1 $class\n\n" if $otype_pod;

	while ( $_ = shift @traverse) {
		push @traverse, @{$ascendants{$_}} if $ascendants{$_};
		push @all_classes, $_;
	}

	$links_body .= ( $otype_pod ? "=head2 Related classes\n\n" : "* Related classes\n\n")
		unless $want_hier;
	for ( reverse @all_classes) {
		my $pod = $pods{$_} ? " in $pods{$_} manpage" : '';
		if ( $otype_pod) {
			$links_body .= ( $pods{$_} ? "L<$_|$pods{$_}/>$pod\n\n" : "$_\n\n");
		} else {
			$links_body .= "    $_$pod\n";
		}
	}

	return if $want_hier;
	
	for ( @all_classes) {
		my $curr_class = $_;
		print "-> $curr_class\n" if $debug;
		$links_body .= ( $otype_pod ? "=head2 $curr_class\n\n" : "\n\n* $curr_class\n");
		if ( $all_items{$curr_class}) {
			while ( my ( $prop, $items) = each %{$all_items{$curr_class}}) { # e.g. METHOD, EVENT, PROPERTY
				print "  -> $prop\n" if $debug;
				$links_body .= ( $otype_pod ? "B<$prop>\n\n=over 4\n\n" : "\n - $prop\n"); 
				for ( @$items) {
					my ( $topic, $root, $name) = @$_;
					$items{$prop}->{$name} = "L<$topic|$root/$name>";
					print "    +-> $name\n" if $debug;
					$links_body .=  ( $otype_pod ? $items{$prop}->{$name} . "\n\n" : "    $topic\n");
				}
				$links_body .= "\n\n=back\n\n" if $otype_pod;
			}
		}
	}
}

dump_class($_) for @classes;


my $text;
if ( $otype_pod) {
	$text = "=pod\n\n=head1 NAME\n\n$header\n\n$links_body\n=cut\n\n";
} else {
	$text = "\n$header\n\n$links_body\n";
}

if ( $ftype_pod) {
	my $rname = ( $want_all ? 'prima-classes' : $want_class[0]);
	$rname =~ s/[\\:\/]/_/g;
	my $d = ($ENV{TEMP}?$ENV{TEMP}:'/tmp')."/$rname.$$";
	open F, "> $d" or die "Cannot write $d:$!\n";
	print F $text;
	close F;
	my $proc = ( $ftype_pod == 1 ? 'podview' : 'perldoc');
	system( $proc, $d) == 0 or warn "Error running $proc $d:$?$!\n";
	unlink $d;
} else {
	print $text;
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)