p4_ls #7

#!/usr/bin/perl -w

#
# p4_ls for Safari
# Copyright (c) 1999 by Barrie Slaymaker, rbs@telerama.com
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the README file.
#
#
# Takes an absolute path and uses it as a wildcard spec to generate a listing
# of a directory in the archives.
#

use strict ;
use vars qw( $opt_out_file $opt_depot_list $opt_file_list ) ;
use Getopt::Long ;
use File::Basename ;
use File::Path ;
use HTML::Entities ;

my $progname = basename( $0 ) ;

GetOptions(
   'depot-list=s',
   'file-list=s',
   'out-file|o=s',
) ;

my ( $spec ) = ( @ARGV ) ;

my $up_to_project = $ENV{SAF_UP_TO_PROJECT} ;
my $up_to_rev     = $ENV{SAF_UP_TO_REV} ;
my $up_to_filter  = $ENV{SAF_UP_TO_FILTER} ;
my $filter        = $ENV{SAF_FILTER} ;
my $file          = $ENV{SAF_FILE} ;
my $rev           = $ENV{SAF_REV} ;

$spec = '//'
   unless defined( $spec ) && length( $spec ) ;

die "path name must be absolute (start with a '/')"
   unless substr( $spec, 0, 1 ) eq '/' ;

#
# Allow a /* here for forwards compatability, so we can implement
# real globbing.
#
$spec =~ s/\*$//g ;

if ( defined( $opt_out_file ) && length( $opt_out_file ) ) {
   my ( undef, $dir ) = fileparse( $opt_out_file ) ;
   mkpath( $dir, 0, 0775 )
      unless -d $dir ;

   open( OUTPUT, ">$opt_out_file" ) or
      die "$!: $opt_out_file" ;
   $SIG{__DIE__} = sub {
      close( OUTPUT ) ;
      print( STDERR "Removing $opt_out_file\n" ) ;
      unlink( $opt_out_file ) ;
   }
}
else {
   open( OUTPUT, ">&STDOUT" ) ;
}

# make /a in to //a
$spec = "/$spec"
   unless substr( $spec, 0, 2 ) eq '//' ;

# make sure there's a / on the end
$spec .= '/'
   unless substr( $spec, -1 ) eq '/' ;

my $list_depots = $spec eq '//' ;

my $headers ;
my $files = {} ;
my $title ;
my $align ;

if ( $list_depots ) {
   $title = "Depots" ;
   $headers = [ 'Depot', 'Description' ] ;
   $align   = [ 'LEFT', 'LEFT' ] ;
   my %depots ;

   my $p4 = defined( $opt_depot_list ) ? "<$opt_depot_list" : "p4 depots |" ;
   open( P4, "$p4" ) or
      die "$progname: $!: '$p4'" ;
   while ( <P4> ) {
      chomp ;
      my ( $type, $depot, $date, undef, undef, $subdir, $desc ) =
         split( /\s+/, $_, 7 ) ;
      next unless defined $desc ;
      $desc =~ s/^'(.*)\s*'$/$1/ ;
      my $depot_key = lc( $depot ) ;
      $depot .= '/' ;
      $files->{ $depot_key } = [ 
         join(
            '',
            qq{<A HREF="$depot">},
            encode_entities( $depot ),
            '</A>',
         ),
         encode_entities( $desc ),
      ] ;
   }
   close( P4 ) or
      die length( $! ) ? "$progname: $! closing '$p4'" : "'$p4' returned $?" ;
   $files->{'depot'} = [ qq{<A HREF="depot/">depot/</A>}, 'default depot' ] 
      unless %$files ;
}
else {
   #
   # We need to list all of the files here because the 'p4 files' command
   # does not list out subdirs. This means that we need to discern subdirs
   # ourself by scanning all files.
   #
   $title = "Files in $spec" ;
   $headers = [ 'File', 'Rev',   '',       'Description', 'Change', '',       'Type' ] ;
   $align   = [ 'LEFT', 'RIGHT', 'CENTER', 'LEFT',        'RIGHT',  'CENTER', 'LEFT' ] ;
   my $p4 = defined( $opt_file_list ) ? "<$opt_file_list" : "p4 files //... |";
   open( P4, "$p4" ) or
      die "$progname $! opening '$p4'" ;

   my $spec_len = length( $spec ) ;
   my %seen ;

   my $dir_entry = {} ;

   while ( <P4> ) {
      chomp ;

      my ( $name, $frev, $desc ) = /^([^#]+)(#\d+)\s*-\s*(.*?)\s*$/ ;
      next unless defined $desc ;
      next unless substr( $name, 0, $spec_len ) eq $spec ;

      $name = substr( $name, $spec_len ) ;

      my $is_dir = $name =~ s@/.*@/@ ;

      my $full_name = $spec . $name ;
      $full_name =~ s@^//@/@ ;

      $desc =~ s/^\s*// ;
      $desc =~ s/\s*$// ;

      my $type = '' ;
      if ( $desc =~ s@\s*\((\w+)\)\s*$@@ ) {
         $type = $1 ;
      }

      my $change = '' ;
      if ( $desc =~ s/(.*?)\s*change (\d+)\s*(.*)/$1$3/ ) {
         $change = $2 ;
      }

      if ( %$dir_entry && $name ne $dir_entry->{NAME} ) {
         emit_dir( $files, $dir_entry ) ;
         $seen{$dir_entry->{NAME}} = 1 ;
         $dir_entry = {} ;
      }

      my $is_deleted = $desc eq 'delete' ;

      if ( $is_dir ) {
         unless ( %$dir_entry ) {
	    $dir_entry->{FULL_NAME} = $full_name ;
	    $dir_entry->{NAME} = $name ;
         }

         $dir_entry->{NON_EMPTY} ||= ! $is_deleted ;

         $dir_entry->{MAX_CHANGE} = $change
            if ( ! defined $dir_entry->{MAX_CHANGE} ||
               $change > $dir_entry->{MAX_CHANGE} 
            ) ;
         next ;
      }

      next if $seen{$name} ;

      $seen{name} = 1 ;

      $files->{lc( $name )} = [ 
	 name_anchor( $name, $is_deleted ),
	 join( '', "<TT>", encode_entities( $frev ), "</TT>" ),
         filelog_anchor( $full_name ),
	 encode_entities( $desc ), 
         change_anchor( $full_name, $change, $is_deleted ),
         desc_anchor( $change ),
	 encode_entities( $type ),
      ] ;

      strike_all( @{$files->{lc( $name )}} )
        if $is_deleted ;
   }

   emit_dir( $files, $dir_entry )
      if ( %$dir_entry ) ;

   close( P4 ) or
      die length( $! ) ? "$progname: $! closing '$p4'" : "'$p4' returned $?" ;
}

#
# We accumulate all output, then print it in a burst so that no output leaks
# out in the event of an error, and so we can use common formatting code.
#


my $output = format_list( $align, $headers, $files ) ;

print OUTPUT
qq{<HTML>
<HEAD>
   <TITLE>$title</TITLE>
</HEAD>
<BODY>
<TABLE CELLPADDING="2" CELLSPACING="0" BORDER="0">
$output
</TABLE>
</BODY>
</HTML>
} or 
   die "$!: $opt_out_file" ;

close( OUTPUT ) or
   die "$!: $opt_out_file" ;

0 ;

###############################################################################

sub name_anchor {
   my( $name, $deleted ) = @_ ;
   my $name_anchor = encode_entities( $name ) ;

   $name_anchor = qq{<A HREF="$name">$name_anchor</A>} 
      unless $deleted ;

   return $name_anchor ;
}

sub filelog_anchor {
   my $full_name = shift ;
   return 
    qq{[ <A HREF="${up_to_project}_head/$filter$full_name?filter=filelog">filelog</A> ]} ; 
}


sub change_anchor {
   my ( $full_name, $change, $deleted ) = @_ ;
   my $change_anchor = 
      join( '', '<TT>', encode_entities( "\@$change" ), "</TT>" ) ;
   $change_anchor = 
   qq{<A HREF="$up_to_project\@$change/$filter$full_name">$change_anchor</A>} 
      unless $deleted ;
   return $change_anchor ;
}


sub desc_anchor {
   my $change = shift ;
   return qq{[ <A HREF="${up_to_project}_head/changes/$change.html">desc</A> ]};
}


sub emit_dir {
   my ( $files, $dir_entry ) = @_ ;

   my $name = $dir_entry->{NAME} ;

   $files->{lc( $name )} = [
      name_anchor( $name ),
      "<BR>",
      "<BR>",
      "<BR>",
      change_anchor( 
         $dir_entry->{FULL_NAME}, 
         $dir_entry->{MAX_CHANGE}, 
         ! $dir_entry->{NON_EMPTY}
      ),
      desc_anchor( $dir_entry->{MAX_CHANGE}) ,
      "<BR>",
   ] ;

   strike_all( @{$files->{lc( $name )}} )
      unless $dir_entry->{NON_EMPTY} ;
}


sub strike_all {
   map{ $_ = "<STRIKE>$_</STRIKE>" } @_ ;
}


sub format_list {
   my ( $align, $headers, $files ) = @_ ;
   my @output ;
   my $format = join( '', map{ "<TH ALIGN=\"$_\">%s</TH>" } "RIGHT", @$align ) ;
   push( 
      @output, 
      '<TR ALIGN="LEFT">', 
      sprintf( $format, '<BR>', @$headers ), 
      "</TR>\n" 
   ) ;
   my $grey = '"#B0FFB0"' ;
   my $greybar_rows = 5 ;
   my $line_number = 1 ;
   $format =~ s/TH/TD/g ;
   for ( sort keys %$files ) {
      my $bgcolor = int( ( $line_number - 1 )  / $greybar_rows) % 2 ?
         " BGCOLOR=$grey" :
	 "" ;
      push( 
	 @output, 
         "<TR$bgcolor>", 
         sprintf( $format, $line_number, @{$files->{$_}} ), 
	 "</TR>\n" 
      ) ;
      ++$line_number ;
   }
   return join( '', @output ) ;
}