p4_get #5

#!/usr/bin/perl -w

#
# p4_get 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.
#
#
# Gets all files from a labelled version in to a subdirectory
#
# The subdirectory must be provided as the last argument, the
# list of files to get is read from stdin or from a file named in ARGV.
# The list of files should be the output of the 'p4 files' command.
#

use strict ;
use Getopt::Long ;
use File::Basename ;
use File::Path ;
use File::Copy ;

my @options = (
   'rev|r=s',
   'p4-file-list|l=s',
   'out-file|o=s',
) ;

my $options = {} ;

GetOptions( $options, @options ) ;

my $progname = basename( $0 ) ;

die "no targets specified"
   unless @ARGV ;

my $rev = $options->{'rev'} ;
$rev = '_head'
   unless defined( $rev ) && length( $rev ) ;
$rev = "_$rev"
   if $rev =~ /^(?:\d+|head)$/ ;
$rev =~ s/^#/_/;
 
my $out_file= $options->{'out-file'} ;
$out_file = ''
   unless defined( $out_file ) && length( $out_file ) ;

my $p4_file_list = $options->{'p4-file-list'} ;
$p4_file_list = ''
   unless defined( $p4_file_list ) && length( $p4_file_list ) ;

my $p4_files = get_p4_files() ;

# print( join( "\n", map { $_->[0] . '#' . $_->[1] } @$p4_files ) ) ;

#
# Scan arg list, then find matching files.  This makes the order
# of the resulting fetches more expected than the other way.
#
while ( @ARGV ) {
   my $target = pop @ARGV ;
   $target =~ s@/\.\.\.$@@ ;
   $target =~ s@^//?@@ ;

   my $target_name_length = length( $target ) ;

   for ( @$p4_files ) {
      my $p4_name = $_->[0] ;
      my $p4_rev  = $_->[1] ;
      die "undefined p4_name" unless defined $p4_name ;
      die "undefined file revision" unless defined $p4_rev ;
      my $file_rev = $p4_rev ;
      $file_rev =~ s/^#/_/ ;

      my $target_name = $p4_name ;
      $target_name =~ s@^//?@@ ;

      next unless substr( $target_name, 0, $target_name_length ) eq $target ;

      my $p4_rev_file_name = "$p4_name$p4_rev" ;
      my $rev_target_name  = "$file_rev/$target_name" ;
      my $out_file_name      = 
	 $out_file eq '' || $out_file eq '-' ?
	 "$rev/$target_name" :
	 $out_file ;
      get_file( $p4_rev_file_name, $rev_target_name ) ;

      if ( $rev_target_name ne $out_file_name ) {
         if ( -f $out_file_name ) {
            unlink $out_file_name or
               die "$: unlink $out_file_name" ;
         }
         else {
	    my ( undef, $dir ) = fileparse( $out_file_name ) ;
            mkpath( $dir, 0, 0775 ) ;
         }

	 link( $rev_target_name, $out_file_name ) or
	    die "$!: link( $rev_target_name, $out_file_name )" ;
#	 copy( $link, $out_file_name ) or
#	    die "$!: copy( $link, $out_file_name )" ;
#         my @chunks = split( '/', $dir ) ;
#	 my $updirs = '../' x @chunks ;
#         my $link = "$updirs$rev_target_name" ;
#	 if ( ! -l $out_file_name || $link ne readlink $out_file_name ) {
##	    print $link, '<=>', readlink $out_file_name, "\n" ;
#	    unlink( $out_file_name ) ;
#	    mkpath( $dir, 0, 0775 )
#	       unless -d $dir ;
#            print( "$prog_name: Linking $out_file_name -> $rev_target_name\n" ) ;
#	    symlink( $link, $out_file_name ) or
#	       die "$!: symlink( $link, $out_file_name )" ;
##	    print $link, '<=>', readlink $out_file_name, "\n" ;
#         }
      }
   }
}   

0 ;

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


sub get_p4_files {
   my $file_list_name = $options->{'p4-file-list'} ;

   my ( undef, $file_dir ) = fileparse( $file_list_name ) ;
   mkpath( $file_dir, 0, 0775 )
      unless -d $file_dir ;

   my $p4 ;

   if ( defined $file_list_name && -f $file_list_name ) {
      $p4 = $file_list_name ;
      open( P4, "<$p4" ) or die "$!: $p4" ;
   }
   else {
      # Clean up the rev since "#" is passed in as an underscore
      my $p4_rev = $rev ;
      $p4_rev =~ s/^_/#/ ;

      $p4 = "p4 files //...$p4_rev" ;
      print( "Getting '$p4' list\n" ) ;

      open( P4, "$p4 |" ) or die "$!: p4 files command" ;
   }

   my $p4_files = [] ;

   my $none_such ;

   while ( <P4> ) {
      chomp ;
      my ( $name, $rev, $action, $desc ) = /^([^#]+)(#\d+)\s+-\s+(\w+)\s+(.*)/ ;
      next unless defined $desc && $action ne 'delete' ;
      push( @$p4_files, [ $name, $rev, $action, $desc ] ) ;
   }
   die "$!: $p4"
      unless close( P4 ) ;

   return $p4_files ;
}

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

sub get_file {
   my ( $p4_name, $file_name ) = @_ ;

   if ( -f $file_name ) {
#      print( "$progname: $file_name exists\n" ) ;
      return
   }

   my ( undef, $dir ) = fileparse( $file_name ) ;
   mkpath( $dir, 0, 0775 ) 
      unless -d $dir ;

   open( OUTPUT, ">$file_name" ) or
      die "$! opening $file_name" ;

   my $p4 = "p4 print $p4_name |" ;
   print( "$progname: $file_name\n" ) ;
#      print( '.' ) ;
   open( P4, $p4 ) or
      die "$!: $p4" ;
   my $first_line = <P4> ;
#   print $first_line ;
   $\ = undef ;
   while (<P4>) {
      print OUTPUT $_ or
	 die "$!" ;
   }
   unless ( close( OUTPUT ) ) {
      my $msg = $! ;
      print "$progname: unlinking $file_name\n" ;
      unlink( $file_name ) or
         print STDERR "$progname: $! unlinking $file_name\n" ;
      die "$msg closing $file_name" ;
   }
   unless( close( P4 ) ) {
      my $code = $? ;
      print "$progname: unlinking $file_name\n" ;
      unlink( $file_name ) or
         print STDERR "$progname: $! unlinking $file_name\n" ;
      die "$p4 returned $code" ;
   }
}