#!/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;
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#2 | 5416 | michael |
Provide pointers to P4DB in //guest branch and remove from //public. Provide link to security notice in Bugtraq. |
||
#1 | 1885 | rmg |
For posterity: Make the old version appear in a "P4DB_0" subdirectory. (I'd have called it 0.99, but I'm not sure it really *is* 0.99!) |
||
//guest/perforce_software/utils/p4db/P4CGI.pm | |||||
#2 | 12 | Perforce maintenance |
P4DB now browses all depot root paths, not just "//depot/...". (Note: This breaks the "Browse depot tree" function on the main form -- will fix later.) |
||
#1 | 11 | Perforce maintenance | Add Fredric Fredricson's depot browser, P4DB. |