P4CGI.pm #3

#!/usr/bin/perl -w
# -*-perl-*-
#################################################################
# This is the "P4CGI" perl module.
#
package P4CGI ;
use CGI ;
use CGI::Carp ;
use strict;
###
###
###
my $VERSION ;


###
### Module variables
###
my $P4 ;
my $CGI ;
local *P4 ;
my $currentChangeLevel ;
my $TMPDIR ;
my $pageEndPrinted ;
my $pageStartPrinted ;
my %administrators ;

sub init ( )
{
				## death handler
    $SIG{'__DIE__'} = sub {	# Thank You Ron Shalhoup for the idea
	my($error) = shift; 
	&P4CGI::bail($error) ;	
	exit 0; 
    }; 
    #
    # Set version
    #
    $VERSION="0.99f" ;
    
    #
    # Initiate CGI module (if we run as a cgi script!)
    #
    $0 =~ /.cgi$/ and do { $CGI = new CGI ; } ;

    #
    # Read configuration file
    #
    my $configFile="config" ;
    unless( -r $configFile) {
	$configFile="config.org" ;
    } ;
    eval `cat $configFile` ;
				# Bail on error
    if($@) {
	$@ =~ s/\n/\n<br>/g ;	
	&P4CGI::bail("Error reading config file \"$configFile\".","<p><pre>$@</pre>") ;
    } ;
    
    #
    # Check that we have contact with p4 server
    #
    $currentChangeLevel=4711 ;
    my $d ;
    p4call(\$d,"changes -m 1") ;
    $d =~ /Change (\d+)/ or &P4CGI::bail("No contact with P4 server") ;
    $currentChangeLevel=$1 ;  
} ;

#################################################################
### Documentation start
=head1 NAME

P4CGI - Support for CGI's that interface p4. Written specifically for P4DB

=cut ;

sub DEFAULT_TABLE_ATTRIBUTES() { "" ; } ;
sub CURRENT_CHANGE_LEVEL() { $currentChangeLevel ; } ;

###################################################################
### Constants for depot browser
###

=head1 CONSTANTS

The constants are defined as perl subroutines.

=head2 Url's

=over 4

=item P4CGI::MAIN_URL()

Main entry point.

=item P4CGI::DTB_URL()

URL to depot tree browser. 

=item P4CGI::CHB_URL()

URL to change browser. 

=item P4CGI::CHV_URL()

URL to change viewer. 

=item P4CGI::FV_URL()

URL to file viewer. 

=item P4CGI::SFV_URL()

URL to special file viewer.

=item P4CGI::SFV_HTML_URL()

URL to special file viewer for HTML

=item P4CGI::FLV_URL()

URL to file log viewer.

=item P4CGI::FDV_URL()

URL to file diff viewer.

=item P4CGI::LDV_URL()

URL to label diff viewer.

=item P4CGI::CL_URL()

URL to view submitted changelists.

=item P4CGI::SFF_URL()

URL to search for file.

=item P4CGI::LAU_URL()

URL to list all users.

=item P4CGI::LU_URL()

URL to view a user.

=item P4CGI::LAB_URL()

URL to list all branches.

=item P4CGI::LAL_URL()

URL to list all labels.

=item P4CGI::LV_URL()

URL to view a labels.

=back

=cut ;

sub MAIN_URL() { "index.cgi"  ; } ;
sub DTB_URL()  { "dtb.cgi"  ; } ;
sub CHB_URL()  { "chb.cgi"  ; } ;
sub CHV_URL()  { "chv.cgi"  ; } ;
sub FLV_URL()  { "flv.cgi"  ; } ; 
sub FV_URL()   { "fv.cgi"   ; } ; 
sub SFV_URL()  { "sfv.cgi"  ; } ; 
sub SFV_HTML_URL()  { "sfv_html.cgi"  ; } ; 
sub FDV_URL()  { "fdv.cgi"  ; } ; 
sub LDV_URL()  { "ldv.cgi"  ; } ; 
sub SFF_URL()  { "sff.cgi"  ; } ; 
sub CL_URL()  { "cl.cgi"  ; } ; 
sub LAU_URL()  { "lau.cgi"  ; } ;
sub LU_URL()   { "lu.cgi"   ; } ;
sub LAB_URL()  { "lab.cgi"  ; } ;
sub LAL_URL()  { "lal.cgi"  ; } ;
sub LV_URL()   { "lv.cgi"   ; } ;

=head1 SUBROUTINES

=cut ;

###################################################################
###  cgi
###

=head2 P4CGI::cgi()

Return CGI reference 

Example:

    my $file = P4CGI::cgi()->param("file") ;
    print "Parameter \"file\" value: $file\n" ;

=cut
    ;
sub cgi() {
    confess "CGI not initialised" unless defined $CGI ;
    return $CGI ;
}

###################################################################
###  p4call
###

=head2 P4CGI::p4call(I<result>,I<command>)

Request data from p4. Calls p4 with command I<command> and returns data in I<result>.

This function is really three different functions depeding in the type of the
I<result> parameter.

=over 4

=item I<result>

This parameter can be of three different types:

=over 4

=item Filehandle (typeglob)

Data from command can be read from filehandle. NOTE! File must be closed by
caller.

=item Reference to array

Returns result from command  in array (newlines stripped)

=item Reference to scalar

Returns result from command in scalar. (lines separated by newline)

=back

Any other type of parameter will abort operation

=item I<command>

Command to send to p4 command line client.

=back

Example:

    my $d ;
    &P4CGI::p4call(\$d,"changes -m 1") ;
    $d =~ /Change (\d+)/ or &bail("No contact with P4 server") ;
    $currentChangeLevel=$1 ;    

=cut
    ;
sub p4call {
    my ( $par, @command ) = @_;
    my $partype = ref $par ;
    if(!$partype) {
	open( $par, "$P4 @command|" ) || &bail( "p4 @command failed" );
	return ;
    }  ;
    "ARRAY" eq $partype and do {
	@$par = () ;
	open( P4, "$P4 @command|" ) || &bail( "p4 @command failed" );
	while(<P4>) {
	    chomp ;
	    push @$par,$_ ;
	} ;
	close P4 ;
	return ;
    } ;
    "SCALAR" eq $partype and do {
	$$par = "" ;
	open( P4, "$P4 @command|" ) || &bail( "p4 @command failed" );
	while(<P4>) {
	    $$par .= $_ ;
	} ;
	close P4 ;
	return ;
    } ;
    die("Called with illegal parameter ref: $partype") ;
} ;

###################################################################
###  start_page
###

=head2 P4CGI::start_page(I<title>[,I<legend>])

Start a page. Print http header and first part of HTML.

=over 4

=item I<title>

Title of page

=item I<legend> (Optional)

Short help text to be displayed at top of page

=back

Example:

 my $start = P4CGI::start_page("Title of page",
			       &P4CGI::dl_list("This","Goto this",
                                               "That","Goto that")) ;
 print $start ;

=cut ;
sub start_page($$ )
{
    my $title  = shift @_ ;
    my $legend = shift @_ ;
    my $n = 0 ;
    
    my $p4port = "" ;
    if(defined $ENV{P4PORT}) {
	my ($host,$port) = split /:/,$ENV{P4PORT} ;
	$p4port = 
	    "<small><table>\n<tr><th align=right>Host:<br>Port:</th>".
		"<td>$host<br>$port</td></tr></table></small>\n" ;
    }

    my $ret = $CGI->header(). "\n"  ;
    my $t = "$title" ;
    $t =~ s/<br>/ /ig ;
    $t =~ s/<[^>]*>//g ;
    $ret .=  $CGI->start_html(-title   => "P4DB: $t",
			      -author  => "fredric\@mydata.se",
			      -bgcolor => "#e0f0f0",
			      -text    => "#000000",
			      "-link"  => "#000099",
			      -vlink   => "#663366",
			      -alink   => "#993399") . "\n" ;

    $ret .= start_table("width=100% bgcolor=\"#FFFF99\" border=0 cellspacing=8") ;
    $ret .= table_row(-valign  => "top",
		      {-align  => "center",
		       -valign => "center",
		       -width  => "20%",
		       -text   =>
			   "<B>P4DB </B><i><small>Version</small> $VERSION</i><br><small>Current change level:</small> $currentChangeLevel"},
		      {-align  => "center",
		       -valign => "center",
		       -width  => "60%",
		       -bgcolor=> "#ccffff",
		       -text   => "<font size=+1 color=blue><b>$title</b></font>\n"},
		      {-align  => "center",
		       -valign => "center",
		       -width  => "20%",
		       -text   => $p4port}) ;
    $ret .= table_row(-bgcolor => "#cccccc",
		      undef,
		      {-align  => "left",
		       -text   => $legend ? "$legend":""},
		      {-align  => "right",
		       -valign => "top",
		       -text   => ahref(-url=>MAIN_URL(),"Main")}) ;
    $ret .= end_table() ;
    $pageStartPrinted = 1 ;
    return $ret . "<hr>\n" ;    
} ;

###################################################################
###  end_page
###

=head2 P4CGI::end_page()

End a page. Print HTML trailer.

Example:

 print P4CGI::end_page() ;

=cut ;
sub end_page()
{
    $pageEndPrinted = 1 ;
    my $adms ;
    my $adm ;
    foreach $adm (sort keys %administrators) {
	if(defined $adms) {
	    $adms .= " , " ;
	}
	else {
	    $adms = "P4 admin: " ;
	} ;
	$adms .= "<a href=\"mailto:$administrators{$adm}\">$adm</a>" ;
    } ;
    return join("",
		("<hr><small><i>\n",
		 $adms,
		 "</small>",
		 $CGI->end_html())) ;
}

###################################################################
### bail
###

=head2 P4CGI::bail(I<message>)

Report an error. This routine will emit HTML code for an error message and exit. 

=over 4

=item I<message>
Message that will be displayed to user

=back

Example:

 unless(defined $must_be_defined) { 
     &P4CGI::bail("was not defined") ; 
 } ;

=cut ;

sub bail {
    my $message = shift @_ ;
    my $text = shift @_ ;    
    unless(defined $pageStartPrinted) {
	print 
	    "",
	    $CGI->header(),
	    $CGI->start_html(-title   => "Error in script",
			     -bgcolor => "white");
    } ;    
    $message = &fixSpecChar($message) ;
    print 
	"<br><hr color=red><p align=center><font color=red size=+2>An error has occurred<br>Sorry!</font><p><font color=red>Message:<BR><pre>$message</pre><br>" ;
    if(defined $text) { 
	$text = &fixSpecChar($text) ;
	print "<pre>$text</pre><br>\n" ; 
    } ;
    print
	"<p>Parameters to script:<br>",
	$CGI->dump() ;
    print "</font>",end_page() ;
    exit 1 ;
}

###################################################################
### start_table
###  

=head2 P4CGI::start_table(I<table_attribute_text>)

Start a table with optional table attributes

=over 4

=item I<table_attribute_text>

This text will be inserted as attributes to table tag

=back

Example:

    print P4CGI::start_table("align=center border") ;

=cut ;
sub start_table($ ) 
{
    my $attribs = shift @_ ;
    my $ret = "<table " . DEFAULT_TABLE_ATTRIBUTES() ;  
    if($attribs) {
	$ret .=  " $attribs" ;
    }
    return $ret . ">\n";
}

###################################################################
### end_table
###  

=head2 P4CGI::end_table()

Return end of table string. (trivial function included mostly for symmetry)

=cut ;
sub end_table() 
{
    return "</table>\n" ;
}

###################################################################
### tableRow
###

=head2 P4CGI::table_row(I<options>,I<listOfValues>)

Insert a row in table.

=over 4

=item I<options>

A list of key/value pairs (a hash will do just fine) containing options for 
the row. 

The key must start with a "-".

Most key/value pairs are treated as attributes to the <TR>-tag.
The following keys are recognized as special:

=over 4

=item C<-type>

Type of cells. Default is <TD>-type. 

=item C<->I<anykey>

I<anykey> will be assumed to be a row option and will be inserted in the TR-tag. 
The value for the option is the key value, unless value is empty or undefined, in which
case the option anykey is assumed to have no value.

=back

=item C<listOfValues>

Row data. Remaining values are assumed to be data for each cell. 
The data is typically the text in the cell but can also be:

=over 4

=item undef

An undefined value indicates that the next cell spans more than one column. 

=item Reference to a hash

The has contains two keys: "-text" for cell text and "-type" for cell type.
All other key/value pairs are treated as attributes to the <TD> or <TH> tag.

=back

=back

Example:

 print P4CGI::start_table("align=center") ;
                                   ### print header row
 print P4CGI::table_row(-type   => "th",
			-valign => "top",
			-align  => "left",
                        "Heading 1","Heading 2",undef,"Heading 3") ;
                                   ### print data
 my %h = (-text    => "text in hash", 
	  -bgcolor => "blue") ;
 print P4CGI::table_row(-valign  => "top",
			-bgcolor => "white",
                        "Cell 1",
			{-text    => "Cell 2",
			 -bgcolor => "red"},
			\%h,
			"Cell 3-2") ;
 print P4CGI::end_table() ;

=cut ;
sub table_row 
{   
    confess ("P4CGI::table_row() Parameters required!") if @_ == 0 ;
    my @ret ;
    my $n = 0 ;
    my $ec = 0 ;
    my $option = shift @_ ;
    my %options ;
    while(defined $option and ($option =~ s/^-//)) {	
	confess ("P4CGI::table_row() Option value required!") if @_ == 0 ;
	$options{lc($option)} = shift @_ ;
	$option = shift @_ ;
    }
    unshift @_,$option ;
    
    my $type      = "td" ;
    $type = $options{"type"} if defined $options{"type"} ;
    delete $options{"type"} ;

    push @ret,"<tr" ;
    my $attr ;
    foreach $attr (keys %options) {
	push @ret," $attr" ;
	if($options{$attr}) {
	    push @ret,"=$options{$attr}" ;
	}
    }
    push @ret,">\n" ;

    my $colspan = 0 ;
    my $cell ;
    foreach $cell (@_) {
	$colspan++ ;
	if(defined $cell) {
	    my $COLSPAN="colspan=$colspan" ;
	    $colspan=0 ;
	    if(ref $cell) {
		my $reftyp = ref $cell ;
		"HASH" eq $reftyp and do { my $txt = $$cell{"-text"} ;
					   confess "P4CGI::table_row() Missing text argument" 
					       unless defined $txt ;
					   delete $$cell{"-text"} ;
					   my $tp = $type ;
					   $tp = $$cell{"-type"} if defined 
					       $$cell{"-type"} ;
					   delete $$cell{"-type"} ;
					   push @ret,"<$tp $COLSPAN" ;
					   my $attr ;
					   foreach $attr (keys %$cell) {
					       ($a = $attr) =~ s/^-// ;
					       push @ret," $a=$$cell{$attr}" ;
					   }
					   push @ret,">$txt</$tp>\n" ;
					   next ; } ;
		confess "Illegal cell data type \"$reftyp\"" ;
	    } 
	    else {
		push @ret,"<$type $COLSPAN>$cell</$type>\n" ;
	    }
	}
    }
    push @ret,"</tr>\n" ;
    return join("",@ret) ;
}

###################################################################
### Make a list
###

=head2 P4CGI::ul_list(I<list>)

Return a bulleted list.

=over 4

=item I<list>

Lits of data to print as bulleted list

=back

Example:

 print P4CGI::ul_list("This","is","a","bulleted","list") ;

=cut ;
sub ul_list(@ ) 
{
    my @ret ;
    if($_[0] eq "-title") {
	shift @_ ;
	push @ret, shift @_ ;
    }
    push @ret,"<ul>\n" ;
    my $a ;
    foreach $a (@_) {
	push @ret,"<li>$a\n" ;
    }
    push @ret,"</ul>\n" ;
    return join("",@ret) ;
}

###################################################################
### Make an dl list
###

=head2 P4CGI::dl_list(I<list_of_pairs>)

Returns a definition list.

=over 4

=item I<list_of_pairs>

List of data pairs to print as a definition list. 
A hash will do just fine, only that You have no control of the
order in the list. 

=back

Example:

 print P4CGI::dl_list("This","Description of this",
                      "That","Description of that") ;

=cut ;
sub dl_list
{
    my @ret ;
    if($_[0] eq "-title") {
	shift @_ ;
	push @ret,shift @_ ;  
    }
    if($_[0] eq "-compact") {
	push @ret,"<dl compact>\n" ;
	shift @_ ;
    } 
    else {
	push @ret,"<dl>\n" ;
    }
    while(@_ > 1) {
	push @ret,"<dt>",shift @_,"<dd>",shift @_,"\n" ;
    }
    push @ret,"</dl>\n" ;
    return join("",@ret) ;
}

###################################################################
### Fix some special characters
###

=head2 P4CGI::fixSpecChar(I<str>)

Convert all '>' to "C<E<amp>gt;>", '<' to "C<E<amp>lt;>" and '&' to "C<E<amp>amp;>".

=over 4

=item I<str>

String to convert

=back

Example:

    my $cvstr = &P4CGI::fixSpecChar("String containing <,> and &") ;

=cut ;
sub fixSpecChar($ )
{    
    my $d = shift @_ ;
    $d =~ s/&/&amp;/g ; # & -> &amp;
    $d =~ s/\"/&quot;/g;# " -> &quot;
    $d =~ s/</&lt;/g  ; # < -> &lt;
    $d =~ s/>/&gt;/g  ; # > -> &gt;
    return $d ;
}

###################################################################
### Replace tabs with spaces
###

=head2 P4CGI::rmTabs(I<str>)

Convert tabs to spaces

=over 4

=item I<str>

String to convert

=back

=cut ;
sub rmTabs($ )
{    
    # This algorithm is kind of, well, the first thing I came up
    # with. Should be replaced with a smarter (== more efficient)
    # eventually.......
    my $l = shift @_ ;    
    if($l =~ /\t/) {
	my $pos = -1 ;
	$l = join('',map
		  { 
		      $pos++ ;
		      if($_ ne "\t") {
			  $_  ;
		      } else
		      {
			  my $p = $pos % 8 ;
			  $pos += 7-$p ;
			  substr("        ",$p) ;
		      } ;
		  } split('',$l)) ;
	# For those that wonder what is going on:
	# 1.  Split string to an array (of characters)
	# 2.  For each entry of array, map a function that returns value
	#     for entry or, if value is <TAB>, returns a number of spaces
	#     depending on position in string
	# 3.  Make string (scalar) of array returned from map using join().
    }
    return $l ;
}

###################################################################
### Create a href tag
###

=head2 P4CGI::ahref(I<options>,I<parameters>,I<text>)

Create a <A HREF...>...</A> tag pair.

=over 4

=item I<options>

Optional list of option-value pairs. Valid options are:

=over 4

=item C<-url>

Url for link. Default is current.

=item C<-anchor>

Anchor in url. Default is none.

=back

Any non-valid option marks the end of the options

=item I<parameters>

Optional list of parameters for link.

=item I<text>

The last parameter is used as text for link. 

=back

Example:

    print &P4CGI::ahref("Back to myself") ; # link to this. No parameters.

    print &P4CGI::ahref("-url","www.perforce.com",
			"To perforce") ; # link to perforce

    print &P4CGI::ahref("-anchor","THERE",
			"Go there") ; # link to anchor THERE

    print &P4CGI::ahref("-url","chb.cgi",
			"FSPC=//.../doc/...",
			"Changes for all documentation") ; # url with parameter

=cut ;
sub ahref
{    
    my $url = $ENV{SCRIPT_NAME} ;
    my $anchor = "" ;
    my $pars   = "" ;
    my $params = "" ;
    while($_[0] =~ /^-/) {
	$_[0] =~ /^-url$/i and do {
	    shift @_ ;
	    $url = shift @_ ;
	    next ;
	} ;
	$_[0] =~ /^-anchor$/i and do {
	    shift @_ ;
	    $anchor = "#" . shift @_ ;
	    next ;
	} ;
	$_[0] =~ /^-(.*)/ and do {
	    my $p = $1 ;
	    shift @_ ;
	    my $v = shift @_ ;
	    $params .= " $p=$v" ;
	    next ;
	} ;
	last ;
    }
    while(@_ > 1) {
	if(length($pars) > 0) {
	    $pars .= "&" ;
	}
	else {
	    $pars = "?" ;
	} ;
	$pars .= shift @_ ;
    } ;
    my $txt = shift @_ ;
    $pars =~ s/ /\+/g ;
    return "<a href=\"${url}${anchor}${pars}\"$params>$txt</a>" ;
}

###################################################################
### Set magic buttons
###

=head2 P4CGI::magic(I<text>)

Substitutes magic phrases in I<text> with links.

Currently the pattern "change I<number>" is replaced with a link to the
change browser.

=back

Example:

    my $t = "This change is the same as change 4711, but with a twist" ;

    print &P4CGI::magic($t) ; # inserts a link to change 4711

=cut ;
sub magic($)
{    
    my $t = shift @_ ;
    my $url = &CHV_URL() ;
    $t =~ s/(change[\s\n]+\#*)(\d+)/<A HREF=\"$url?CH=$2\">$1$2<\/A>/ig ; #"    
    $t =~ s/(change no\.*[\s\n]+\#*)(\d+)/<A HREF=\"$url?CH=$2\">$1$2<\/A>/ig ; #"    
    return $t ;
}

###################################################################
### Fixspaces
###

=head2 P4CGI::fixspaces(I<text>)

Return parameter with spaces substituted with %20

=back

Example:

    my $t = "/File with spaces" ;

    print &P4CGI::fixspaces($t) ; # prints: /File%20with%20spaces

=cut ;
sub fixspaces($)
{    
    my $t = shift @_ ;
    $t =~ s/ /%20/g ;
    $t =~ s/\+/%2b/g ;
    $t =~ s/-/%2d/g ;
    $t =~ s/_/%5f/g ;
    $t =~ s/~/%7e/g ;
    return $t ;
}

###################################################################
### BEGIN
###
sub BEGIN ()
{
    init() ;
} ;

1;