- #!/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 ) ;
- }
# | Change | User | Description | Committed | |
---|---|---|---|---|---|
#7 | 201 | Barrie Slaymaker |
More format tweaks, fixed bug that made change number a link for deleted items. |
26 years ago | |
#6 | 197 | Barrie Slaymaker | Added change numbers to directory lines, made strikeout apply to all fields for deleted l...ines. « |
26 years ago | |
#5 | 184 | Barrie Slaymaker | The change number is now a link even when for a deleted file. ...It is still put in <STRIKE> if the file is deleted. « |
26 years ago | |
#4 | 182 | Barrie Slaymaker | Cleaned up directory listing so that directories no longer have meaningless links to chan...ge number, filelog, etc. Also made directory names appear in <STRIKE> when they contain no files that have not been deleted. « |
26 years ago | |
#3 | 168 | Barrie Slaymaker | Added YAPC paper, slides | 26 years ago | |
#2 | 165 | Barrie Slaymaker | Applied Greg KH's license patch. | 26 years ago | |
#1 | 162 | Barrie Slaymaker | First code & documentation checkin | 26 years ago |