#!/usr/local/bin/perl

#
# p4xml.pl - a CGI script for serving up Perforce related data as 
#            XML to web applications
# 
# Accepted parameters: 
#    command=<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=<anything>     - shockingly enough, follow integs a.k.a. '-i'
#    long=<anything>             - fetch long descriptions
#    expr=<job query>            - job query
#
# Returned data: Perforce tagged data formatted as XML, root tag named <perforce>
#
# Sample query:  http://public.perforce.com/cgi-bin/p4xml.pl?command=changes;path=//guest/matt_attaway/p4xml/...
#

use strict;
use Switch;

my $user   = "matt_attaway";
my $passwd = "foobar";
my $port   = "public.perforce.com:1666";
my $p4exec = "p4.exe";
my $p4     = "$p4exec -ztag -p $port -u $user -P $passwd ";

# let's get this party started
my %vars = &getCgiVars;

if( ($ENV{'REQUEST_METHOD'} eq 'GET') )
{
    # das headers
    print "Content-type: text/xml\n\n" ;	
	print "<?xml version='1.0' encoding='ISO-8859-1'?>";
	
	# verify we at least have a command
    if( !exists $vars{"cmd"} )
    {
        print "<perforce><error>Give me a command fool</error></perforce>";
        exit;
    }

    my $ results;
    switch( $vars{"cmd"} )
    {
    case "changes" 	{ $results = &fetchChanges }
    case "jobs" 	{ $results = &fetchJobs }
    else { print "<perforce><error>Give me a command fool</error></perforce>"; exit; }
    }

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


sub fetchChanges
{
   my( @changes, $cmdline, $output );
   my $needEndTag = 0;
   
   # get the changes
   $cmdline .= $p4 . "changes ";
   if( exists $vars{"user"} )
   {
       $cmdline .= "-u " . $vars{"user"} . " ";
   }
   if( exists $vars{"client"} )
   {
       $cmdline .= "-c " . $vars{"client"} . " ";
   }
   if( exists $vars{"max"} )
   {
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }
   if( exists $vars{"followIntegs"} )
   {
       $cmdline .= "-i ";	
   }
   if( exists $vars{"long"} )
   {
       $cmdline .= "-l ";	
   }
   if( exists $vars{"path"} )
   {
       $cmdline .= $vars{"path"};
   }
   if( exists $vars{"rev"} )
   {
       $cmdline .= $vars{"rev"};
   }
   @changes = `$cmdline`;
   
   # now parse 'em
   my $desc;
   my $parsingDesc = 0;
   while( scalar(@changes) )
   {
   	   $_ = shift @changes;
   	   
   	   # handle multiline descriptions
   	   if( $parsingDesc )
   	   {
   	       if( /^\.\.\. .*/ )
   	       {
   	           unshift @changes, $_;
   	           $output .= "$desc</desc>";
   	           $desc = "";
   	           $parsingDesc = 0;
   	       }	
           else
           {   	   	   
   	   	       $desc .= $_;
   	   	   }
   	   	   next;
   	   }
   	   
   	   # toss away blank lines between sets of changes
   	   next if /^$/;
   	
   	   # throw on the end tag if we need it
       if( /^\.\.\. change/ && $needEndTag )
       {
           $output .= '</change>';
       }
       
       # handle actual output
       switch( $_ )
       {
       case /^\.\.\. change/ { /^\.\.\. change ([0-9]*)/; $output .= "<change id=\"$1\">"; }
       case /^\.\.\. desc/ { /^\.\.\. desc (.*)/; $desc .= "<desc>$1"; $parsingDesc = 1; }
       else { /^\.\.\. (\w*) (.*)/; $output .= "<$1>" . $2 . "</$1>"; }
       }

   	   $needEndTag = 1;
   }
   
   $output .= '</change>';
   return $output;
}


sub fetchJobs
{
   my( @jobs, $cmdline, $output );
   my $needEndTag = 0;
   
   # get the changes
   $cmdline .= $p4 . "jobs ";
   if( exists $vars{"max"} )
   {
       $cmdline .= "-m " . $vars{"max"} . " ";	
   }
   if( exists $vars{"followIntegs"} )
   {
       $cmdline .= "-i ";	
   }
   if( exists $vars{"long"} )
   {
       $cmdline .= "-l ";	
   }
   if( exists $vars{"expr"} )
   {
       $cmdline .= "-e " . '"' . $vars{"expr"} . '"' . " ";
   }
   
   # run commands
   @jobs = `$cmdline`;
   
   # now parse 'em
   my $currentElem;
   my $currentElemText;
   my $parsingElem = 0;
   
   while( scalar(@jobs) )
   {
   	   $_ = shift @jobs;
   	   
   	   # handle multiline fields
   	   if( $parsingElem )
   	   {
   	       if( /^\.\.\. .*/ )
   	       {
   	           unshift @jobs, $_;
   	           $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
       if( /^\.\.\. Job/ && $needEndTag )
       {
           $output .= '</job>';
       }
       
       # handle actual output
       switch( $_ )
       {
       case /^\.\.\. Job/ { /^\.\.\. Job (.*)/; $output .= "<job id=\"$1\">"; }
       else { 
       	        /^\.\.\. (\w*) (.*)/; 
       	        $currentElem = $1; 
       	      
       	        # escape XML unfriendly content
       	        $currentElemText = "<$currentElem>" . &escapeCDATA( $2 );

       	        $parsingElem = 1;
       	    }
       }

   	   $needEndTag = 1;
   }
   
   $output .= "$currentElemText</$currentElem></job>";
   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 ;
}