#!/usr/bin/perl -w
# -*-perl-*-
##################################################################
# "P4CGI" perl module.
#
# This package is documented using perlpod.
#
package P4CGI ;
###
# You might need to uncomment and modify this to set the lib
# to point to the perl libraries.
#
#use lib '/usr/local/lib/perl5/site_perl' ;
###
# Specify configuration file path
#
sub ConfigFileName()
{
return "./P4DB.conf" ; # Change here to move or rename configuration file
}
use CGI ;
use CGI::Carp ;
use strict;
# A feeble attempt to fence off the most blatant DOS attacks.
$CGI::POST_MAX=1024 * 100; # max 100K posts
$CGI::DISABLE_UPLOADS = 1; # no uploads
#### Conficuration file name
my $CONFIG_FILE ;
#### Store error information
my @ERRLOG ; ## Error log
my $ERRORS ; ## Error counter
#### The following variables are set or updated by the init() routine.
my $CGI; # Contains CGI object from CGI.pm
# Constants
my $VERSION ; # P4DB version
my $CHANGELEVEL ; # P4 change level for relesed version
my $BETA_RELEASE ; # Set to NO if we are running a version that does not contain
# known problems
my $REQUIRED_SERVER_VERSION_YEAR ; # Required server version year
my $REQUIRED_SERVER_VERSION_NUMBER ; # Required server version number
my $STYLE_SHEET ; # Style sheet file name
my $HELPFILE_PATH; # Path to help file (html) ### OBSOLETE???
#
my $P4_PORT_NO ; # Depot number (as defined by preferences list)
my @P4_PORTS ; # Ports from config file
my $P4_USER ; # Current P4 user
my $P4_TICKET ; # Current ticket
my $P4_TICKET_EXPIRES ; # Current ticket expires
my $LOGINMESSAGE ; # A login/out message
# Information read from p4 depot:
my $LASTCHANGE ; # Current change level
my $SERVER_VERSION_YEAR ; # Server year
my $SERVER_VERSION_NO ; # Server count
my $SERVER_VERSION_QUAL ; # Server version qualifier
my $SERVER_VERSION_CHANGE ; # Server change No.
my $NO_CONTACT_ERROR ; # Defined if no contact with depot or other depot-related problem
# Information from configuration file.a
my %CONF ; # Hash containing configuration
my $P4 ; # Contains p4 command
my $PORT; # Contains p4 port
my $P4_HOSTNAME; # Contains p4 host name
my $UNUSEDCLIWL ; # Unused client warning level (from configuration file)
my $UNUSEDUSRWL ; # Unused user warning level (from configuration file)
my $SELECT_USER_FROM_LIST ; # Set to 1 if login page let operator select user from a pulldown
my $SHORTCUT_ICON ; # File containing short icon
my $CGI_TIMEOUT ; # CGI script timout
my $REDIRECT_ERROR_TO_NULL_DEVICE; # Command that redirects errors to /dev/null
my $REDIRECT_ERROR_TO_STDOUT; # Command that redirects errors to stdout
my @P4DBadmin ; # Admins for P4DB and Perforce server
# Information store in cookies (user preferences etc).
my %SHORTCUTS ; # Shortcuts (from cookie)
my %PREF ; # Current user preferences
my %PREF_LIST ; # List of available preferences
my $IGNORE_CASE; # "YES" if case should be ignored
my $MAX_CHANGES; # Max changes for change list
my $TAB_SIZE; # Tab size for file viewer
my $DEBUG ; # Debug mode, When true, prints log (from preferences)
# Misc info.
my $LEGEND ; # Legend supplied to header (from CGi script)
#### Other package variables
my $pageStartPrinted ; # Mark that html header is printed
# Used to avoid mutliple headers if an error occurres
my %EXTRAHEADER ;
my $ONLOADSCRIPT ;
my $helpTarget ; # target for help text
my $printHeaderButtons ;
#### Convenience variables
my $DEFAULT_SPAN_CLASS ; # Default class for spanClass() method.
###
### Subroutine that prints the error log
###
sub prerrlog() {
my $res = "" ;
if(@ERRLOG> 0) {
map {
if(/^ERROR:/) {
$_ = spanClass(&htmlEncode($_),"LogError") ;
}
else {
if(/^p4call/) {
$_ = spanClass(&htmlEncode($_),"LogP4Call") ;
}
else { $_ = spanClass(&htmlEncode($_),"Log") ; } ;
} ;
} @ERRLOG ;
$res .=
"
" .
"URL: " . $CGI->self_url() . "
\n" .
spanClass("Log printout:","LogHeader") .
"
" .
join("\n",@ERRLOG) .
"\n" ;
} ;
return $res ;
}
sub login_form() ; ## Prototype
###
### Initialization code, called from BEGIN().
###
sub init( )
{
$printHeaderButtons="Y" ;
# We require server from 2004.2 or newer
#
$REQUIRED_SERVER_VERSION_YEAR = 2004 ;
$REQUIRED_SERVER_VERSION_NUMBER = 2 ;
# Set config file name
#
$CONFIG_FILE = &ConfigFileName() ;
# death handler
#
$SIG{'__DIE__'} = sub { # Thank you Ron Shalhoup for the tip
my $error = shift;
&P4CGI::bail("Signal caught: $error\n") ;
exit 0;
};
# set up a timeout
#
$SIG{'ALRM'} = sub {
&P4CGI::bail("Command timeout\nInform your P4DB administrator\n") ;
exit 0;
} ;
alarm(30) ; # preliminary, will be reset after the config file have been loaded
push @ERRLOG,"Timeout initially set to 30 seconds" ;
# clear error counter
#
$ERRORS = 0 ;
# Set P4DB version
#
$VERSION="4.0" ;
$CHANGELEVEL=4964 ;
$BETA_RELEASE="NO" ;
# Set some configuration defaults
#
$HELPFILE_PATH = "./" ;
$UNUSEDCLIWL = 10 ;
$UNUSEDUSRWL = 10 ;
$SELECT_USER_FROM_LIST = 0 ;
# Initiate CGI module
#
$CGI = new CGI ;
$CGI->autoEscape(undef) ;
# Get depot number
#
$P4_PORT_NO = 0 ;
$P4_PORT_NO = $CGI->param("DP") if defined $CGI->param("DP") ;
$P4_PORT_NO = 0 unless $P4_PORT_NO =~ /^\d+$/ ;
# Setup list of preferences
#
%PREF_LIST =
(
"IC" => ["d:BOOL","Ignore case", 0],
"MX" => ["d:INT" ,"Max changes to show", 100],
"TB" => ["d:INT" ,"Default tab stop", 8],
"HD" => ["e:BOOL","Hide deleted files ", 0],
"VC" => ["f:BOOL","View files with colors", 1],
"ST" => ["f:LIST","Style Sheet File", 0],
"PH" => ["f:LIST","Header style", 0,"Pulldown Menues","Buttons"],
# Comment out line below to disable log printouts completely.
"DBG" => ["z:BOOL","Print debug information", 0],
) ;
# Read user preferences
#
%PREF=$CGI->cookie(-name=>"P4DB40_PREFERENCES") ; # First try cookie...
my $p ;
foreach $p (keys %PREF_LIST) { # Fill in defaults for those missing in cookie
if(! defined $PREF{$p}) {
$PREF{$p} = $ {$PREF_LIST{$p}}[2];
ERRLOG("Set default for $p!") ;
}
} ;
foreach $p (keys %PREF) { # Check that all specified prefereces really exists...
if(exists $PREF_LIST{$p}) {
ERRLOG("PREF: $p => $PREF{$p} (${$PREF_LIST{$p}}[1])") ;
}
else {
delete $PREF{$p} ;
} ;
} ;
# If new preferences are specified, parse and modify
if(defined $CGI->param("SET_PREFERENCES")) {
my $c ;
foreach $c (keys %PREF) {
my $val = $CGI->param($c) ;
if(defined $val) {
$CGI->delete($c) ;
my $type = $ {$PREF_LIST{$c}}[0] ;
if($type eq "INT") { $val =~ /^\d+$/ or next ; } ;
if($type eq "BOOL") { $val =~ /^[01]$/ or next ; } ;
$PREF{$c} = $val ;
}
}
}
# Set up data structure for configuration file
#
my %configReaderData = ( "P4PATH" => \$P4,
"HTML_HELPFILE_PATH" => \$HELPFILE_PATH,
"P4DB_ADMIN" => \@P4DBadmin,
"SHELL" => \$ENV{"SHELL"},
"REDIRECT_ERROR_TO_NULL_DEVICE" => \$REDIRECT_ERROR_TO_NULL_DEVICE,
"REDIRECT_ERROR_TO_STDOUT" => \$REDIRECT_ERROR_TO_STDOUT,
"PORT" => \@P4_PORTS,
"STYLES" => $PREF_LIST{"ST"},
"UNUSED_CLIENT_WARNING_LEVEL" => \$UNUSEDCLIWL,
"UNUSED_USER_WARNING_LEVEL" => \$UNUSEDUSRWL,
"SELECT_USER_FROM_LIST" => \$SELECT_USER_FROM_LIST,
"SHORTCUT_ICON" => \$SHORTCUT_ICON,
"CGI_TIMEOUT" => \$CGI_TIMEOUT
) ;
# Read configuration file
#
local *F ;
my $line = 0 ;
open(F,"<$CONFIG_FILE") or &P4CGI::bail("Could not open config file \"$CONFIG_FILE\" for read") ;
while() {
$line++ ;
chomp ; # Remove newline
s/^\s+// ; # Remove leading spaces
next if (/^\#/ or /^\s*$/) ; # Skip if comment or empty line
s/\s+/ /g ; # Normalize all spaces to a single space
s/ $// ; # Remove trailing spaces
# Check syntax and get data
/^(\S+):\s*(.*)/ or
&P4CGI::bail("Parse error in config file \"$CONFIG_FILE\" line $line:\n\"$_\"") ;
# Get values
my ($res,$val) = ($1,$2);
# Make sure configuration exist
if(! exists $configReaderData{$res}) {
&P4CGI::bail("Parse error in config file \"$CONFIG_FILE\" line $line:\n\"$_\"") ;
} ;
# Get config value and check type
my $ref = $configReaderData{$res} ;
my $type = ref($ref) ;
$type eq "SCALAR" and do { $$ref = $val ; next ; } ;
$type eq "ARRAY" and do {
if($res =~ /^\@/) {
push @$ref,split /\s+/,$val ;
}
else {
push @$ref,$val ;
} ;
# Security note: any user can se p4 user and password in log. Uncomment for debug only.
# ERRLOG("push $res,$val") ;
next ;
} ;
&P4CGI::bail("Illegal config type $type line $line:\n\"$_\"") ;
}
close F ;
push @ERRLOG,join("\nPorts: ","",@P4_PORTS) ;
if(defined $CGI_TIMEOUT) {
alarm($CGI_TIMEOUT) ;
push @ERRLOG,"Timeout reset to $CGI_TIMEOUT seconds" ;
} ;
# Set variables from config
$IGNORE_CASE = $PREF{"IC"} ? "Yes" : "No" ;
$TAB_SIZE = $PREF{"TB"} ;
$TAB_SIZE = 16 if $TAB_SIZE > 16 ;
$TAB_SIZE = 0 if $TAB_SIZE <= 0 ;
$MAX_CHANGES = $PREF{"MX"} ;
my @t =split(/ /,$ {$PREF_LIST{"ST"}}[3+$PREF{"ST"}]) ;
$STYLE_SHEET = $t[0] ;
push @ERRLOG,"Style sheet file: $STYLE_SHEET" ;
foreach (keys %ENV) {
push @ERRLOG,"Environment variable $_: \"". $ENV{$_} . "\"" ;
} ;
# Set port
#
$PORT = $P4_PORTS[$P4_PORT_NO] ;
if(!defined $PORT) {
$P4_PORT_NO = 0 ;
$PORT = $P4_PORTS[$P4_PORT_NO] ;
}
bail("PORT NOT DEFINED") unless defined $PORT ;
$P4_HOSTNAME=$PORT ;
$P4_HOSTNAME =~ s/:.*$//;
$PORT =~ /(\S+)\s*;/ or do { bail("DEPOT line not correct ($PORT)") ; } ;
$PORT= $1 ;
# Handle shortcuts
#
%SHORTCUTS=$CGI->cookie(-name=>"P4DB40F_${P4_HOSTNAME}_$P4_PORT_NO") ; # read shortcuts cookie
# Check if login
$LOGINMESSAGE="" ;
if(defined $CGI->param("LOGIN_USER")) {
$P4_USER=$CGI->param("LOGIN_USER") ;
my $passwd=$CGI->param("LOGIN_PASSWD") ;
$CGI->delete("LOGIN_PASSWD") ;
local *T ;
open(T," echo $passwd | $P4 -p $PORT -u $P4_USER -P $passwd login -p |") or bail("Failed to issue login command") ;
;
$P4_TICKET= ;
chomp $P4_TICKET ;
close T ;
$LOGINMESSAGE="User $P4_USER logged in" ;
$LOGINMESSAGE="Login failed!" unless $P4_TICKET ;
}
else {
# Get ticket
my %userinfo = $CGI->cookie(-name=>"P4DB40_${P4_PORT_NO}_USERINFO") ; # First try cookie...
$P4_USER=$userinfo{"USR"} ;
$P4_TICKET=$userinfo{"TICKET"} ;
$P4_USER = "" unless defined $P4_USER ;
$P4_TICKET = "" unless defined $P4_TICKET ;
if( defined $CGI->param("logout") ) {
$P4_TICKET="" ;
$LOGINMESSAGE="User $P4_USER logged out" ;
}
} ;
if(!defined $P4_USER) {
login_form() ;
}
$P4_TICKET ="" unless $P4_TICKET ;
$P4 .= " -p $PORT -u \"$P4_USER\" -P \"$P4_TICKET\" " ;
my $stat="FAIL";
p4call(\$stat,"login -s") ;
$stat="FAIL" unless $stat and $stat =~ /ticket expires/ ;
if($stat ne "FAIL") {
$stat =~ /ticket expires (.*)/ and do { $P4_TICKET_EXPIRES = $1 ; } ;
}
login_form() unless $stat ne "FAIL" ;
# Check that we have contact with p4 server
#
$LASTCHANGE= undef ;
my $d ;
p4call(\$d,"changes -m 1") ;
$d =~ /Change (\d+)/ and do { $LASTCHANGE=$1 ;} ;
# Get server version
#
$SERVER_VERSION_YEAR = 0 ;
$SERVER_VERSION_NO = 0 ;
$SERVER_VERSION_CHANGE = 0 ;
my @tmp ;
p4call(\@tmp,"info") ;
foreach $d (@tmp) {
$d =~ /^Server version: (.+?)\/(.+?)\/(\d+)\.(\d+)([^\/]*)\/(\d+)/ and
do { $SERVER_VERSION_YEAR = $3 ;
$SERVER_VERSION_NO = $4 ;
$SERVER_VERSION_QUAL = $5 ;
$SERVER_VERSION_CHANGE = $6 ; }
} ;
if($SERVER_VERSION_YEAR == 0) {
$NO_CONTACT_ERROR = "NO CONTACT WITH SERVER \"$PORT\"" ;
}
else {
if(($SERVER_VERSION_YEAR < $REQUIRED_SERVER_VERSION_YEAR) or
(($SERVER_VERSION_YEAR == $REQUIRED_SERVER_VERSION_YEAR) and
($SERVER_VERSION_NO < $REQUIRED_SERVER_VERSION_NUMBER))) {
$NO_CONTACT_ERROR =
"P4DB REQUIRES VERSION $REQUIRED_SERVER_VERSION_YEAR.$REQUIRED_SERVER_VERSION_NUMBER OR NEWER
" .
"(Current server $SERVER_VERSION_YEAR.$SERVER_VERSION_NO)" ;
} ;
} ;
# Handle shortcuts
#
%SHORTCUTS=$CGI->cookie(-name=>"P4DB40F_${P4_HOSTNAME}_$P4_PORT_NO") ; # read shortcuts cookie
my $addShortCut=htmlEncode($CGI->param(-name=>"ADDSHORTCUT")) ; # Add shortcut if specified
if(defined $addShortCut) {
my ($target,$name) = split(":::",$addShortCut) ;
$name =~ s/\s+$// ;
my $urlpath=&P4CGI::cgi()->url() ;
$urlpath =~ s|[^/]+$|| ;
$target =~ s/^$urlpath// ;
$SHORTCUTS{$name} = $target if $name ne "" ;
$CGI->delete("ADDSHORTCUT") ;
} ;
my $rmShortCut=htmlEncode($CGI->param(-name=>"RMSHORTCUT")) ; # Delete shortcut if specified
if(defined $rmShortCut) {
my ($target,$name) = split(":::",$rmShortCut) ;
if($SHORTCUTS{"$name"} eq $target) {
delete $SHORTCUTS{"$name"} ;
}
$CGI->delete("RMSHORTCUT") ;
};
my $clearShortCuts=$CGI->param(-name=>"CLRSHORTCUTS") ; # Clear all shortcuts if specified
if(defined $clearShortCuts) {
my %empt ;
%SHORTCUTS = %empt ;
$CGI->delete("CLRSHORTCUTS") ;
};
} ;
#################################################################
### Documentation start
=head1 About
P4CGI - Support for CGIs that interface p4. Written specifically for P4DB
=cut
;
################################################################
## Short access functions used to get preferences and such ##
## in CGIs. ##
################################################################
=head1 General functions
General functions.
=cut
;
sub CURRENT_CHANGE_LEVEL() { return $LASTCHANGE ? $LASTCHANGE : -1 ; } ;
sub USER_P4PORT() { return $PORT ; } ;
sub HELPFILE_PATH() { return $HELPFILE_PATH ; } ;
sub REDIRECT_ERROR_TO_NULL_DEVICE() { return $REDIRECT_ERROR_TO_NULL_DEVICE ; } ;
sub REDIRECT_ERROR_TO_STDOUT() { return $REDIRECT_ERROR_TO_STDOUT ; } ;
sub VIEW_WITH_COLORS() { return $PREF{"VC"} ; } ;
sub HEADER_STYLE() { return $PREF{"PH"} ; } ; # 1=pulldown, 2=text links
sub SHOW_FULL_DESC() { return $PREF{"FD"} ; } ;
sub HIDE_DELETED() { return $PREF{"HD"} ; } ;
sub CURR_DEPOT_NO() { return $P4_PORT_NO ; } ;
sub DEPOT_NAME($) { my $s = $P4_PORTS[shift] ;
$s =~ s/^.*;\s+// ;
return $s ;} ;
sub NO_OF_DEPOTS() { return scalar(@P4_PORTS) ; } ;
sub CHANGES_IN_SEPARATE_WIN() { return $PREF{"NW"} ; } ;
sub MAX_CHANGES() { return $MAX_CHANGES ; } ;
sub ERRLOG { push @ERRLOG,@_ ; };
sub ERROR { &ERRLOG(map { "ERROR: $_" } @_) ; $ERRORS++ ; };
sub EXTRAHEADER(% ) { %EXTRAHEADER = @_ ; } ;
sub ONLOADSCRIPT($ ) { $ONLOADSCRIPT= shift ; } ;
sub SKIPHEADERBUTTONS() { $printHeaderButtons = undef ; } ;
sub SET_HELP_TARGET($ ) { $helpTarget = shift ; } ;
sub P4_USER() { return $P4_USER ; } ;
sub IGNORE_CASE() { return $IGNORE_CASE ; } ;
sub UNUSEDCLIWL() { return $UNUSEDCLIWL ; } ;
sub UNUSEDUSRWL() { return $UNUSEDUSRWL ; } ;
sub VERSION() { return $VERSION ; } ;
sub CHANGELEVEL() { return $CHANGELEVEL ; } ;
sub BETA_RELEASE() { return $BETA_RELEASE ; } ;
sub SERVER_VERSION() { return ($SERVER_VERSION_YEAR,
$SERVER_VERSION_NO,
$SERVER_VERSION_QUAL) ; } ;
sub REQUIRED_SERVER_VERSION() { return "$REQUIRED_SERVER_VERSION_YEAR.$REQUIRED_SERVER_VERSION_NUMBER" ; } ;
sub SHORTCUTS() { return %SHORTCUTS ; } ;
sub PREF() { return %PREF ; } ;
sub PREF_LIST() { return %PREF_LIST ; } ;
sub STARTPAGE_MARKER { return "Default start page" ; } ;
## Return true if we are browsed by MS Explorer 5 or 6. (Not a 100% pure way but should work...) ;
sub IS_MSEXPLORER { return $ENV{"HTTP_USER_AGENT"} =~ /compatible; MSIE [56]/ ; }
###################################################################
### cgi
###
=head2 cgi
C<&P4CGI::cgi()>
Return CGI reference
Example:
my $file = P4CGI::cgi()->param("file") ;
print "File parameter value: $file\n" ;
=cut
;
sub cgi() {
confess "CGI not initialized" unless defined $CGI ;
return $CGI ;
}
###################################################################
### Fix some special characters to html entities
###
=head2 htmlEncode
C<&P4CGI::htmlEncode(>BC<)>
Convert all '>' to "C<>>", '<' to "C<<>" and '&' to "C<&>".
=over 4
=item str
String to convert
=back
Example:
my $cvstr = &P4CGI::htmlEncode("String containing <,> and &") ;
=cut
;
sub htmlEncode($ )
{
my $d = shift ;
if(defined $d) {
$d = &rmTabs($d) ;
$d =~ s/&/&/g ; # & -> &
$d =~ s/\"/"/g;# " -> "
$d =~ s/ <
$d =~ s/>/>/g ; # > -> >
} ;
return $d ;
}
###################################################################
### Replace tabs with spaces
###
=head2 rmTabs
C<&P4CGI::rmTabs(>BC<)>
Returns B with all tabs converted to spaces
=over 4
=item I
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/) { # only do this if there really are tabs in the text
my $tabsz=$TAB_SIZE ;
$tabsz = 8 unless $tabsz ;
my $pos = 0 ;
$l = join('',map
{
if($_ ne "\t") {
$pos++ ;
$_ ;
} else
{
my $p = $pos % $tabsz ;
$pos += $tabsz-$p ;
substr(" ",0,$tabsz-$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 , returns a number of spaces
# depending on position in string
# 3. Make string (scalar) of array returned from map using join().
# (Note that the steps appear in the reverse order in the code)
}
return $l ;
}
###################################################################
### Set magic buttons
###
=head2 magic
C<&P4CGI::magic(>BC<)>
Returns B with some magic "patterns" substituted with links.
Currently the pattern "change I" (and some variants) is replaced with a link to the
change browser.
Example:
my $t = "Integrated change 4711 to this codeline" ;
print &P4CGI::magic($t) ; # inserts a link to change 4711
=cut ;
sub magic($;\@)
{
my $t = shift ;
my %found ;
my $res = "" ;
my $hot = 0 ;
my $max = &P4CGI::CURRENT_CHANGE_LEVEL() ;
while($t =~ s/^([\s\n]*)(no\.|\.|ch\.|[a-zA-Z-0-9]+|[^a-zA-Z-0-9]+)//i) {
$res .= $1 ;
my $tok = $2 ;
if($hot == 0) {
$hot = 3 if $tok =~ /^(ch[\.]?|change|integrate|submit)/i ;
}
else {
$hot-- ;
if($tok =~ /^\d+$/ and !($t =~ /\.\d+/)) {
if($tok > 0 and $tok < $max) {
$hot = 3 ;
$found{$tok} = 1 ;
$tok = ahref(-url => "changeView.cgi",
"CH=$tok",
"HELP=View change $tok",
"$tok") ;
}
}
elsif($tok eq ".") {
$hot = 0 ;
}
}
$res .= $tok ;
} ;
$res .= $t ;
my $ar ;
if($ar = shift ) {
@$ar = sort { $a <=> $b } keys %found ;
} ;
return $res ;
}
###################################################################
### UrlEncode
###
=head2 urlEncode
C<&P4CGI::urlEncode(>BC<)>
Returns B with characters like space substituted with "%".
Example:
my $t = "/File with spaces" ;
print &P4CGI::urlEncode($t) ; # prints: /File%20with%20spaces
=cut
;
sub urlEncode($)
{
my $t = shift ;
$t =~ s/%(?![\da-fA-F][\da-fA-F])/%25/g ;
$t =~ s/\?/%3f/g ;
$t =~ s/&/%26/g ;
$t =~ s/ /%20/g ;
$t =~ s/;/%3b/g ;
$t =~ s/\+/%2b/g ;
$t =~ s/-/%2d/g ;
$t =~ s/_/%5f/g ;
$t =~ s/~/%7e/g ;
return $t ;
}
###################################################################
### urlDecode
###
=head2 urlDecode
C<&P4CGI::urlDecode(>BC<)>
Reverse the operation of C. See above.
=cut
;
sub urlDecode($)
{
my $t = shift ;
my $r = "" ;
while($t =~ /(.*?)\%(..)(.*)/) {
my ($start,$code,$end) = ($1,$2,$3) ;
$r .= $start ;
$t = $end ;
if($code eq "25") {
$r .= "%" ;
}
else {
if($code =~ /[\da-fA-F][\da-fA-F]/) {
$r .= chr(hex($code)) ;
}
else {
$r .= "%$code" ;
}
}
}
return $r . $t ;
}
###################################################################
### urlCompare
###
=head2 urlCompare
C<&P4CGI::urlDecode(>B,[,]C<)>
Compare two urls. Return 1 if "equal" and optionally ignore some options.
=cut
;
sub urlCompare($$@) {
my $u1 = shift ;
my $u2 = shift ;
my %ignoredOptions = map { ($_,1) ; } @_ ; # A cheap trick to get convert to a hash...
my $cgi1=$u1 ;
my %opt1 ;
$u1 =~ /^(.*?)\?(.*)/ and do {
$cgi1 = $1 ;
foreach (split(/[\&\;]/,$2)) {
/(.*)=(.*)/ and do { $opt1{$1} = $2 ; } ;
}
} ;
my $cgi2=$u2 ;
my %opt2 ;
$u2 =~ /^(.*?)\?(.*)/ and do {
$cgi2 = $1 ;
foreach (split(/[\&\;]/,$2)) {
/(.*)=(.*)/ and do { $opt2{$1} = $2 ; } ;
}
} ;
return 0 if $cgi1 ne $cgi2 ;
my $o ;
foreach $o ((keys %opt1,keys %opt2)) {
next if defined $ignoredOptions{$o} ;
return 0 unless defined $opt1{$o} and defined $opt2{$o} and ( urlDecode($opt1{$o}) eq urlDecode($opt2{$o}) ) ;
}
return 1 ;
}
################################################################
##
=head1 Functions for p4 access
These fuctions used the "p4" command to access the depot.
=cut
###################################################################
### p4call
###
=head2 p4call
C<&P4CGI::p4call(>BC<,>BC<)>
Request data from p4. Calls p4 with command B and returns data in B.
This function is really three different functions depeding in the type of the
B parameter.
=over 4
=item 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 into array (newlines stripped)
=item Reference to scalar
Returns result from command into scalar. (lines separated by newline)
=back
Any other type of parameter will abort operation
=item 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") ;
$LASTCHANGE=$1 ;
=cut
;
sub p4call {
my ( $par, @command ) = @_;
my $partype = ref $par ;
push @ERRLOG,"p4call(<$partype>,@command)" ;
if(!$partype) {
open( $par, "$P4 @command|" ) || &bail( "$P4 @command failed" );
return ;
} ;
"ARRAY" eq $partype and do {
local *P4 ;
@$par = () ;
open( P4, "$P4 @command|" ) || &bail( "$P4 @command failed" );
while() {
chomp ;
push @$par,$_ ;
} ;
close P4 ;
return ;
} ;
"SCALAR" eq $partype and do {
$$par = "" ;
local *P4 ;
open( P4, "$P4 @command|" ) || &bail( "$P4 @command failed" );
while() {
$$par .= $_ ;
} ;
close P4 ;
return ;
} ;
die("Called with illegal parameter ref: $partype") ;
} ;
###################################################################
### p4readform
###
=head2 p4readform
C<&P4CGI::p4readform(>B,BC<)>
Reads output from a P4 command and assumes the data is a form (e.g. "client -o").
The form is stored in a hash and the function returns an array containing all
field names in the order they appeared. The hash will contain the field names as
key and field values as data.
=over 4
=item command
Command to send to p4 command line client.
=item resulthash
Reference to a hash to receive reults
=back
Example:
my %fields ;
my @fields = &P4CGI::p4readforml("client -o",\%fields) ;
my $f ;
foreach $f (@fields) {
print "field $f: $fields{$f}\n" ;
}
=cut
;
sub p4readform($\% )
{
my $cmd = shift ;
my $href = shift ;
my @result ;
# clear hash
%$href = () ;
local *F ;
p4call(*F,$cmd) ;
my $cline = ;
while($cline) {
chomp $cline ;
$_ = $cline ;
if(/^\#/ or /^\s*$/) { # skip comments and empty line
$cline = ;
next ;
}
if(/^(\S+):\s*(.*)\s*$/) {
my $fld=$1 ;
my $val=$2 ;
push @result,$fld ;
my $ws ;
if($val eq "") {
$val = undef ;
while(defined ($cline = )) {
$_ = $cline ;
chomp ;
last if /^\w/ ;
s/^\s+// ;
if(defined $val) {
$val .= "\n$_" ;
}
else {
$val = "$_" ;
}
}
}
else {
$cline = ;
}
$$href{$fld}=$val ;
}
else {
$cline = ;
}
}
close *F ;
return @result ;
} ;
###################################################################
### p4users
###
=head2 p4users
C<&P4CGI::p4users()>
Reads and parses data from "p4 users" command.
Data is returned in a hash with user Id as key and a reference to a hash containing keys
"FullName","Email","Access".
Example:
my %userdata ;
my %userdata = &P4CGI::p4users() ;
my $user ;
foreach $user (keys %userdata) {
print "user $user email:",$userdata{$user};
}
=cut
;
my %p4users_Memory ;
sub p4users()
{
unless(scalar(keys %p4users_Memory)) {
local *F ;
p4call(*F,"users") ;
while() {
/^(\S+) <(.*)> \((.*)\) accessed (\S+)/ and do {
$p4users_Memory{$1} = { "Email" => $2,
'FullName' => $3,
'Access' => $4 } ;
}
}
close *F ;
}
return %p4users_Memory ;
} ;
###################################################################
### p4user2name
###
=head2 p4users
C<&P4CGI::p4user2name(BC<)>
Creats a hash with user Id as key and full user name as value.
Example:
my %user2name ;
&P4CGI::p4user2name(\%user2name) ;
foreach $user (keys %user2name) {
print "user $user full name::",$user2name{$user};
}
=cut
;
sub p4user2name(\%)
{
my $href = shift ;
my %userData = &p4users() ;
my $userId ;
foreach $userId (keys %userData) {
${$href}{$userId} = ${$userData{$userId}}{"FullName"} ;
} ;
} ;
###################################################################
### p4clients
###
=head2 p4clients
C<&P4CGI::p4clients()>
Reads and parses data from "p4 clients" command.
Data is returned in a hash with client Id as key and a reference to a hash containing keys
"Update","Root" and "Description"
Example:
my %clientdata ;
my %clientdata = &P4CGI::p4clients() ;
my $client ;
foreach $client (keys %clientdata) {
print "client $client root: ${$clientdata{$client}}{Root}\n" ;
}
=cut
;
my %p4clients_Memory;
sub p4clients()
{
unless(scalar(keys %p4clients_Memory)) {
local *F ;
p4call(*F,"clients") ;
while() {
/^Client (\S+) (\S+) root (.*) '(.*)'/ and do {
$p4clients_Memory{$1} = { "Update" => $2,
'Root' => $3,
'Description' => $4 } ;
}
}
close *F ;
}
return %p4clients_Memory ;
} ;
################################################################
################################################################
################ Page header, footer and common ################
################ routines. ################
################################################################
################################################################
###################################################################
### start_page
###
=head2 start_page
C<&P4CGI::start_page(>B[C<,>B<legend>]C<)>
Start a page. Print http header and first part of the html code for a page.
=over 4
=item title
Title of page. If the text contains " -- " it is removed and all text
is used for the page title but only the text before " -- " is printed
in the page header.
=item legend (Optional)
Short help text to be displayed at top of page
=back
Example:
my @buttons ;
push @button,P4CGI::buttonCell("http://www.perforce.com",
"Tooltip help text",
"Go To Perforce") ;
my $start = P4CGI::start_page("Title of page",
@buttons) ;
print $start ;
=cut ;
sub start_page($;@)
{
my @cookiepar ;
# Set up cookies and print header
my @cookieArray ;
push @cookieArray,$CGI->cookie(-name=>"P4DB40_PREFERENCES",
-value=>\%PREF,
-path=>"/",
-expires=>'+6M');
push @cookieArray,$CGI->cookie(-name=>"P4DB40F_${P4_HOSTNAME}_$P4_PORT_NO",
-value=>\%SHORTCUTS,
-path=>"/",
-expires=>'+6M');
push @cookieArray,$CGI->cookie(-name=>"P4DB40_${P4_PORT_NO}_USERINFO",
-value=>["USR"=>$P4_USER,
"TICKET"=>$P4_TICKET],
-path=>"/",
-expires=>'+6M');
push @cookiepar,"-cookie",\@cookieArray ;
my $ret = $CGI->header(@cookiepar,
-Cache_Control => "no-cache",
%EXTRAHEADER). "\n" ;
my $title = shift ;
my @buttons = @_ ;
my $buttons ;
my $helpURL="${HELPFILE_PATH}/P4DB_Help.html" ;
if(defined $helpTarget) {
$helpURL .= "#$helpTarget" ;
} ;
if(@buttons) {
$buttons = buttonHMenuTable(@buttons) ;
}
my $n = 0 ;
$ONLOADSCRIPT = "" unless defined $ONLOADSCRIPT ;
my $t = "$title" ; # Take title and removed all HTML tags
$t =~ s/<br>/ /ig ;
$t =~ s/<[^>]*>//g ;
$t =~ s/ -- / /;
$title =~ s/ -- .*$/ / ;
my %header ;
$header{"-title"} = "P4DB: $t" ;
$header{"-author"} = "fredric\@mydata.se" ;
$header{"-style"} = { -src=>$STYLE_SHEET } ;
$header{"-link"} = { -src=>$STYLE_SHEET } ;
$header{"-class"} = "DataFrame" ;
$header{"-head"} = [CGI::meta({"-http-equiv" => 'Content-Script-Type',
"-content" => 'text/javascript' }),
CGI::Link({-rel=>"SHORTCUT ICON",
-href=>"P4DB.ico"})] ;
$header{"-onload"} = $ONLOADSCRIPT if $ONLOADSCRIPT ;
# $header{"-script"} = { -src=>"P4DB.js" , -language=>"JavaScript" } ;
$ret .= $CGI->start_html(%header) ;
# Main pages menu
#
my $opt ;
my $options = "" ;
my $headerStyle = HEADER_STYLE() ;
foreach $opt (
["intro.cgi", "Intro page", "P4DB Intro page"],
["depotTreeBrowser.cgi","Depot Browser", "Browse Depot Tree"],
["changeList.cgi", "Changes", "View submitted changes for //...",
{ FSPC => "//..."} ],
["searchPattern.cgi", "Find Changes", "Find changes"],
["findFiles.cgi", "Find Files", "Search depot for files"],
["fileOpen.cgi", "Open files", "List open files"],
["branchList.cgi", "Branches", "List branches"],
["labelList.cgi", "Labels", "List labels in depot"],
["jobList.cgi", "Jobs", "View selected jobs"],
["userList.cgi", "Users and Groups", "List Users and Groups"],
["clientList.cgi", "Clients", "List Clients" ],
["depotStats.cgi", "Statistics", "View Depot Statistics"],
["SetPreferences.cgi", "Preferences", "Set user preferences manage user shortcuts"],
["p4race.cgi", "Submit Race", "The Great Submit Race"]) {
my @arr = @$opt ;
my $url = shift @arr ;
my $text = shift @arr ;
my $title = shift @arr ;
my $xparams = "" ;
if(@arr) {
my $hr = shift @arr ;
$xparams = join(";",map { &htmlEncode("$_=${$hr}{$_}") ; } keys %$hr) ;
} ;
if($P4_PORT_NO) {
if($xparams ne "") {
$xparams .= ";DP=$P4_PORT_NO" ;
}
else {
$xparams = "DP=$P4_PORT_NO" ;
}
} ;
my $selected = "" ;
$url .= "?$xparams" if defined $xparams ;
if(urlCompare($CGI->url(-relative=>1,-query=>1),$url,("HIDEDEL","SHOWREFERENCED","HELP","DP"))) {
$selected = "selected" if $headerStyle > 0 or ! urlCompare($url,"intro.cgi",("DP")) ;
} ;
if($headerStyle == 0) {
$options .= "\n <option value=\"$url\" title=\"$title\" $selected>$text</option>" ;
}
else { # $headerStyle == 1
$text =~ s/ / /g ;
if($selected eq "selected") {
$options .= "\n<span class=\"HeaderTableSelected\">$text</span>" ;
}
else {
$options .= "\n<a class=\"HeaderTable\" href=\"$url\" title=\"$title\" $selected>$text</a>" ;
}
}
} ;
my $selectPage ;
my $disabled="" ;
$disabled = "disabled" unless $P4_TICKET ;
if($headerStyle == 0) {
my $script =
"var n = this.selectedIndex ; ".
"if(n > 0) { ; " .
"var o = this.options[n] ; ".
"location = o.value;" .
"}" ;
$selectPage =
join("\n ",
("<select title=\"Select a predefined entry to P4DB\" class=\"HeaderTable\" size=\"1\" name=\"Page\" onChange=\"$script\" $disabled>" ,
"<option> -- Select page -- </option>\n",
$options ,
"</select>\n")) ;
}
else { # $headerStyle == 1
$selectPage = "<span class=\"HeaderTable\">$options\n</span>" ;
}
# User shortcuts
#
my $scscript =
"var n = this.selectedIndex ; ".
"if(n > 0) { ; " .
"var o = this.options[n] ; ".
"location = o.value;" .
"}" ;
my $disableSC="" ;
my %shortcuts = %SHORTCUTS ;
$disableSC = "disabled" unless (keys %shortcuts) ;
my $shortcuts = "" ;
if($headerStyle == 0 ) {
$shortcuts = "<select title=\"Select a personal shortcut\" class=\"HeaderTable\" size=\"1\" onChange=\"$scscript\" $disableSC $disabled>\n" ;
$shortcuts .= "<option>-- Select Shortcurt --</option>\n",
}
my $name ;
foreach $name (sort { uc($a) cmp uc($b) } keys %shortcuts) {
my $target = $SHORTCUTS{$name} ;
my $selected = "" ;
$selected = "selected" if urlCompare($CGI->url(-relative=>1,-query=>1),$target,("HIDEDEL",
"SHOWREFERENCED",
"HELP")) ;
my $title = "Shortcut: $name" ;
if($headerStyle == 0) {
$shortcuts .=
"\n <option value=\"$target\" title=\"$title\" $selected>$name</option>" ;
}
else { # $headerStyle == 1
$shortcuts .= " <span class=\"HeaderTableSeparator\">|</span>" if $shortcuts ne "" ;
$shortcuts .= "<span class=\"HeaderTable\">Shortcuts:<br>\n" if $shortcuts eq "" ;
$name =~ s/ / /g ;
if($selected eq "selected") {
$shortcuts .= "\n <span class=\"HeaderTableSelected\">$name</span>" ;
}
else {
$shortcuts .= "\n <a class=\"HeaderTable\" href=\"$target\" title=\"$title\" $selected>$name</a>" ;
}
}
}
if($headerStyle == 0) {
$shortcuts .= "</select>\n" ;
}
else { # $headerStyle == 1
$shortcuts .= "</span>\n" ;
}
my $urlSelf = urlEncode($CGI->self_url) ;
my $disableButtons = "" ;
$disableButtons="disabled" unless $printHeaderButtons and $P4_TICKET;
my $buttonClass="HeaderTable" ;
$buttonClass="HeaderTableDisabled" unless $printHeaderButtons ;
my $addshortcutScript =
"location = 'addshortcut.cgi?DP=$P4_PORT_NO;SC=" . $urlSelf . "' ;" ;
my $addshortcut =
"<button class=\"$buttonClass\" type=\"button\" name=\"addsc\" value=\"addsc\" ".
"title=\"Add current page to list of shortcuts\" ".
"onclick=\"$addshortcutScript\" $disableButtons> Add Shortcut </button>\n" ;
my $addstartLocation=
join("",("addshortcut.cgi?DP=$P4_PORT_NO;ADDSHORTCUT=${urlSelf}:::" ,
urlEncode(&STARTPAGE_MARKER()),
"&GOTO=$urlSelf")) ;
my $makeStartPage =
"<button class=\"$buttonClass\" type=\"button\" name=\"makestart\" value=\"makestart\" ".
"title=\"Make current page your start page\" ".
"onclick=\"location='$addstartLocation' ;\" $disableButtons> Make startpage </button>\n" ;
my $logout =
"<button class=\"$buttonClass\" type=\"button\" name=\"logout\" value=\"logout\" ".
"title=\"Log out\" ".
"onclick=\"location='index.cgi?logout=Y;DP=$P4_PORT_NO' ;\" $disableButtons> Log out </button>\n" ;
if($headerStyle == 0) {
$ret .= join("\n",("<table class=\"HeaderTable\">",
" <tr>",
" <td class=\"HeaderTable_AppName\">",
" <a class=\"HeaderTable_AppName\" href=\"index.cgi?DP=$P4_PORT_NO\" title=\"Go to start page\">",
" P4DB",
" </a>",
" </td>",
" <td class=\"HeaderTable\">",
$selectPage,
" </td>",
" <td class=\"HeaderTable\">",
$shortcuts,
" </td>",
" <td class=\"HeaderTable\">",
$addshortcut,
" </td>",
" <td class=\"HeaderTable\">",
$makeStartPage,
" </td>",
" </tr>",
"</table>")) ;
}
else { # $headerStyle == 1
$ret .= join("\n",("<table class=\"HeaderTable\">",
" <tr>",
" <td class=\"HeaderTable_AppName\">",
" <a class=\"HeaderTable_AppName\" href=\"index.cgi?DP=$P4_PORT_NO\" title=\"Go to start page\">",
" P4DB",
" </a>",
" </td>",
" <td class=\"HeaderTableTextSelect\">",
$selectPage,
" </td>",
" <td class=\"HeaderTableTextSelect\">",
$shortcuts,
" </td>",
" <td class=\"HeaderTable\">",
$addshortcut,
$makeStartPage,
" </td>",
" </tr>",
"</table>")) ;
}
$ret .= "<table class=\"HeaderBuffer\"><tr><td> $LOGINMESSAGE</td></tr></table>\n" ;
if(defined $NO_CONTACT_ERROR) {
$ret .= "<p class=\"Error\">ERROR: $NO_CONTACT_ERROR</p>" ;
}
my $headerTable = "<div class=\"PageTitleTable\">" . start_table("class=\"PageTitleTable\"") ;
my $prHeaderTable = 1 ; # Always print it (disable logic to determine if header should be printed
# if($title ne "") {
$headerTable .= table_row({-class => "PageTitle",
-text => "$title"},
{-class => "PageTitleLogout",
-text => $logout}) ;
$prHeaderTable++ ;
# }
$headerTable .= end_table() . "</div>" ;
if(defined $buttons) {
$headerTable .= $buttons ;
$prHeaderTable++ ;
} ;
if($prHeaderTable) { $ret .= $headerTable ; } ;
$pageStartPrinted = 1 ;
return $ret . "\n" ;
} ;
###################################################################
### end_page
###
=head2 end_page
C<&P4CGI::end_page()>
End a page. Print HTML trailer.
Example:
print P4CGI::end_page() ;
=cut ;
sub end_page()
{
$DEFAULT_SPAN_CLASS = "" ;
my $depot = spanClass(DEPOT_NAME(CURR_DEPOT_NO())) ;
my $lastch = spanClass(CURRENT_CHANGE_LEVEL()) ;
my $server_port = spanClass(USER_P4PORT()) ;
my ($server_year, $server_No, $server_qual) = SERVER_VERSION() ;
unless(defined $server_year and $server_year > 0) {
$server_port= "" ;
($server_year, $server_No, $server_qual) = ("-","-","") ;
} ;
my $server_version = spanClass("$server_year.$server_No$server_qual") ;
$DEFAULT_SPAN_CLASS = "" ;
my $version = &P4CGI::VERSION() ;
my $changelevel = &P4CGI::CHANGELEVEL() ;
my $p4dbver = "$version/$changelevel" ;
my @p4adm = map { my ($em,@nm) = split(/\s+/,$_) ; "<a href=\"mailto:$em\">" . join(" ",@nm) ."</a>" } @P4DBadmin;
my $adminPluralS = @p4adm > 1 ? "s": "" ;
my $showuser ;
$showuser = "Y" if defined $P4_TICKET_EXPIRES ;
my $info= join("\n",
"<br>",
"<div class=\"ServerInfo\">",
(start_table(" class=\"ServerInfo\""),
table_row(
{-type=>"th",
-text=>spanClass("P4DB ver:")},
$p4dbver,
{-type=>"th",
-text=>spanClass("Depot:")},
$depot,
{-type=>"th",
-text=>spanClass("Changes:")},
$lastch,
{-type=>"th",
-text=>spanClass("Port:")},
$server_port,
{-type=>"th",
-text=>spanClass("Server version:")},
$server_version),
table_row(
{-type=>"th",
-text=>$showuser ? spanClass("Current user:") : "" },
undef,
undef,
undef,
undef,
$showuser ? "$P4_USER<br>Ticket expires $P4_TICKET_EXPIRES" : "" ,
{-type=>"th",
-text=>spanClass("Administrator$adminPluralS:")},
undef,
undef,
join("<br>",@p4adm)),
end_table(),
"</div>",
"<br>")) ;
my $err = "" ;
if($PREF{"DBG"}) {
$err = &prerrlog() ;
} ;
return $info . $err . $CGI->end_html() ;
} ;
###################################################################
### bail
###
=head2 bail
C<&P4CGI::bail(>B<message>C<)>
Report an error. This routine will emit HTML code for an error message, print the error log and exit.
This rouine is intended to report internal errors in the code (much like assert(3) in c).
=over 4
=item message
Message that will be displayed to user
=back
Example:
unless(defined $must_be_defined) {
&P4CGI::bail("was not defined") ;
} ;
=cut ;
my $bailed ;
sub bail(@) {
unless(defined $bailed) {
$bailed = 1 ;
my $message = shift ;
my $text = shift ;
unless(defined $pageStartPrinted) {
print
"",
$CGI->header(),
$CGI->start_html(-title => "Error in script",
-bgcolor => "white",
-style => { -src=>$STYLE_SHEET }) ;
$pageStartPrinted = 1 ;
} ;
$message = &htmlEncode($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 = &htmlEncode($text) ;
print "<pre>$text</pre><br>\n" ;
} ;
print
"<p>Parameters to script:<br>",
$CGI->Dump() ;
print "</font>\n",prerrlog(), end_page() ;
die($message) ;
}
} ;
###################################################################
### signalError
###
=head2 signalError
C<&P4CGI::signalError(>B<message>C<)>
Report an operator error in a reasonable fashion.
SignalError can be called before or after start_page() but if it is called
before start_page() a "default" page header will appear. It is recommended
to call signalError() after start_page() to make it more obvious to the
operator what the problem was.
=over 4
=item message
Message that will be displayed to user
=back
Example:
unless(defined $must_be_defined) {
&P4CGI::signalError("was not defined") ;
} ;
=cut ;
sub signalError {
my $message = shift ;
my $text = shift ;
unless(defined $pageStartPrinted) {
print "",start_page("Error","") ;
$pageStartPrinted = 1 ;
} ;
$message = &htmlEncode($message) ;
print
"<p align=center><font color=red size=+2>$message</font><br><br>" ;
if(defined $text) {
$text = &htmlEncode($text) ;
print "<pre>$text</pre><br>\n" ;
} ;
print "", end_page() ;
exit 0 ;
} ;
###################################################################
### help_link
###
sub help_link($ ) {
my $helpURL="$HELPFILE_PATH/B_Help.html#" . shift ; ;
return ahref(-url=>$helpURL,
"<font size=+2 style=fixed><B>?</B></font>") ;
}
###################################################################
### start_table
###
=head2 start_table
C<&P4CGI::start_table(>B<table_attribute_text>C<)>
Start a table with optional table attributes
=over 4
=item 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 " ;
if($attribs) {
$ret .= " $attribs" ;
}
return $ret . ">\n";
}
###################################################################
### end_table
###
=head2 end_table
C<&P4CGI::end_table()>
Return end of table string. (trivial function included mostly for symmetry)
=cut ;
sub end_table()
{
return "</table>\n" ;
}
###################################################################
### table_row
###
=head2 table_row
C<&P4CGI::table_row(>B<options>C<,>B<listOfValues>C<)>
Insert a row in table.
=over 4
=item 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 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 hash 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) ;
}
###################################################################
### table_header
###
=head2 table_header
C<&P4CGI::table_header(>B<list of label/hint>C<)>
Create a table header row with a a description and an optional hint for each column.
=over 4
=item list of label/hint
A list of column labels optionally followed by a '/' and a hint.
=back
Example:
print P4CGI::start_table("align=center") ;
### print header row
print P4CGI::table_header("File/click for story","Revision/click to view") ;
### 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_header
{
my @cols ;
my @tmp = @_ ;
my $tmp ;
my $n ;
while(@tmp > 0) {
$tmp = shift @tmp ;
if(defined $tmp) {
my $label = $tmp ;
push @cols,{ -text => $label,
-class => "ListHeader" } ;
}
else {
push @cols,$tmp ;
}
}
return table_row(-class => "ListHeader", @cols) ;
} ;
################################################################
### Make a framed table with a title
###
sub start_framedTable($;$ )
{
my $title = shift ;
my $class ;
$class = shift or do { $class="Frame" ; } ;
my $res = "" ;
$res .= "<span class=\"${class}Title\">$title</span>\n" if $title ne "" ;
return $res . "<table class=\"$class\"><tr><td>\n" ;
}
sub end_framedTable()
{
return "</td></tr></table>\n" ;
}
sub framedTable($$ )
{
my $title = shift ;
my $contents = shift ;
return join("\n",(&start_framedTable($title),
$contents,
&end_framedTable())) ;
}
###################################################################
### Make a list
###
=head2 ul_list
C<&P4CGI::ul_list(>B<list>C<)>
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 a dl list
###
=head2 dl_list
C<&P4CGI::dl_list(>B<list_of_pairs>C<)>
Returns a definition list.
=over 4
=item list_of_pairs
List of data pairs to print as a definition list.
A hash will do just fine, only you have no control over 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) ;
}
###################################################################
### Create a href tag
###
=head2 ahref
C<&P4CGI::ahref(>B<options>C<,>B<parameters>C<,>B<text>C<)>
Returns 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.
If the next to the last parameter has the format: C<"HELP=Help text"> the
help text is displayed as a tooltip.
=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","changeList.cgi",
"FSPC=//.../doc/...",
"HELP=Click here", # a tooltop help text
"Changes for all documentation") ; # url with parameter
=cut ;
sub ahref
{
my $args=@_ ;
my @tmp = @_ ;
my $url = $ENV{SCRIPT_NAME} ;
my $anchor = "" ;
my $params = "" ;
while($tmp[0] =~ /^-/) {
$tmp[0] =~ /^-url$/i and do {
shift @tmp ;
$url = shift(@tmp) ;
next ;
} ;
$tmp[0] =~ /^-anchor$/i and do {
shift @tmp ;
$anchor = "#" . shift @tmp ;
next ;
} ;
$tmp[0] =~ /^-(.*)/ and do {
my $p = $1 ;
shift @tmp ;
my $v = shift @tmp ;
$params .= " $p=$v" ;
next ;
} ;
last ;
}
my $pars = "" ;
$pars = "?DP=$P4_PORT_NO" if ($P4_PORT_NO and !($url =~ /\WDP=/) and !($url =~ /^mailto/)) ;
my $tooltips="" ;
while(@tmp > 1) {
if($tmp[0] =~ /HELP=(.*)/) {
$tooltips=" title=\"$1\"" ;
shift @tmp ;
next ;
}
if(length($pars) > 0) {
$pars .= ";" ;
}
else {
$pars = "?" ;
} ;
$pars .= urlEncode(shift @tmp) ;
} ;
my $txt = shift @tmp ;
$pars =~ s/ /\+/g ;
return "<a class=\"normal\" href=\"${url}${pars}${anchor}\"$params$tooltips>$txt</a>" ;
}
###################################################################
### ButtonCell
### Create a button link in a table cell
###
sub buttonCell($$@)
{
return "<td>" . &buttonLink(@_) . "</td>\n" ;
}
###################################################################
### ButtonLink
### Create a button link
###
sub buttonLink($$@)
{
my $url = shift ;
my $help = shift ;
my @text = @_ ;
my $params="" ;
$params = "?DP=$P4_PORT_NO" if ($P4_PORT_NO and !($url =~ /\WDP=/) and !($url =~ /^mailto/)) ;
while(@text > 1) {
if($params) {
$params .= ";" ;
}
else {
$params = "?" ;
}
$params .= shift @text ;
}
my $txt = $text[0] ;
$txt =~ s/ / /g ;
return "<span class=\"button\" ><a class=\"button\" href=\"$url$params\" title=\"$help\">$txt</a></span>\n" ;
}
###################################################################
### buttonVMenuTable
### Create a vertical menu of "buttons".
###
sub buttonVMenuTable(@)
{
my $r = "<table cellspacing=\"3\" cellpadding=\"0\" class=\"Button\">\n" ;
while(@_) {
my $m = shift ;
$r .= "<tr>\n " . $m ."</tr>\n" ;
}
return $r . "</table>\n" ;
}
###################################################################
### buttonHMenuTable
### Create a horizontal menu of "buttons".
###
sub buttonHMenuTable(@)
{
return
"<table cellspacing=\"3\" cellpadding=\"0\" class=\"Button\">\n".
"<tr>\n " .
join(' ',@_) .
"</tr>\n" .
"</table>\n" ;
}
###################################################################
### spanClass
### Create a <span> element with a class
###
sub spanClass($;$)
{
my $text = shift ;
$text = "" unless defined $text ;
my $class ;
$class = shift or do { $class = $DEFAULT_SPAN_CLASS ; } ;
if($class eq "") {
return "$text" ;
}
return "<span class=\"$class\">$text</span>" ;
}
###################################################################
### splitLine
### Use <br>-tags to split lines longer than maxlen characters (and do not include html-tags in count).
###
sub splitLine($$)
{
my $line = shift ;
my $maxlen = shift ;
my @line = split(/(<[^>]+>)/,$line) ;
$line = "" ;
while(@line > 0) {
my $l = shift @line ;
my $txt ="" ;
while(length($l) > $maxlen and
$l =~ s/(.{1,$maxlen}\S)\s(.*)/$2/) {
$txt .= $1 ;
$txt .= "\n" if length($l) ;
}
$txt .= $l ;
$txt =~ s/ / /g ;
$line .= $txt ;
$line .= shift @line if @line > 0 ;
}
return $line ;
}
###################################################################
### formatDescription
### Format a description text and insert it into a cell
###
sub formatDescription($;\@)
{
my $desc = shift ;
my @tmp ;
my $refref ;
$refref = shift or $refref = \@tmp ;
$desc = &htmlEncode($desc) ;
$desc = &P4CGI::magic($desc,$refref) ;
my @desc = map { my $d = splitLine($_,85) ;
$d ;
} split("\n",$desc) ;
my $r = join("\n",@desc) ;
$r =~ s/\n/<br>\n/g ;
return $r ;
}
###################################################################
### Login form
### Called when a user must log in
###
sub login_form() {
print start_page("Login page") ;
if(NO_OF_DEPOTS() > 1) {
print
$CGI->start_form(-method=>"POST",
-action=>$CGI->self_url()),
start_framedTable("Select depot"),
start_table() ;
my $d ;
my %alts ;
my @depotnames ;
for($d = 0 ; $d < NO_OF_DEPOTS() ; $d++) {
my $n = DEPOT_NAME($d) ;
$alts{$d} = $n ;
push @depotnames, $d ;
}
my $cell = $CGI->popup_menu(-name=>"DP",
"values"=>\@depotnames,
-title=>"Select p4 server",
-default=>CURR_DEPOT_NO(),
-labels=>\%alts) ;
print
table_row({-class=>"Prompt",
-text=>"Select p4 server"},
{-align=>"left",
-text=>$cell}),
table_row("",
$CGI->submit(-value=>'Change server',
-name=>'1')),
end_table(),
end_framedTable(),
$CGI->end_form(),
"<br>";
}
print
$CGI->start_form(-method=>"POST",
-action=>$CGI->self_url()),"\n",
start_framedTable("Log in"),"\n",
start_table() ;
## Print input field for user name.
my $defaultuser;
$defaultuser = $P4_USER if $P4_USER ;
if($SELECT_USER_FROM_LIST) {
my %p4users = p4users() ;
my %user2username ;
map {
$user2username{$_} = "$_ (".${$p4users{$_}}{"FullName"}.")" ;
} keys %p4users ;
my @usersInOrder = sort {uc($a) cmp uc($b)} keys %p4users ;
print
table_row({-class=>"Prompt",
-text=>"P4 user"},
{-align=>"left",
-text=>$CGI->popup_menu(-name=>"LOGIN_USER",
-values=>\@usersInOrder,
-labels=>\%user2username,
-default=>$defaultuser)}) ;
}
else {
print
table_row({-class=>"Prompt",
-text=>"P4 user"},
{-align=>"left",
-text=>$CGI->textfield(-name=>"LOGIN_USER",
-size=>20,
-maxlength=>80,
-default=>$defaultuser)}) ;
} ;
$CGI->delete("LOGIN_PASSWD") ;
print
table_row({-class=>"Prompt",
-text=>"Password"},
{-align=>"left",
-text=>$CGI->password_field(-name=>"LOGIN_PASSWD",
-size=>20,
-default=>"",
-maxlength=>80)}),
table_row("",
{-align=>"left",
-text=>$CGI->submit(-name=>"Login",
-value=>"Login")}),
end_table(),
end_framedTable(),
"\n" ;
$CGI->delete("LOGIN_USER","Login") ;
my @pars=$CGI->param() ;
foreach (@pars) {
print $CGI->hidden($_,$CGI->param($_)) , "\n" ;
}
print $CGI->end_form() ;
print
"The user name and password used for P4DB is same as your p4 user name and password. " ;
$P4_USER= undef ;
print end_page() ;
exit 0 ;
}
sub BEGIN ()
{
init() ;
} ;
1;