#!/usr/bin/perl -w
# -*-perl-*-
#################################################################
# This is the "P4CGI" perl module.
#
package P4CGI ;
use CGI ;
use CGI::Carp ;
use strict;
###
### Module variables
###
my $P4 ;
my $CGI ;
local *P4 ;
my $currentChangeLevel ;
my $TMPDIR ;
my $pageEndPrinted ;
my $pageStartPrinted ;
my %administrators ;
sub init ( )
{
#
# 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 temporary directory exists
#
-d $TMPDIR or makedir($TMPDIR) ;
#
# 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::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::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
=head2 Data file update scripts
=over 4
=item P4CGI::DTB_UPDATE()
Update data files for depot tree browser.
=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 FDV_URL() { "fdv.cgi" ; } ;
sub LDV_URL() { "ldv.cgi" ; } ;
sub SFF_URL() { "sff.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" ; } ;
sub DTB_UPDATE() { "./dtb_update.pl" ; } ;
=head2 Constants for Depot Tree Browser
=over 4
=item P4CGI::DTB_LOCKFILE()
Lock file name
=item P4CGI::DTB_FILESPLIT()
Number of data files to split data to.
=item P4CGI::DTB_DATAFILE()
Data file base name
=back
=cut ;
sub DTB_FILEDIR() { $TMPDIR . "/db" ; } ;
sub DTB_LOCKFILE() { DTB_FILEDIR() . "/lockfile" ; } ;
sub DTB_FILESPLIT() { 16 ; } ;
sub DTB_DATAFILE() { DTB_FILEDIR() . "/data." ; } ;
=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 $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 => "#cccccc",
-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><br><small>Current change level:</small><br>$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");
}
print
"<br><hr color=red><p align=center><font color=red size=+2>Error: $message</font><hr>" ;
if(defined $text) { print "$text\n" ; } ;
print
"<p>Script parameters:<br>",
$CGI->dump() ;
print "",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
{
my @ret ;
my $n = 0 ;
my $option = shift @_ or croak ("Parameters required!") ;
my %options ;
while(defined $option and ($option =~ s/^-//)) {
$options{lc($option)} = shift @_ or croak ("Parameters required!") ;
$option = shift @_ or croak ("Parameters required!") ;
}
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"} or
carp "Missing text argument" ;
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) ;
}
###################################################################
### valid_lockfile
###
=head2 P4CGI::valid_lockfile(I<file>)
Check if I<file> is a valid lock file. Return true if I<file> is a valid lock file.
=over 4
=item I<file>
Name of lock file
=back
Example:
if(P4CGI::valid_lockfile("/tmp/lockfile")) {
print "Locked\n" ;
}
=cut ;
sub valid_lockfile($ ) {
return (-r $_[0]) && kill(0,`cat $_[0]`) ;
} ;
###################################################################
### create_lockfile
###
=head2 P4CGI::create_lockfile(I<file>)
Create a valid lock file for this process. Returns true if success.
=over 4
=item I<file>
Name of lock file
=back
Example:
P4CGI::create_lockfile("/tmp/lockfile") or die "can't create lockfile!" ;
=cut ;
sub create_lockfile($ ) {
if(valid_lockfile($_[0])) {
return 0 ;
}
system("echo $$ >$_[0]") ;
return valid_lockfile($_[0]) ;
} ;
###################################################################
### 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/&/&/g ; # & -> &
$d =~ s/\"/"/g;# " -> "
$d =~ s/</</g ; # < -> <
$d =~ s/>/>/g ; # > -> >
return $d ;
}
###################################################################
### 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 = "" ;
while($_[0] =~ /^-/) {
$_[0] =~ /^-url$/i and do {
shift @_ ;
$url = shift @_ ;
next ;
} ;
$_[0] =~ /^-anchor$/i and do {
shift @_ ;
$anchor = "#" . shift @_ ;
next ;
} ;
last ;
}
while(@_ > 1) {
if(length($pars) > 0) {
$pars .= "&" ;
}
else {
$pars = "?" ;
} ;
$pars .= shift @_ ;
}
return "<a href=\"${url}${anchor}${pars}\">$_[0]</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 ;
}
###################################################################
### Make a directory
###
sub makedir($ ) {
my $dir= shift @_ or confess("missing parameter") ;
my $parentDir;
($parentDir="/$dir") =~ s/\/[^\/]+$//;
if ($parentDir ne "") {
$parentDir =~ s/^\///;
-d $parentDir || do { makedir($parentDir) };
}
mkdir $dir,0777 || die "Can not mkdir $dir\n";
chmod 0777,$dir ;
}
###################################################################
### BEGIN
###
sub BEGIN ()
{
init() ;
} ;
1;