package VCP::Source::p4 ; =head1 NAME VCP::Source::p4 - A Perforce p4 repository source =head1 SYNOPSIS vcp p4://depot/...@10 # all files after change 10 applied vcp p4://depot/...@1,10 # changes 1..10 vcp p4://depot/...@-2,10 # changes 8..10 vcp p4://depot/...@1,#head # changes 1..#head vcp p4://depot/...@-2,#head # changes 8..10 vcp p4:...@-2,#head # changes 8..10, if only one depot To specify a user name of 'user', P4PASSWD 'pass', and port 'host:1666', use this syntax: vcp p4:user(client)password@host:1666:files Note: the password will be passed in the environment variable P4PASSWD so it shouldn't show up in error messages. This means that a password specified in a P4CONFIG file will override the password you set on the command line. This is a bug. User, client and the server string will be passed as command line options to make them show up in error output. You may use the P4... environment variables instead of any or all of the fields in the p4: repository specification. The repository spec overrides the environment variables. =head1 DESCRIPTION Driver to allow L to extract files from a L repository. Note that not all metadata is extracted: users, clients and job tracking information is not exported, and only label names are exported. Also, the 'time' and 'mod_time' attributes will lose precision, since p4 doesn't report them down to the minute. Hmmm, seems like p4 never sets a true mod_time. It gets set to either the submit time or the sync time. From C: modtime Causes 'p4 sync' to force modification time to when the file was submitted. nomodtime * Leaves modification time set to when the file was fetched. =head1 OPTIONS =over =item -b, --bootstrap -b '...' --bootstrap='...' -b file1[,file2[,...]] --bootstrap=file1[,file2[,...]] (the C<...> there is three periods, a p4 wildcard implemented by L. Forces bootstrap mode for an entire export (-b '...') or for certain files. Filenames may contain wildcards, see L for details on what wildcards are accepted. Controls how the first revision of a file is exported. A bootstrap export contains the entire contents of the first revision in the revision range. This should only be necessary when exporting for the first time. An incremental export contains a digest of the revision preceding the first revision in the revision range, followed by a delta record between that revision and the first revision in the range. This allows the destination import function to make sure that the incremental export begins where the last export left off. The default is decided on a per-file basis: if the first revision in the range is revision #1, the full contents are exported. Otherwise an incremental export is done for that file. This option is necessary when exporting only more recent revisions from a repository. =item --follow-branch-into Causes VCP to notice "branch into" messages in the filelog and, if the target revision number is #1, add the target file to the list of exported files. This usually needs a --rev-root option to set the rev root to be high enough in the directory tree to include all branches (it's an error to export a file that is not under the rev root). =item -r, --rev-root Sets the "revisions" root of the source tree being extracted; without this option, VCP assumes that you are extracting the directory tree ending in the last path segment in the filespec without a wildcard. This allows you to specify a shorter root directory, which can be useful especially with --follow-branch-into, since branches may often lead off from the current directory to peer directories or even in to entirely different trees. The default C is the file spec up to the first path segment (directory name) containing a wildcard, so p4:/a/b/c... would have a rev root of C. In direct repository-to-repository transfers, this option should not be necessary, the destination filespec overrides it. =back =head1 BRANCHES For simple p4->p4 copies, VCP should generally Do The Right Thing about branches. The facts that Cs are not always meaningful to humans or consistent across branches should not be important; VCP::Dest::p4 does not export Cs in to the target repository. For other uses, like copying to other repository types or rearranging the branching structure of a p4 repository in a p4->p4 conversion, then you need to know how VCP identifies and copies branches and how to work with them using maps to rewrite revision metadata. See the L and L chapters for details on these. The rest of this section presumes that you have read those chapters. The crux of the matter is that VCP::Source::p4 can't reliably associate meaningful or consistent Cs with all files in a repository unless all of the branch points are covered by one and only one branch specification. VCP::Source::p4 can't reliably identify directories containing what users think of as a branches from other directories. Simply put, p4 is too powerful and flexible; users can do what they want with it to and that leaves VCP unable to use directory names to intuit what constitutes a branch without making assumptions. Likewise, p4's branch specifications are optional and maleable after use so they cannot be depended upon to name branches. However, branch specifications are used where available when extracting revisions to try to give reasonable branch_ids to branched revisions. And then there's the fact that branch specifications are merely a shorthand for integrating files between branches, so the name of a branch specification is not necessarily the name you'd want associated with a brancvh. Also, a branch specification, might really define a branch per se, so you might have different files on the same branch covered by different branch specifications. Still, VCP tries to use branch specifications to assign somewhat meaningful Cs to files. When VCP finds a branch point, it hunts through all branch specs in the server looking for a match. If it finds one and only one branch spec that matches the from_file and the to_file of the file being branched, it takes the branch spec's name and uses that as the branch_id. If not, it concocts a branch name of its own. If it doesn't find an applicable branch specification, it uses a placeholder names. If it finds only one, it uses the name of the branch specification as a branch name. If it finds more than one, it errors out rather than randomly choose one. This happens before any revisions are transferred. B: This algorithm has lots of room for improvement, including the possible improvement of removing it entirely, so don't depend on it for long term, repeated conversions. As the L chapter mentions, you can alter the source repositories' branch specifications or add a Map section to the transfer specification to extract meaningful Cs if you need to. =for test_script t/90p4.t =cut $VERSION = 1.0 ; use strict ; use Carp ; use Getopt::Long ; use Fcntl qw( O_WRONLY O_CREAT ) ; use VCP::Debug ":debug" ; use Regexp::Shellish qw( :all ) ; use VCP::Branch; use VCP::Branches; use VCP::Rev ; use IPC::Run qw( run io timeout new_chunker ) ; use base qw( VCP::Source VCP::Utils::p4 ) ; use fields ( 'P4_REPO_CLIENT', ## Set by p4_parse_repo_spec in VCP::Utils::p4 'P4_INFO', ## Results of the 'p4 info' command 'P4_LABEL_CACHE', ## ->{$name}->{$rev} is a list of labels for that rev # 'P4_LABELS', ## Array of labels from 'p4 labels' 'P4_MAX', ## The last change number needed 'P4_MIN', ## The first change number needed 'P4_FOLLOW_BRANCH_INTO', ## Whether or not to follow "branch-into" events 'P4_FAKE_BRANCH_COUNTER', ## The current "fake" branch id. 'P4_BRANCH_IDS', ## a HASH keyed on in-use branch ids with undef values 'P4_BRANCH_MAPS', ## An ARRAY of ## [ $base_re, $target_re, $branch_name ] ## used to categorize branches based on what ## was branched to where. 'P4_BRANCH_SPECS', ## A HASH of branch specs by branch_id. Used to ## pass on the appropriate branch specs to the ## destination. ) ; sub new { my $class = shift ; $class = ref $class || $class ; my VCP::Source::p4 $self = $class->SUPER::new( @_ ) ; ## Parse the options my ( $spec, $options ) = @_ ; $self->parse_p4_repo_spec( $spec ) ; my $rev_root ; local *ARGV = $options; my $run_p4d; GetOptions( 'b|bootstrap:s' => sub { my ( $name, $val ) = @_ ; $self->bootstrap( $val ) ; }, 'r|rev-root:s' => \$rev_root, 'follow-branch-into' => \$self->{P4_FOLLOW_BRANCH_INTO}, 'run-p4d' => \$run_p4d, ) or $self->usage_and_exit ; $self->run_p4d if $run_p4d; $self->set_up_p4_user_and_client; my $name = $self->repo_filespec ; unless ( defined $rev_root ) { if ( length $name >= 2 && substr( $name, 0, 2 ) ne '//' ) { ## No depot on the command line, default it to the only depot ## or error if more than one. my $depots ; $self->p4( ['depots'], \$depots ) ; $depots = 'depot' unless length $depots ; my @depots = split( /^/m, $depots ) ; die "vcp: p4 has more than one depot, can't assume //depot/...\n" if @depots > 1 ; debug "vcp: defaulting depot to '$depots[0]'" if debugging $self ; $name = join( '/', '/', $depots[0], $name ) ; } $self->deduce_rev_root( $name ) ; } else { $self->rev_root( $rev_root ) ; } die "no depot name specified for p4 source '$name'\n" unless $name =~ m{^//[^/]+/} ; $self->repo_filespec( $name ) ; $self->load_p4_info ; $self->load_p4_labels ; $self->load_p4_branches ; $self->{P4_FAKE_BRANCH_COUNTER} = 0; return $self ; } sub load_p4_info { my VCP::Source::p4 $self = shift ; my $errors = '' ; $self->p4( ['info'], \$self->{P4_INFO} ) ; } sub is_incremental { my VCP::Source::p4 $self= shift ; my ( $file, $first_rev ) = @_ ; my $bootstrap_mode = $first_rev == 1 || $self->is_bootstrap_mode( $file ) ; return ! $bootstrap_mode ; } # A typical entry in the filelog looks like #-------8<-------8<------ #//revengine/revml.dtd #... #6 change 11 edit on 2000/08/28 by barries@barries (text) # # Rev 0.008: Added some modules and tests and fixed lots of bugs. # #... #5 change 10 edit on 2000/08/09 by barries@barries (text) # # Got Dest/cvs working, lots of small changes elsewhere # #-------8<-------8<------ # And, from a more tangled source tree, perl itself: #-------8<-------8<------ #... ... branch into //depot/ansiperl/x2p/a2p.h#1 #... ... ignored //depot/maint-5.004/perl/x2p/a2p.h#1 #... ... copy into //depot/oneperl/x2p/a2p.h#3 #... ... copy into //depot/win32/perl/x2p/a2p.h#2 #... #2 change 18 integrate on 1997/05/25 by mbeattie@localhost (text) # # First stab at 5.003 -> 5.004 integration. # #... ... branch into //depot/lexwarn/perl/x2p/a2p.h#1 #... ... branch into //depot/oneperl/x2p/a2p.h#1 #... ... copy from //depot/relperl/x2p/a2p.h#2 #... ... branch into //depot/win32/perl/x2p/a2p.h#1 #... #1 change 1 add on 1997/03/28 by mbeattie@localhost (text) # # Perl 5.003 check-in # #... ... branch into //depot/mainline/perl/x2p/a2p.h#1 #... ... branch into //depot/relperl/x2p/a2p.h#1 #... ... branch into //depot/thrperl/x2p/a2p.h#1 #-------8<-------8<------ # # This next regexp is used to parse the lines beginning "... #" my $filelog_rev_info_re = qr{ \G # Use with /gc!! ^\.\.\.\s+ \#(\d+)\s+ # Revision change\s+(\d+)\s+ # Change nubmer (\S+)\s+ # Action \S+\s+ ### 'on ' (\S+)\s+ # date \S+\s+ ### 'by ' (\S(?:.*?\S))\s+ # user id. Undelimited, so hope for best \((\S+?)\) # type .*\r?\n }mx ; # And this one grabs the comment my $filelog_comment_re = qr{ \G ^\r?\n ((?:^[^\S\r\n].*\r?\n)*) ^\r?\n }mx ; sub scan_filelog { my VCP::Source::p4 $self = shift ; my ( $first_change_id, $last_change_id ) = @_ ; my $log = '' ; my $delta = $last_change_id - $first_change_id + 1 ; my $spec = join( '', $self->repo_filespec . '@' . $last_change_id ) ; my @follow_ons; my %oldest_revs ; { my $log_state = "need_file" ; my VCP::Rev $r ; my $name ; my $comment ; my $p4_filelog_parser = sub { local $_ = shift ; REDO_LINE: if ( $log_state eq "need_file" ) { die "\$r defined" if defined $r ; die "vcp: p4 filelog parser: file name expected, got '$_'" unless m{^//(.*?)\r?\n\r?} ; $name = $1 ; $log_state = "revs" ; } elsif ( $log_state eq "revs" ) { if ( $r && m{^\.\.\. #} ) { $self->revs->add( $r ); $r = undef; } elsif ( m{^\.\.\.\s+\.\.\.\s*(.*?)\s*\r?\n\r?} ) { my $chunk = $1; if ( $chunk =~ /^branch from (.*)/ ) { ## Only pay attention to branch foundings return if ! $r || $r->rev_id ne "1"; my $base_spec = $1; my ( $base_name, $base_rev, $source_rev ) = $base_spec =~ m{\A([^#]+)#(\d+)(?:,#(\d+))?\z} or die "Could not parse branch from '$base_spec' for ", $r->as_string; ## TODO: $base_rev is usually #1 when a new branch ## is created, since the last "add" of the source ## file is usually #1. However, it might not be and I'm ## not sure what, if anything, should be done with it. $source_rev = $base_rev unless defined $source_rev; $r->previous_id( "$base_name#$source_rev" ); my $n = "//$name"; my %ids; for ( @{$self->{P4_BRANCH_MAPS}} ) { my ( $base_re, $target_re, $id ) = @$_; $ids{$id} = undef if $base_name =~ $base_re && $n =~ $target_re; } my $id; if ( keys %ids > 1 ) { die "Initial revision belongs to multiple branch maps (", join( ", ", sort keys %ids ), "): ", $r->as_string, "\n"; } elsif ( keys %ids == 1 ) { $id = (keys %ids)[0]; } else { ## TODO: Aggregate by some mysterious heuristic if ## a bunch of files were branched at the same ## change number? Like if all source files have a ## greatest common path prefix different from the ## gcpp of all dest files? Perhaps as an option. $id = "__branch_" . ++$self->{P4_FAKE_BRANCH_COUNTER}; } $r->branch_id( $id ); $self->{P4_BRANCH_IDS}->{$id} = undef; } elsif ( $self->{P4_FOLLOW_BRANCH_INTO} && $chunk =~ /^branch into (.*)/ ) { my $target_spec = $1; my ( $target_name, $target_rev ) = $target_spec =~ m{\A(.*)#(\d+)\z} or die "Could not parse branch into '$target_spec' for ", $r->as_string; push @follow_ons, $target_name; } ## We ignore unrecognized secondary log lines. return; } unless ( m{$filelog_rev_info_re} ) { $log_state = "need_file" ; $self->revs->add( $r ) if defined $r; $r = undef; goto REDO_LINE ; } my $rev_id = $1; my $change_id = $2; if ( $change_id < $self->min ) { undef $r ; $log_state = "need_comment" ; return ; } my $action = $3; my $user_id = $5; my $type = $6 ; my $norm_name = $self->normalize_name( $name ) ; die "\$r defined" if defined $r ; $r = VCP::Rev->new( id => "//$name#$rev_id", name => $norm_name, rev_id => $rev_id, change_id => $change_id, action => $action, time => $self->parse_time( $4 ), user_id => $user_id, p4_info => $_, comment => '', ) ; my $nr = eval { $self->revs->get_last_added( $r ) }; if ( $nr ) { $nr->previous_id( $r->id ) ; } elsif ( 0 > index $@, "t find revision" ) { die $@; } my $is_binary = $type =~ /^(?:u?x?binary|x?tempobj|resource)/ ; $r->type( $is_binary ? "binary" : "text" ) ; $r->labels( $self->get_p4_file_labels( $name, $r->rev_id ) ); ## Filelogs are in newest...oldest order, so this should catch ## the oldest revision of each file. $oldest_revs{$name} = $r ; $log_state = "need_comment" ; } elsif ( $log_state eq "need_comment" ) { unless ( /^$/ ) { die "vcp: p4 filelog parser: expected a blank line before a comment, got '$_'" ; } $log_state = "comment_accum" ; } elsif ( $log_state eq "comment_accum" ) { if ( /^$/ ) { if ( defined $r ) { $r->comment( $comment ) ; } $comment = undef ; $log_state = "revs" ; return ; } unless ( s/^\s// ) { die "vcp: p4 filelog parser: expected a comment line, got '$_'" ; } $comment .= $_ ; } else { die "unknown log_state '$log_state'" ; } } ; push @follow_ons, $spec; while ( @follow_ons ) { my $s = shift @follow_ons; $self->p4 ( [qw( filelog -m ), $delta, "-l", $s ], '>', new_chunker, $p4_filelog_parser, stderr_filter => sub { qr{//\S* - no file\(s\) at that changelist number\.\s*\r?\n} } ) ; if ( $r ) { $self->revs->add( $r ); $r = undef; } } for ( $self->revs->get ) { next unless defined $_->previous_id; ## We assume that any unfound source branches are not wanted and ## that the user intends to export a branch without its roots. my $r= eval { $self->revs->get( $_->previous_id ) }; if ( $r ) { $_->previous( $r ); } else { die $@ unless 0 < index $@, "t find revision"; $_->previous_id( undef ); } } my %visited; for ( $self->revs->get ) { next if $visited{ int $_ }++ || defined $_->branch_id; my @trail; while (1) { push @trail, $_; $_ = $_->previous; last unless $_; $visited{int $_} = 1; last if defined $_->branch_id; } if ( $_ ) { my $id = $_->branch_id; $_->branch_id( $id ) for @trail; } } die "\$r defined" if defined $r ; } my @base_rev_specs ; for my $name ( sort keys %oldest_revs ) { my $r = $oldest_revs{$name} ; my $rev_id = $r->rev_id ; if ( $self->is_incremental( "//$name", $r->rev_id ) ) { $rev_id -= 1 ; push @base_rev_specs, "//$name#$rev_id" ; } else { debug "vcp: bootstrapping '", $r->name, "#", $r->rev_id, "'" if debugging $self ; } $oldest_revs{$name} = undef ; } if ( @base_rev_specs ) { undef $log ; $self->p4( [qw( filelog -m 1 -l ), @base_rev_specs ], \$log, stderr_filter => sub { qr{//\S* - no file\(s\) at that changelist number\.\s*\r?\n} } ) ; while ( $log =~ m{\G(.*?)^//(.*?)\r?\n\r?}gmsc ) { warn "vcp: Ignoring '$1' in p4 filelog output\n" if length $1 ; my $name = $2 ; my $norm_name = $self->normalize_name( $name ) ; while () { next if $log =~ m{\G^\.\.\.\s+\.\.\..*\r?\n\r?}gmc ; last unless $log =~ m{$filelog_rev_info_re}gc ; my VCP::Rev $br = VCP::Rev->new( id => "//$name#$1", name => $norm_name, rev_id => $1, change_id => $2, # Don't send these on a base rev for incremental changes: # action => $3, # time => $self->parse_time( $4 ), # user_id => $5, type => $6, # comment => '', ) ; my $nr = eval { $self->revs->get_last_added( $br ) }; if ( $nr ) { $nr->previous_id( $br->id ) ; $nr->previous( $br ) ; } elsif ( 0 > index $@, "t find revision" ) { die $@; } $self->revs->add( $br ) ; $log =~ m{$filelog_comment_re}gc ; } } } } sub min { my VCP::Source::p4 $self = shift ; $self->{P4_MIN} = shift if @_ ; return $self->{P4_MIN} ; } sub max { my VCP::Source::p4 $self = shift ; $self->{P4_MAX} = shift if @_ ; return $self->{P4_MAX} ; } # $ p4 labels # Label P98.2 1999/06/14 'Perforce98.2-compatible scripts & source files. ' # Label P99.1 1999/06/14 'Perforce99.1-compatible scripts & source files. ' # Label PerForte-1-0 2002/02/27 'Initial version from Axel Wienberg. Created by david_rees. ' # Label PerForte-1-1 2002/02/28 'Created by david_rees. ' # Label jam2-2-0 1998/09/24 'Jam/MR 2.2 ' # Label jam2-2-4 1998/09/24 'Jam/MR 2.2.4 ' # Label vcp_00_02 2000/12/11 'VCP release 0.02. ' # Label vcp_00_03 2000/12/11 'VCP Release 0.03 ' # Label vcp_00_04 2000/12/19 'VCP release 0.4 ' # Label vcp_00_05 2000/12/19 'VCP release 0.05 ' # Label vcp_00_06 2000/12/20 'VCP Release 0.06 ' # Label vcp_00_068 2001/05/21 'VCP version v0.068 ' # Label vcp_00_07 2002/07/17 'VCP release v0.07 ' # Label vcp_00_08 2001/05/23 'VCP release 0.08 ' # Label vcp_00_09 2001/05/30 'Created by barrie_slaymaker. ' # Label vcp_00_091 2001/06/07 'vcp release 0.091 ' # Label vcp_00_1 2001/07/03 'VCP release 0.1 ' # Label vcp_00_2 2001/07/18 'VCP release 0.2. ' # Label vcp_00_21 2001/07/20 'VCP release 0.21 ' # Label vcp_00_22 2001/12/18 'VCP release 0.22 ' # Label vcp_00_221 2001/07/30 'VCP Release 0.221 ' # Label vcp_00_26 2001/12/18 'VCP release 0.26 ' # Label vcp_00_28 2002/04/30 'VCP release 0.28 ' # Label vcp_00_30 2002/05/24 'VCP release 0.3 ' sub load_p4_labels { my VCP::Source::p4 $self = shift ; my $labels = '' ; my $errors = '' ; $self->p4( ['labels'], \$labels ) ; my @labels = map( /^Label\s*(\S*)/ ? $1 : (), split( /^/m, $labels ) ) ; my $marker = "//.../NtLkly" ; my $p4_files_args = join( "", ( map { ( "$marker\n", "//...\@$_\n" ) ; } @labels ), ) ; $self->p4( [ qw( -x - -s files) ], "<", \$p4_files_args, ## Need explicit "<" to feed stdin ">", \my $files, ok_result_codes => [ 0, 1 ], ); my $label ; for my $spec ( split /\n/m, $files ) { last if $spec =~ /^exit:/ ; if ( $spec =~ /^error: $marker/o ) { $label = shift @labels ; next ; } next if $spec =~ m{^error: //\.\.\.\@.+ file(\(s\))? not in label.$} ; $spec =~ /^.*?: *\/\/(.*)#(\d+)/ or die "Couldn't parse name & rev from '$spec' in '$files'" ; debug "vcp: p4 label '$label' => '$1#$2'" if debugging $self ; push @{$self->{P4_LABEL_CACHE}->{$1}->{$2}}, $label ; } return ; } # $ p4 branches # Branch BoostJam 2001/11/12 'Created by david_abrahams. ' # Branch P4DB_2.1 2002/07/07 'P4DB Version 2.1 ' # Branch gjam 2000/03/22 'Created by grant_glouser to branch the jam sources. ' # Branch jab_triggers 1999/03/18 'Created by jeff_bowles. ' # Branch java_reviewer 2002/08/12 'Created by david_markley. ' # Branch lw2pub 1999/06/18 'Created by laura_wingerd. ' # Branch mwm2pub 1999/06/18 'Created by laura_wingerd. ' # Branch p4hltest 2002/04/24 'Branch for testing FileLogCache stuff out. ' # Branch p4jsp 2002/07/30 'p4jsp to public depot ' # Branch p4package 2001/11/05 'Created by david_markley. ' # Branch scouten-jam 2000/08/18 'ES version of jam. ' # Branch scouten-webkeeper 2000/03/01 'ES version of webkeeper. ' # Branch srv_webkeep_guest_to_main 2001/09/04 'Created by stephen_vance. ' # Branch steve_howell_util 1998/12/31 'Created by steve_howell. ' # Branch tq_cvs2p4 2000/09/09 'Created by thomas_quinot. ' # Branch vsstop4_rc2ps 2002/03/06 'for pulling Roberts branch into mine ' sub load_p4_branches { my VCP::Source::p4 $self = shift ; $self->p4( ['branches'], \my $branches ) ; my @branches = map /^Branch\s*(\S*)/ ? $1 : (), split /^/m, $branches; my $shellish_opts = { star_star => 0 }; for ( @branches ) { $self->p4( ['branch', '-o', $_ ], ">", \my $branch_spec ); $self->{P4_BRANCH_SPECS}->{$_} = $branch_spec; my %branch = $self->parse_p4_form( $branch_spec ); for ( split /\n/, $branch{View} ) { next unless length; my ( $source, $dest ) = split /\s+/, $_, 2; my $source_re = compile_shellish( $source, $shellish_opts ); my $dest_re = compile_shellish( $dest , $shellish_opts ); push @{$self->{P4_BRANCH_MAPS}}, [ $source_re, $dest_re, $branch{Branch} ]; } } return ; } sub denormalize_name { my VCP::Source::p4 $self = shift ; my $fn = $self->SUPER::denormalize_name( @_ ); $fn =~ s{^/*}{//}; return $fn; } sub get_p4_file_labels { my VCP::Source::p4 $self = shift ; my $name ; my VCP::Rev $rev ; ( $name, $rev ) = @_ ; return ( ( exists $self->{P4_LABEL_CACHE}->{$name} && exists $self->{P4_LABEL_CACHE}->{$name}->{$rev} ) ? @{$self->{P4_LABEL_CACHE}->{$name}->{$rev}} : () ) ; } my $filter_prog = <<'EOPERL' ; use strict ; my ( $name, $working_path ) = ( shift, shift ) ; } EOPERL sub get_rev { my VCP::Source::p4 $self = shift ; my VCP::Rev $r ; ( $r ) = @_ ; return if defined $r->action && $r->action eq "delete" ; my $fn = $r->name ; my $rev = $r->rev_id ; $r->work_path( $self->work_path( $fn, $rev ) ) ; my $wp = $r->work_path ; $self->mkpdir( $wp ) ; my $denormalized_name = $self->denormalize_name( $fn ) ; my $rev_spec = "$denormalized_name#$rev" ; sysopen( WP, $wp, O_CREAT | O_WRONLY ) or die "$!: $wp" ; binmode WP ; my $re = quotemeta( $rev_spec ) . " - .* change \\d+ \\((.+)\\)"; ## TODO: look for "+x" in the (...) and pass an executable bit ## through the rev structure. $self->p4( [ "print", $rev_spec ], ">", sub { $_ = shift ; s/\A$re\r?\n//m if $re ; $re = undef ; print WP or die "$! writing to $wp" ; }, ) ; close WP or die "$! closing wp" ; return ; } sub handle_header { my VCP::Source::p4 $self = shift ; my ( $header ) = @_ ; $header->{rep_type} = 'p4' ; $header->{rep_desc} = $self->{P4_INFO} ; $header->{rev_root} = $self->rev_root ; $self->revs( VCP::Revs->new ) ; $self->scan_filelog( $self->min, $self->max ) ; if ( $self->{P4_BRANCH_IDS} ) { $header->{branches} = VCP::Branches->new; $header->{branches}->add( VCP::Branch->new( branch_id => $_, p4_branch_spec => $self->{P4_BRANCH_SPECS}->{$_}, ) ) for sort keys %{$self->{P4_BRANCH_IDS}}; } $self->dest->handle_header( $header ) ; return ; } sub copy_revs { my VCP::Source::p4 $self = shift ; $self->dest->sort_revs( $self->revs ) ; ## Discard the revs so they'll be DESTROYed and thus ## clean up after themselves. my $metadata_only = $self->dest->metadata_only; while ( my VCP::Rev $r = $self->revs->shift ) { $self->get_rev( $r ) unless $metadata_only; $self->dest->handle_rev( $r ) ; } } =head1 LIMITATIONS Treats each branched file as a separate branch with a unique branch_id, although files that are branched together should end up being submitted together in the destination repository due to change number aggregation. Ignores branch specs for now. There may be an option to enable automatic use of branch specs because most are probably well behaved. However, in the event of a branch spec being altered after the original branch, this could lead to odd results. Not sure how useful branch specs are vs. how likely a problem this is to be. We may also want to support "external" branch specs to allow deleted branch specs to be used. =head1 SEE ALSO L, L. =head1 AUTHOR Barrie Slaymaker =head1 COPYRIGHT Copyright (c) 2000, 2001, 2002 Perforce Software, Inc. All rights reserved. See L (C) for the terms of use. =cut 1