#!/usr/bin/perl

#
# p4xml.pl - a CGI script for serving up Perforce related data as 
#            XML to web applications
# 
# Accepted parameters: 
#    cmd=<perforce command>      - Perforce command (required)
#    path=<depot path>           - a depot path
#    rev=<rev specifier>         - a Perforce revision specifier
#    user=<user>                 - a Perforce user
#    client=<client>             - a Perforce client
#    max=<num>                   - max number of elements
#    followIntegs=               - shockingly enough, follow integs a.k.a. '-i'
#    long=                       - fetch long descriptions
#    expr=<job query>            - job query
#    showDetails=                - show all info from a command, a la monitor
#
# Returned data: Perforce tagged data formatted as XML, root tag named <perforce>
#
# Sample query:  http://public.perforce.com/cgi-bin/p4xml.pl?cmd=changes;path=//guest/matt_attaway/p4xml/...
#

use strict;
use Switch;

my $user   = "matt";
my $port   = "public.perforce.com:1666";
my $p4exec = "/usr/local/bin/p4";
my $p4     = "$p4exec -ztag -p $port -u $user ";

# let's get this party started; parse the query string
my %vars = &getCgiVars;
my $ results;

if( ($ENV{'REQUEST_METHOD'} eq 'GET') )
{
    # das headers
    print "Content-type: text/xml\n\n" ;	
	print "<?xml version='1.0' encoding='ISO-8859-1'?>";
	
    switch( $vars{"cmd"} )
    {
  	case "branches" 	   { $results = &fetchBranches }
    case "changes" 	   { $results = &fetchChanges }
    case "clients" 	   { $results = &fetchClients }
    case "depots"      { $results = &fetchDepots }
    case "jobs" 	   { $results = &fetchJobs }
    case "labels"      { $results = &fetchLabels }
    case "users"       { $results = &fetchUsers }
    case "monitor"     { $results = &fetchProcesses }
    else               { $results = "<error>Give me a command fool</error>"; }
    }

    # the good stuff
	print "<perforce>$results</perforce>";
}


sub fetchBranches
{
   my( @branches, $cmdline );
   
   # build the command
   $cmdline .= $p4 . "branches ";
   if( exists $vars{"user"} )
   {
   	   if( !IsValidAlphaNumeric( $vars{"user"} ) ) { return "<error>Alphanumeric values only for variable \"user\"</error>"; }   	
       $cmdline .= "-u " . $vars{"user"} . " ";
   }
   if( exists $vars{"max"} )
   {
   	   if( !IsValidNumeric( $vars{"max"} ) ) { return "<error>Numeric values only for variable \"max\"</error>"; }   	
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }

   # fetch the branches
   @branches = `$cmdline`;
   
   return &parsePerforceLists( "branch", "branch", @branches );
}


sub fetchChanges
{
   my( @changes, $cmdline );
   
   # build the command
   $cmdline .= $p4 . "changes ";
   if( exists $vars{"user"} )
   {
   	   if( !IsValidAlphaNumeric( $vars{"user"} ) ) { return "<error>Alphanumeric values only for variable \"user\"</error>"; }   	
       $cmdline .= "-u " . $vars{"user"} . " ";
   }
   if( exists $vars{"client"} )
   {
   	   if( !IsValidData( $vars{"client"} ) ) { return "<error>Alphanumeric values only for variable \"client\"</error>"; }   	
       $cmdline .= "-c " . $vars{"client"} . " ";
   }
   if( exists $vars{"max"} )
   {
   	   if( !IsValidNumeric( $vars{"max"} ) ) { return "<error>Numeric values only for variable \"max\"</error>" }   	
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }
   if( exists $vars{"followIntegs"} )
   {
       $cmdline .= "-i ";	
   }
   if( exists $vars{"long"} )
   {
       $cmdline .= "-l ";	
   }
   if( exists $vars{"path"} )
   {
   	   if( !IsValidData( $vars{"path"} ) ) { return "<error>Alphanumeric values only for variable \"path\"</error>"; }    	
       $cmdline .= $vars{"path"};
   }
   if( exists $vars{"rev"} )
   {
   	   if( !IsValidRevData( $vars{"rev"} ) ) { return "<error>Numeric values only for variable \"rev\"</error>" }   	
       $cmdline .= $vars{"rev"};
   }
   
   # fetch the changes
   @changes = `$cmdline`;
   
   return &parsePerforceLists( "change", "change", @changes );
}


sub fetchClients
{
   my( @clients, $cmdline );
   
   # build the command
   $cmdline .= $p4 . "clients ";
   if( exists $vars{"user"} )
   {
   	   if( !IsValidAlphaNumeric( $vars{"user"} ) ) { return "<error>Alphanumeric values only for variable \"user\"</error>"; }   	
       $cmdline .= "-u " . $vars{"user"} . " ";
   }
   if( exists $vars{"max"} )
   {
   	   if( !IsValidNumeric( $vars{"max"} ) ) { return "<error>Numeric values only for variable \"max\"</error>" }   	
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }

   # fetch the clients
   @clients = `$cmdline`;
   
   return &parsePerforceLists( "client", "client", @clients );
}


sub fetchDepots
{
   my( @depots, $cmdline );
   
   # build the command
   $cmdline .= $p4 . "depots ";

   # fetch the clients
   @depots = `$cmdline`;
   
   return &parsePerforceLists( "name", "depot", @depots );
}


sub fetchJobs
{
   my( @jobs, $cmdline );
   
   # build the command
   $cmdline .= $p4 . "jobs ";
   if( exists $vars{"max"} )
   {
   	   if( !IsValidNumeric( $vars{"max"} ) ) { return "<error>Numeric values only for variable \"max\"</error>" }   	
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }
   if( exists $vars{"followIntegs"} )
   {
       $cmdline .= "-i ";	
   }
   if( exists $vars{"long"} )
   {
       $cmdline .= "-l ";	
   }
   if( exists $vars{"expr"} )
   {
   	   if( !IsValidData( $vars{"expr"} ) ) { return "<error>Alphanumeric values only for variable \"expr\"</error>"; }    	
       $cmdline .= "-e " . '"' . $vars{"expr"} . '"' . " ";
   }
   
   # fetch the jobss
   @jobs = `$cmdline`;
   
   return &parsePerforceLists( "Job", "job", @jobs );
}


sub fetchLabels
{
   my( @labels, $cmdline );
   
   # build the command
   $cmdline .= $p4 . "labels ";
   if( exists $vars{"user"} )
   {
   	   if( !IsValidAlphaNumeric( $vars{"user"} ) ) { return "<error>Alphanumeric values only for variable \"user\"</error>"; }   	
       $cmdline .= "-u " . $vars{"user"} . " ";
   }
   if( exists $vars{"max"} )
   {
  	   if( !IsValidNumeric( $vars{"max"} ) ) { return "<error>Numeric values only for variable \"max\"</error>" }   	
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }
   if( exists $vars{"path"} )
   {
   	   if( !IsValidData( $vars{"path"} ) ) { return "<error>Alphanumeric values only for variable \"path\"</error>"; }    	
       $cmdline .= $vars{"path"};
   }
   if( exists $vars{"rev"} )
   {
   	   if( !IsValidRevData( $vars{"rev"} ) ) { return "<error>Numeric values only for variable \"rev\"</error>" }   	
       $cmdline .= $vars{"rev"};
   }
   
   # fetch the labels
   @labels = `$cmdline`;
   
   return &parsePerforceLists( "label", "label", @labels );
}


sub fetchProcesses
{
    my( @processes, $cmdline );
    
    # build command
    $cmdline .= $p4 . "monitor show ";
    if( exists $vars{"showDetails"} )
    {
    	$cmdline .= "-ael";
    }
    
    # fetch the processes
    @processes = `$cmdline`;
    
    return &parsePerforceLists( "id", "process", @processes );
}


sub fetchUsers
{
   my( @users, $cmdline );
   
   # build the command
   $cmdline .= $p4 . "users ";
   if( exists $vars{"max"} )
   {
   	   if( !IsValidNumeric( $vars{"max"} ) ) { return "<error>Numeric values only for variable \"max\"</error>" }   	
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }
   if( exists $vars{"user"} )
   {
   	   if( !IsValidAlphaNumeric( $vars{"user"} ) ) { return "<error>Alphanumeric values only for variable \"user\"</error>"; }   	
       $cmdline .= $vars{"user"};
   }
   
   # fetch the users
   @users = `$cmdline`;
   
   return &parsePerforceLists( "User", "user", @users );
}


sub parsePerforceLists()
{
   my $specKey = shift;
   my $tagName = shift;
   my @results = @_;
   my $output;
   my $currentElem;
   my $currentElemText;
   my $parsingElem = 0;
   my $needEndTag = 0;
   
   while( scalar(@results) )
   {
   	   $_ = shift @results;
   	   
   	   # handle multiline fields
   	   if( $parsingElem )
   	   {
   	       if( /^\.\.\. .*/ )
   	       {
   	           unshift @results, $_;
   	           
   	           # check to see if this is the next tag is a "key" tag, and
   	           # if so chop the two newlines perforce likes to attach
   	           if( /^\.\.\. $specKey/ )
			   {
			   	   chop $currentElemText;chop $currentElemText;
			   }   	           
   	           
   	           $output .= "$currentElemText</$currentElem>";
   	           $currentElemText = $currentElem = "";
   	           $parsingElem = 0;
   	       }	
           else
           {   	   	   
   	   	       $currentElemText .= &escapeCDATA( $_ );
   	   	   }
   	   	   next;
   	   }
   	   
   	   # toss away blank lines between sets of jobs
   	   next if /^$/;
   	
   	   # throw on the end tag if we need it, and cut off the newline that p4 likes to append
       if( /^\.\.\. $specKey/ && $needEndTag )
       {
           $output .= "</$tagName>";
       }
       
       # handle actual output
       switch( $_ )
       {
       case /^\.\.\. $specKey/ { /^\.\.\. $specKey (.*)/; $output .= "<$tagName id=\"$1\">"; }
       else { 
       	        /^\.\.\. (\w*) (.*)/; 
       	        $currentElem = $1; 
       	      
       	        # escape XML unfriendly content
       	        $currentElemText = "<$currentElem>" . &escapeCDATA( $2 );

       	        $parsingElem = 1;
       	    }
       }

   	   $needEndTag = 1;
   }
   chop $currentElemText; chop $currentElemText;
   
   if( $needEndTag )
   {
       $output .= "$currentElemText</$currentElem></$tagName>";
   }
   return $output;
}	
	
	
sub escapeCDATA()
{
	my $cdata = shift;
	
    $cdata =~ s/\&/&amp;/g;
    $cdata =~ s/</&lt;/g;
    $cdata =~ s/>/&gt;/g; 
    
    return $cdata;	
}


sub getCgiVars( )
{
    my( $in, $key, $val );

    # read entire string of CGI vars
    if( ($ENV{'REQUEST_METHOD'} eq 'GET') ||
        ($ENV{'REQUEST_METHOD'} eq 'HEAD') ) 
    {
        $in = $ENV{'QUERY_STRING'};
    } 
    elsif ($ENV{'REQUEST_METHOD'} eq 'POST') 
    {
        read(STDIN, $in, $ENV{'CONTENT_LENGTH'}) ;
    }
    else
    {
    	exit;
    }
    
    # resolve name/value pairs into %in
    foreach( split( /[&;]/, $in ) ) 
    {
        s/\+/ /g ;
        my ($key, $val) = split /=/;
        $key =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge ;
        $val =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge ;
        $vars{$key}.= $val ;
    }

    return %vars ;
}


sub IsValidRevData()
{
	my $value = shift;
	
	if( $value !~ /^[0-9\w\@\#\-]+$/ )
	{
	    return 0;	
	}
	return 1;	
}


sub IsValidData()
{
	my $value = shift;
	
	if( $value !~ /^[0-9\w-\/]+$/ )
	{
	    return 0;	
	}
	return 1;	
}

sub IsValidAlphaNumeric()
{
	my $value = shift;
	
	if( $value !~ /^[0-9\w]+$/ )
	{
	    return 0;	
	}
	return 1;	
}

sub IsValidNumeric()
{
	my $value = shift;
	
	if( $value !~ /^[0-9]+$/ )
	{
	    return 0;	
	}
	return 1;	
}


sub IsValidAlpha()
{
	my $value = shift;
	
	if( $value !~ /^[\w]+$/ )
	{
	    return 0;	
	}
	return 1;
}


sub ReturnError()
{
	
}