#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

# use strict;
require Exporter;
require AutoLoader;

use strict;
use CGI;

$W3C::Util::ShowSource::REVISION = '$Id: ShowSource.pm,v 1.15 2004/03/29 06:45:50 eric Exp $ ';

package W3C::Util::ShowSource;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK @TODO);
@ISA = qw(CGI Exporter AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.97;
$DSLI = 'adpO';
@TODO = ('make it faster');

#####
# per-object data
# user parameters:
# SOURCES	- ARRAY names of source files
# LABELS	- HASH labels for these sources
# CGI		- SCALAR ref to caller's CGI object
# internal variables:
# SEARCH_ORDER	- ARRAY SOURCES reverse sorted by length
# UNIQUES	- HASH temp search substitutions
# LINKS		- HASH final search substitutions

#####
# new - prepare a W3C::Util::ShowSource with everything it needs to present itself

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);

    my $sources = shift;
    my $labels = shift;
    my @searchOrder = @$sources;
    @searchOrder = sort {return length($a) < length($b)} @searchOrder;
    my %uniques;
    my %links;

    #####
    # user parameters:
    $self->{SOURCES} = $sources;
    $self->{LABELS}  = $labels;
    $self->{CGI} = shift;

    #####
    # internal variables:
    $self->{SEARCH_ORDER} = \@searchOrder;
    $self->{UNIQUES} = \%uniques;
    $self->{LINKS} = \%links;
    foreach my $source (@searchOrder) {
	$uniques{$source} = $self->unique;
	$links{$source} = '<a href=\'#'.$labels->{$source}.'\'>'.$labels->{$source}.'</a>';
    }

    return $self;
}

sub unique {
    my ($self) = @_;
    return 'left'.rand(1).'right';
}

#####
# preset - present all the sources in SOURCE

sub present {
    my ($self, $useColor, $funcLinks, $funcList) = @_;
#    print $self->{BLURB};
    my $sources = $self->{SOURCES};
    foreach my $source (@$sources) {
	$self->showSource($source, $useColor, $funcLinks, $funcList);
    }
}

#####
# showSource - present a single source file

sub showSource {
    my ($self, $source, $useColor, $funcLinks, $funcList) = @_;
    my $labels = $self->{LABELS};
    my $label = $labels->{$source};
    my $cgi = $self->{CGI};
    my $sources = $self->{SOURCES};
    my $searchOrder = $self->{SEARCH_ORDER};
    my $uniques = $self->{UNIQUES};
    my $links = $self->{LINKS};
    my $uniqueHash = $self->unique;
    my $uniqueFont = $self->unique;
    my $uniqueSQuote = $self->unique;
    my $uniqueDQuote = $self->unique;

    print '<hr><h2><a name="'.$labels->{$source}.'">'.$labels->{$source}.'</a>';
    my $fh = $self->openInc($source);
    if (!defined $fh) {
	print ' not found</h2>'."\n";
	return;
    }
    print '</h2>'."\n".'<pre>'."\n";
    while (<$fh>) {
	#for some reason, print escaping goes away when crossing a module boundry
	$_ = $cgi->escapeHTML($_);

	# do the Ted Turner thing									(colorize it, get it?)
	s/font/$uniqueFont/gm;
	s/(\$|\\)\'/$1$uniqueSQuote/gm;
	s/(\$|\\)\"/$1$uniqueDQuote/gm;
	s/(\$|\\)\#/$1$uniqueHash/gm;
	s/\#(.*)/<font color=${uniqueDQuote}red${uniqueDQuote}>\#$1<\/font>/gmx;
	s/$uniqueHash/\#/gm;
	s/sub (\s [^\{]*) (\s \{)?/sub<font color=${uniqueDQuote}blue${uniqueDQuote}>$1<\/font>$2/gsx;
	s/\b(sub|else|until|elsif|if|while|foreach|for|return)\b/<font color=${uniqueDQuote}purple${uniqueDQuote}>$1<\/font>/gm;
	s/(my)/<font color=${uniqueDQuote}green${uniqueDQuote}>$1<\/font>/gm;
	s/(\@|\$|\#)(\w+)/$1<font color=${uniqueDQuote}orange${uniqueDQuote}>$2<\/font>/gm;
	s/\'([^\']*)\'/'<font color=${uniqueDQuote}pink${uniqueDQuote}>$1<\/font>'/gm;
	s/\"([^\"]*)\"/"<font color=${uniqueDQuote}pink${uniqueDQuote}>$1<\/font>"/gm;
	s/$uniqueSQuote/\'/gm;
	s/$uniqueDQuote/\"/gm;

	# change to unique strings - see explaination at top
	foreach my $source (@$searchOrder) {
	    s/$labels->{$source}/$uniques->{$source}/g;
	}
	# change unique strings to real values - see explaination at top
	foreach my $source (@$searchOrder) {
	    s/$uniques->{$source}/$links->{$source}/g;
	}

	my @pieces = split ('((?:<|<\/)font[^>]*\>)', $_);
	my $nested = 0;
	my $ret = '';
	foreach my $piece (@pieces) {
	    if ($nested == 0) {		# 0: outside font
		if ($piece =~ m/<font/) {
		    $nested++;
		}
		$ret .= $piece;
	    } elsif ($nested == 1) {	# 1: inside font
		if ($piece =~ m/<font/) {
		    $nested++;
		} elsif ($piece =~ m/<\/font/) {
		    $ret .= $piece;
		    $nested--;
		} else {
		    $ret .= $piece;
		}
	    } else {			# n: inside more than one font
		if ($piece =~ m/<font/) {
		    $nested++;
		} elsif ($piece =~ m/<\/font/) {
		    $nested--;
		} else {
		    $ret .= $piece;
		}
	    }
	}
	$ret =~ s/$uniqueFont/font/gm;
	print $ret;
    }
    close($fh);
    print '</pre>'."\n";
}

#####
# openInc - find a source file in perl's INC path

sub openInc {
    my $self = shift;
    my $lookFor = shift;
    local *FH;
#    foreach my $path (@INC) {
#	open(FH, $path.'/'.$lookFor) && return *FH;
#    }
    $lookFor =~ s/::/\//g;
    my $lookIn = $INC{$lookFor};
    $lookIn = $lookFor if (!defined $lookIn);
    open(FH, $lookIn) && return *FH;
    return undef;
}

1;

__END__

=head1 NAME

W3C::Util::ShowSource - CGI wrapper to help debug CGIs

=head1 SYNOPSIS

  use W3C::Util::ShowSource;
  my $showSource = W3C::Util::ShowSource->new(\@sources, \%paths, $query);
  $showSource->present($useColor, $funcLinks, $funcList);

=head1 DESCRIPTION

=head2 What It Does:

 Given a list of sources and labels for them, W3C::Util::ShowSource builds a page of the
 sources. The sources are slightly pretty-printed in that each ref to another
 source is href'd.

=head2 How It Works:

 The text href substitutions are done in two stages, first to a uniqe string,
 and finally to the string build of the href to the other source. The sources
 are sorted by descending length so that W3C::Util::ShowSource will replace abcde before
 abc.

=head2 Example Invocation:

    my @sources = ('chaclCGI.pl', 'W3C::Rnodes::W3CAclInterface.pm', 'W3C::Database::DBIInterface.pm', 
		   'W3C::Util::Properties.pm', 'W3C::Util::ShowSource.pm', 'W3C::Rdf::RdfParser.pm', 
		   'W3C::XML::XmlParser.pm', 'W3C::XML::InputSource.pm', 'W3C::XML::AttributeListImpl.pm', 
		   'W3C::XML::HandlerBase.pm', 'W3C::XML::SAXException.pm', 'W3C::XML::SAXParseException.pm', 
		   'W3C::XML::HandlerBase.pm', 'W3C::XML::XmlElement.pm');
    my %paths = ('chaclCGI.pl' => 'chaclCGI', 
		 'W3C::Rnodes::W3CAclInterface.pm' => 'W3CAclInterface', 
		 'W3C::Database::DBIInterface.pm' => 'DBIInterface',
		 'W3C::Util::Properties.pm' => 'Properties', 
		 'W3C::Util::ShowSource.pm' => 'ShowSource', 
		 'W3C::Rdf::RdfParser.pm' => 'RdfParser', 
		 'W3C::XML::XmlParser.pm' => 'XmlParser', 
		 'W3C::XML::InputSource.pm' => 'InputSource', 
		 'W3C::XML::AttributeListImpl.pm' => 'AttributeListImpl', 
		 'W3C::XML::HandlerBase.pm' => 'HandlerBase', 
		 'W3C::XML::SAXException.pm' => 'SAXException', 
		 'W3C::XML::SAXParseException.pm' => 'SAXParseException', 
		 'W3C::XML::HandlerBase.pm' => 'HandlerBase', 
		 'W3C::XML::XmlElement.pm' => 'XmlElement');

    my ($useColor, $funcLinks, $funcList) = ($query->param('_w3c_useColor'), 
					     $query->param('_w3c_funcLinks'), 
					     $query->param('_w3c_funcList'));
    #####
    # Start the page
    print $query->header(-expires=>'+4h');
    print $query->start_html(-title=>'ACL Editor Sources', -BGCOLOR=>"#FFFFFF", -TEXT=>"#000000", -LINK=>"#0000ee", -VLINK=>"#551a8b");
    print <<EOF;
<h1>ACL Editor Sources</h1>
    <p>
    <a href='#chaclCGI'>chaclCGI</a> presents the the current 
    ACLs for a resource and creates forms to manipulate them. 
    <a href='#chaclCGI'>chaclCGI</a> then handles 
    the output from the forms. Both are layered on top of 
    <a href='#W3CAclInterface'>W3C::Rnodes::W3CAclInterface.pm</a> and 
    <a href='#DBIInterface'>W3C::Database::DBIInterface.pm</a>.
    <p>
    RDF parsing facilities are handled by a stack of parser:
    <pre>
    <a href='#RdfParser'>W3C::Rdf::RdfParser</a>
       |
    <a href='#XmlParser'>W3C::XML::XmlParser</a>
    </pre> The <a href='#XmlParser'>W3C::XML::XmlParser</a> is an
    implementation of a SAX interface ported to perl. It uses:
    <ul>
	<li><a href='#InputSource'>W3C::XML::InputSource</a>
	<li><a href='#AttributeListImpl'>W3C::XML::AttributeListImpl</a>
	<li><a href='#HandlerBase'>W3C::XML::HandlerBase</a>
	<li><a href='#SAXException'>W3C::XML::SAXException</a>
	<li><a href='#SAXParseException.'>W3C::XML::SAXParseException.</a>
	<li><a href='#HandlerBase'>W3C::XML::HandlerBase</a>
	<li><a href='#XmlElement'>W3C::XML::XmlElement</a>
    </ul>
    <p>
    &lt;brought to you by <a href='#ShowSource'>W3C::Util::ShowSource.pm</a>&gt;.
EOF
    ;

    #####
    # Print source
    my $showSource = W3C::Util::ShowSource->new(\@sources, \%paths, $query);
    $showSource->present($useColor, $funcLinks, $funcList);

This module is part of the W3C::Utils CPAN module.

=head1 AUTHOR

Eric Prud\'hommeaux <eric@w3.org>

=head1 SEE ALSO

perl(1).

=cut

