1package VCP::Source::p4; 2 3=head1 NAME 4 5VCP::Source::p4 - A Perforce p4 repository source 6 7=head1 SYNOPSIS 8 9 vcp p4://depot/...@10 # all files after change 10 applied 10 vcp p4://depot/...@1,10 # changes 1..10 11 vcp p4://depot/...@-2,10 # changes 8..10 12 vcp p4://depot/...@1,#head # changes 1..#head 13 vcp p4://depot/...@-2,#head # changes 8..10 14 vcp p4:...@-2,#head # changes 8..10, if only one depot 15 16To specify a user name of 'user', P4PASSWD 'pass', port 'host:1666', 17and p4 client 'client' use this syntax: 18 19 vcp p4:user(client):pass@host:1666:files 20 21Or, to run against a private p4d in a local directory, use this syntax 22and the --run-p4d option: 23 24 vcp p4:user(client):pass@/dir:files 25 vcp p4:user(client):pass@/dir:1666:files 26 27Note: VCP will set the environment variable P4PASSWD rather than 28sending the password to p4 via the command line, so it shouldn't show 29up in error messages. This means that a password specified in a 30P4CONFIG file will override the one set on the VCP command line. This 31is a bug. User, client and the server string will be passed as 32command line options to make them show up in error output. 33 34You may use the P4... environment variables instead of any or all of the 35fields in the p4: repository specification. The repository spec 36overrides the environment variables. 37 38If the L<P4::Client> Perl module is installed, this will be used instead 39of the p4 command line utility. If this causes undesirable results, set 40the environment variable VCPP4API equal to "0" (zero). 41 42=head1 DESCRIPTION 43 44Driver to allow L<vcp|vcp> to extract files from a 45L<Perforce|http://perforce.com/> repository. 46 47Note that not all metadata is extracted: users, clients and job tracking 48information is not exported, and only label names are exported. 49 50Also, the 'time' and 'mod_time' attributes will lose precision, since 51p4 doesn't report them down to the minute. Hmmm, seems like p4 never 52sets a true mod_time. It gets set to either the submit time or the 53sync time. From C<p4 help client>: 54 55 modtime Causes 'p4 sync' to force modification time 56 to when the file was submitted. 57 58 nomodtime * Leaves modification time set to when the 59 file was fetched. 60 61=head1 OPTIONS 62 63See also the OPTIONS sections in L<VCP::Source|VCP::Source/OPTIONS> 64and L<VCP::Driver/OPTIONS>. 65 66=over 67 68=item --run-p4d 69 70Runs a p4d instance in the directory indicated by repo_server (use a 71directory path rather than a host name). If repo_server contains a 72port, that port will be used, otherwise a random port will be used. 73 74Dies unless the directory exists and contains files matching db.* (to 75help prevent unexpected initializing of empty directories). 76 77VCP will kill this p4d when it's done. 78 79=item --follow-branch-into 80 81Causes VCP to notice "branch into" messages in the output of p4's 82filelog command and. If the file that's the target of the p4 83integrate (branch) command is revision number #1, adds the target to 84the list of exported files. This usually needs a --rev-root option to 85set the rev root to be high enough in the directory tree to include 86all branches (it's an error to export a file that is not under the rev 87root). 88 89=item --rev-root 90 91Sets the "revisions" root of the source tree being extracted; without this 92option, VCP assumes that you are extracting the directory tree ending in the 93last path segment in the filespec without a wildcard. This allows you to 94specify a shorter root directory, which can be useful especially with 95--follow-branch-into, since branches may often lead off from the current 96directory to peer directories or even in to entirely different trees. 97 98The default C<rev-root> is the file spec up to the first path segment 99(directory name) containing a wildcard, so 100 101 p4:/a/b/c... 102 103would have a rev root of C</a/b>. 104 105In direct repository-to-repository transfers, this option should not be 106necessary, the destination filespec overrides it. 107 108=back 109 110=head1 BRANCHES 111 112VCP uses the "directory" name of each file as the file's branch_id. 113VCP ignores p4 branch specs for several reasons: 114 115=over 116 117=item 1 118 119Branch specs are not version controlled, which means that you can't tell 120what a branch spec looked like when a branch was created. 121 122=item 2 123 124Multiple branch specs can point to the same directory or even the same file. 125 126=item 3 127 128branch specs are not necessary in managing a p4 repository. 129 130=back 131 132TODO: build a filter or VCP::Source::p4 option that allows p4 branch 133specifications to determine branch_ids. 134 135As the L<VCP Branches|VCP::Branches> chapter mentions, you can use a Map 136section in the transfer specification to extract meaningful C<branch_id>s if 137you need to. 138 139=for test_script t/9*p4.t 140 141=cut 142 143$VERSION = 1.0 ; 144 145@ISA = qw( VCP::Source VCP::Utils::p4 ); 146 147use strict ; 148 149use Carp ; 150use Fcntl qw( O_WRONLY O_CREAT ) ; 151use File::Basename; 152use VCP::Debug ":debug" ; 153use VCP::Logger qw( lg BUG pr pr_doing pr_done ); 154use VCP::Rev; 155use VCP::Source; 156use VCP::Utils qw( empty is_win32 ); 157use VCP::Utils::p4; 158 159#use base qw( VCP::Source VCP::Utils::p4 ) ; 160#use fields ( 161# 'P4_REPO_CLIENT', ## Set by p4_parse_repo_spec in VCP::Utils::p4 162# 'P4_REP_DESC', ## Results of the 'p4 info' command 163# 'P4_RUN_P4D', ## whether --run-p4d specified 164# 'P4_LABEL_CACHE', ## ->{$name}->{$rev} is a list of labels for that rev 165# 'P4_MAX', ## The last change number needed 166# 'P4_MIN', ## The first change number needed 167# 'P4_FOLLOW_BRANCH_INTO', ## Whether or not to follow "branch-into" events 168# 169# 'P4_SPECS_TO_SCAN', ## Filespecs for sets of files to scan. 170# ## Starts with the user provided spec, then 171# ## grows as branches are found if 172# ## P4_FOLLOW_BRANCH_INTO is set. 173# 174# 'P4_BRANCH_SPECS', ## A HASH of branch specs by branch_id. Used to 175# ## pass on the appropriate branch specs to the 176# ## destination. 177#) ; 178 179 180sub new { 181 my $self = shift->SUPER::new; 182 183 ## Parse the options 184 my ( $spec, $options ) = @_ ; 185 186 $self->parse_p4_repo_spec( $spec ) 187 unless empty $spec; 188 189 $self->parse_options( $options ); 190 191 return $self ; 192} 193 194 195sub DESTROY { 196 my $self = shift; 197 if ( $self->rev_labels_db ) { 198 $self->rev_labels_db->close_db; 199 $self->rev_labels_db->delete_db; 200 } 201} 202 203 204sub options_spec { 205 my $self = shift; 206 return ( 207 $self->SUPER::options_spec, 208 'follow-branch-into' => \$self->{P4_FOLLOW_BRANCH_INTO}, 209 'run-p4d' => \$self->{P4_RUN_P4D}, 210 ); 211} 212 213 214sub init { 215 my $self = shift ; 216 217 $self->SUPER::init; 218 219 my $repo_server = $self->repo_server; 220 $repo_server = $ENV{P4PORT} unless defined $repo_server; 221 die 'P4PORT not set\n' if empty $repo_server; 222 223 $self->repo_id( "p4:$repo_server" ) 224 if empty $self->repo_id; 225 226 227 $self->run_p4d if $self->{P4_RUN_P4D}; 228 229 $self->set_up_p4_user_and_client; 230 231 my $name = $self->repo_filespec ; 232 if ( length $name >= 2 && substr( $name, 0, 2 ) ne '//' ) { 233 ## No depot on the command line, default it to the only depot 234 ## or error if more than one. 235 my $depots ; 236 $self->p4( ['depots'], undef, \$depots ) ; 237 $depots = 'depot' unless length $depots ; 238 my @depots = split( /^/m, $depots ) ; 239 die "p4 has more than one depot, can't assume //depot/...\n" 240 if @depots > 1 ; 241 lg "defaulting depot to '$depots[0]'"; 242 $name = join( '/', '/', $depots[0], $name ) ; 243 } 244 245 $self->deduce_rev_root( $name ) 246 if empty $self->rev_root; 247 248 die "no depot name specified for p4 source '$name'\n" 249 unless $name =~ m{^//[^/]+/} ; 250 $self->repo_filespec( $name ) ; 251 252 $self->load_p4_info ; 253 $self->load_p4_branches ; 254 255 warn "vcp: METADATA LOSS WARNING: p4 server version ", 256 $self->p4_server_version_number, 257 " does not export submit times (no filelog -t option)\n" 258 unless $self->has_filelog_t_option; 259 260} 261 262 263sub ui_set_p4d_dir { 264 my $self = shift; 265 my ($dir) = @_; 266 $self->repo_server( $dir ); 267 268 die "Warning: '$dir' not found!\n" 269 unless -e $dir; 270 die "Error: '$dir' exists, but is not a directory.\n" 271 unless -d $dir; 272} 273 274 275## Note: the next two routins are designed to be factored in to 276## VCP::Utils::p4 if & when the dest needs them. 277sub load_p4_info { 278 my $self = shift ; 279 280 my $errors = '' ; 281 $self->p4( ['info'], undef, \$self->{P4_REP_DESC} ) ; 282} 283 284 285sub p4_server_version_number { 286 my $self = shift; 287 die "No \"p4 info\" output to get server version from\n" 288 if empty $self->{P4_REP_DESC}; 289 die "Can't parse server version from \"p4 info\" output:\n", 290 $self->{P4_REP_DESC} 291 unless $self->{P4_REP_DESC} 292 =~ m{^Server\s+version:.*\/([12]\d{3}\.\d+)/}m; 293 return $1; 294} 295 296 297sub has_filelog_t_option { 298 my $self = shift; 299 $self->{P4_HAS_FILELOG_T_OPTION} = 300 ($self->p4_server_version_number ge "2002.2") 301 unless defined $self->{P4_HAS_FILELOG_T_OPTION}; 302 return $self->{P4_HAS_FILELOG_T_OPTION}; 303} 304 305 306# A typical entry in the filelog looks like 307#-------8<-------8<------ 308#//revengine/revml.dtd 309#... #6 change 11 edit on 2000/08/28 by barries@barries (text) 310# 311# Rev 0.008: Added some modules and tests and fixed lots of bugs. 312# 313#... #5 change 10 edit on 2000/08/09 by barries@barries (text) 314# 315# Got Dest/cvs working, lots of small changes elsewhere 316# 317#-------8<-------8<------ 318# And, from a more tangled source tree, perl itself: 319#-------8<-------8<------ 320#... ... branch into //depot/ansiperl/x2p/a2p.h#1 321#... ... ignored //depot/maint-5.004/perl/x2p/a2p.h#1 322#... ... copy into //depot/oneperl/x2p/a2p.h#3 323#... ... copy into //depot/win32/perl/x2p/a2p.h#2 324#... #2 change 18 integrate on 1997/05/25 by mbeattie@localhost (text) 325# 326# First stab at 5.003 -> 5.004 integration. 327# 328#... ... branch into //depot/lexwarn/perl/x2p/a2p.h#1 329#... ... branch into //depot/oneperl/x2p/a2p.h#1 330#... ... copy from //depot/relperl/x2p/a2p.h#2 331#... ... branch into //depot/win32/perl/x2p/a2p.h#1 332#... #1 change 1 add on 1997/03/28 by mbeattie@localhost (text) 333# 334# Perl 5.003 check-in 335# 336#... ... branch into //depot/mainline/perl/x2p/a2p.h#1 337#... ... branch into //depot/relperl/x2p/a2p.h#1 338#... ... branch into //depot/thrperl/x2p/a2p.h#1 339#-------8<-------8<------ 340# 341# This next regexp is used to parse the lines beginning "... #" 342 343my $filelog_rev_info_re = qr{ 344 \G # Use with /gc!! 345 ^\.\.\.\s+ 346 \#(\d+)\s+ # Revision 347 change\s+(\d+)\s+ # Change nubmer 348 (\S+)\s+ # Action 349 on\s+ ### 'on ' 350 ([\d/]+(?:\s[\d:]+)?)\s+ # date/date-time 351 by\s+ ### 'by ' 352 (\S(?:.*?\S))\s+ # user id. Undelimited, so hope for best 353 \((\S+?)\) # type 354 .*\r?\n 355}mx ; 356 357# And this one grabs the comment 358my $filelog_comment_re = qr{ 359 \G 360 ^\r?\n 361 ((?:^[^\S\r\n].*\r?\n)*) 362 ^\r?\n 363}mx ; 364 365 366sub add_rev { 367 my $self = shift ; 368 my ( $r ) = @_; 369 370 my $mode = $self->rev_mode( $r->source_filebranch_id, $r->rev_id ); 371 372 return unless $mode; 373 374 $r->base_revify if $mode eq "base"; 375 376 $self->queue_rev( $r ); 377} 378 379 380sub p4_filelog_parser { 381 my $self = shift; 382 my ( $fh ) = @_; 383 384 my $r ; 385 my $name ; 386 my $comment ; 387 388 local $_; 389 390 my $log_state = "need_file" ; 391 while ( <$fh> ) { 392 if ( debugging ) { 393 my $l = $_; 394 1 while chomp $l; 395 debug "$log_state: [$l]"; 396 } 397 REDO_LINE: 398 if ( $log_state eq "need_file" ) { 399 die "\$r defined" if defined $r ; 400 die "p4 filelog parser: file name expected, got '$_'" 401 unless m{^//(.*?)\r?\n\r?} ; 402 403 $name = $1 ; 404 $log_state = "revs" ; 405 } 406 elsif ( $log_state eq "revs" ) { 407 if ( $r && m{^\.\.\. #} ) { 408 $self->add_rev( $r ); 409 $r = undef; 410 } 411 elsif ( m{^\.\.\.\s+\.\.\.\s*(.*?)\s*\r?\n\r?} ) { 412 my $chunk = $1; 413 if ( $chunk =~ /^branch from (.*)/ ) { 414 ## Only pay attention to branch foundings 415 next if ! $r || $r->rev_id ne "1"; 416 417 my $base_spec = $1; 418 my ( $base_name, $base_rev, $source_rev ) = 419 $base_spec =~ m{\A([^#]+)#(\d+)(?:,#(\d+))?\z} 420 or die "Could not parse branch from '$base_spec' for ", 421 $r->as_string; 422 ## TODO: $base_rev is usually #1 when a new branch 423 ## is created, since the last "add" of the source 424 ## file is usually #1. However, it might not be and I'm 425 ## not sure what, if anything, should be done with it. 426 $source_rev = $base_rev unless defined $source_rev; 427 $r->previous_id( "$base_name#$source_rev" ); 428 } 429 elsif ( $self->{P4_FOLLOW_BRANCH_INTO} 430 && $chunk =~ /^branch into (.*)/ 431 ) { 432 my $target_spec = $1; 433 my ( $target_name, $target_rev ) = 434 $target_spec =~ m{\A(.*)#(\d+)\z} 435 or die"Could not parse branch into '$target_spec' for ", 436 $r->as_string; 437 push @{$self->{P4_SPECS_TO_SCAN}}, $target_name; 438 } 439 ## We ignore unrecognized secondary log lines. 440 next; 441 } 442 443 unless ( m{$filelog_rev_info_re} ) { 444 $log_state = "need_file" ; 445 $self->add_rev( $r ) if defined $r; 446 $r = undef; 447 goto REDO_LINE ; 448 } 449 450 my $rev_id = $1; 451 my $change_id = $2; 452 my $action = $3; 453 my $time = $4; 454 my $user_id = $5; 455 my $type = $6 ; 456 457 if ( $change_id < $self->min ) { 458 undef $r ; 459 $log_state = "need_comment" ; 460 next; 461 } 462 463 $user_id =~ s/\@(.*)//; 464 my $client = $1; 465 466 my $norm_name = $self->normalize_name( $name ) ; 467 die "\$r defined" if defined $r ; 468 469 my $p4_name = "//$name"; 470 my $id = "$p4_name#$rev_id"; 471 472 my $branch_id = (fileparse $p4_name )[1]; 473 474 $type = $type =~ /^(?:u?x?binary|x?tempobj|resource)/ 475 ? "binary" 476 : "text"; 477 478 $action = "edit" 479 if $action !~ /^(add|branch|delete)$/; 480 ## There are only add, branch, edit and delete actions 481 ## in VCP::Dest::* drivers at this time. 482 483 484 $r = VCP::Rev->new( 485 id => $id, 486 action => $action, 487 name => $norm_name, 488 source_name => $norm_name, 489 source_filebranch_id => $p4_name, 490 branch_id => $branch_id, 491 source_branch_id => $branch_id, 492 source_repo_id => $self->repo_id, 493 rev_id => $rev_id, 494 source_rev_id => $rev_id, 495 change_id => $change_id, 496 source_change_id => $change_id, 497 time => $self->parse_time( $time ), 498 user_id => $user_id, 499 $action ne "branch" 500 ? ( 501 p4_info => $_, 502 type => $type, 503 ) 504 : (), 505 comment => '', 506 ); 507 508 $self->set_last_rev_in_filebranch_previous_id( $r ); 509 510 $r->set_labels( $self->get_rev_labels( $id ) ); 511 512 $log_state = "need_comment" ; 513 } 514 elsif ( $log_state eq "need_comment" ) { 515 unless ( /^\r?\n/ ) { 516 die 517"p4 filelog parser: expected a blank line before a comment, got '$_'" ; 518 } 519 $log_state = "comment_accum" ; 520 } 521 elsif ( $log_state eq "comment_accum" ) { 522 if ( /^\r?\n/ ) { 523 if ( defined $r ) { 524 $r->comment( $comment ) ; 525 } 526 $comment = undef ; 527 $log_state = "revs" ; 528 next; 529 } 530 unless ( s/^\s// ) { 531 die "p4 filelog parser: expected a comment line, got '$_'" ; 532 } 533 s/\r\n$/\n/ if is_win32; 534 $comment .= $_ ; 535 } 536 else { 537 die "unknown log_state '$log_state'" ; 538 } 539 } 540 541 if ( $r ) { 542 $self->add_rev( $r ); 543 $r = undef; 544 } 545} 546 547 548sub scan_metadata { 549 my $self = shift ; 550 551 my ( $first_change_id, $last_change_id ) = ( $self->min, $self->max ) ; 552 553 my $delta = $last_change_id - $first_change_id + 1 ; 554 555 my $spec = join( '', $self->repo_filespec, '@', $last_change_id ) ; 556 557 $self->{P4_SPECS_TO_SCAN} = [ $spec ]; 558 559 my @opts; 560 push @opts, "-t" if $self->has_filelog_t_option; 561 562 while ( @{$self->{P4_SPECS_TO_SCAN}} ) { 563 my $s = shift @{$self->{P4_SPECS_TO_SCAN}}; 564 565 $self->p4( 566 [ "filelog", "-m", $delta, @opts, "-l", $s ], 567 undef, 568 sub { $self->p4_filelog_parser( @_ ) }, 569 { 570 stderr_filter => 571 sub { qr{//\S* - no file\(s\) at that changelist number\.\s*\r?\n} } 572 } 573 ) ; 574 575 } 576 577 pr "found " . $self->queued_rev_count, " revisions"; 578} 579 580 581sub min { 582 my $self = shift ; 583 $self->{P4_MIN} = shift if @_ ; 584 return $self->{P4_MIN} ; 585} 586 587 588sub max { 589 my $self = shift ; 590 $self->{P4_MAX} = shift if @_ ; 591 return $self->{P4_MAX} ; 592} 593 594# $ p4 labels 595# Label P98.2 1999/06/14 'Perforce98.2-compatible scripts & source files. ' 596# Label P99.1 1999/06/14 'Perforce99.1-compatible scripts & source files. ' 597# Label PerForte-1-0 2002/02/27 'Initial version from Axel Wienberg. Created by david_rees. ' 598# Label PerForte-1-1 2002/02/28 'Created by david_rees. ' 599# Label jam2-2-0 1998/09/24 'Jam/MR 2.2 ' 600# Label jam2-2-4 1998/09/24 'Jam/MR 2.2.4 ' 601# Label vcp_00_02 2000/12/11 'VCP release 0.02. ' 602# Label vcp_00_03 2000/12/11 'VCP Release 0.03 ' 603# Label vcp_00_04 2000/12/19 'VCP release 0.4 ' 604# Label vcp_00_05 2000/12/19 'VCP release 0.05 ' 605# Label vcp_00_06 2000/12/20 'VCP Release 0.06 ' 606# Label vcp_00_068 2001/05/21 'VCP version v0.068 ' 607# Label vcp_00_07 2002/07/17 'VCP release v0.07 ' 608# Label vcp_00_08 2001/05/23 'VCP release 0.08 ' 609# Label vcp_00_09 2001/05/30 'Created by barrie_slaymaker. ' 610# Label vcp_00_091 2001/06/07 'vcp release 0.091 ' 611# Label vcp_00_1 2001/07/03 'VCP release 0.1 ' 612# Label vcp_00_2 2001/07/18 'VCP release 0.2. ' 613# Label vcp_00_21 2001/07/20 'VCP release 0.21 ' 614# Label vcp_00_22 2001/12/18 'VCP release 0.22 ' 615# Label vcp_00_221 2001/07/30 'VCP Release 0.221 ' 616# Label vcp_00_26 2001/12/18 'VCP release 0.26 ' 617# Label vcp_00_28 2002/04/30 'VCP release 0.28 ' 618# Label vcp_00_30 2002/05/24 'VCP release 0.3 ' 619 620sub load_p4_labels { 621 my $self = shift ; 622 623 my $labels = '' ; 624 my $errors = '' ; 625 pr "running p4 labels"; 626 $self->p4( ['labels'], undef, \$labels ) ; 627 628 my @labels = map( 629 /^Label\s*(\S*)/ ? $1 : (), 630 split( /^/m, $labels ) 631 ) ; 632 633 if ( @labels ) { 634 my $marker = "//.../NtLkly" ; 635 636 pr_doing "running p4 files to find labelled files: "; 637 $self->p4_x( 638 [ "-s", "files" ], 639 [ 640 map { 641 ( "$marker\n", "//...\@$_\n" ) ; 642 } @labels, 643 ], 644 \my $files, 645 { ok_result_codes => [ 0, 1 ] }, 646 ); 647 648 my $label ; 649 for my $spec ( split /\r?\n/m, $files ) { 650 pr_doing; 651 last if $spec =~ /^exit:/ ; 652 if ( $spec =~ /^error: $marker/o ) { 653 $label = shift @labels ; 654 next ; 655 } 656 next if $spec =~ m{^error: //\.\.\.\@.+ file(\(s\))?( not in label.)?$}; 657 next if $spec =~ m{^error: //\.\.\..+ - no such file\(s\)\.}; 658 $spec =~ /^.*?: *(\/\/.*#\d+)/ 659 or die "Couldn't parse name & rev from '$spec' in p4 output:\n$files\n" ; 660 my $id = $1; 661 662 debug "p4 label '$label' => '$id'" if debugging ; 663 $self->rev_labels_db->set( 664 [ $id ], 665 $self->rev_labels_db->get( [ $1 ] ), $label 666 ); 667 } 668 pr_done; 669 } 670 671 return ; 672} 673 674 675# $ p4 branches 676# Branch BoostJam 2001/11/12 'Created by david_abrahams. ' 677# Branch P4DB_2.1 2002/07/07 'P4DB Version 2.1 ' 678# Branch gjam 2000/03/22 'Created by grant_glouser to branch the jam sources. ' 679# Branch jab_triggers 1999/03/18 'Created by jeff_bowles. ' 680# Branch java_reviewer 2002/08/12 'Created by david_markley. ' 681# Branch lw2pub 1999/06/18 'Created by laura_wingerd. ' 682# Branch mwm2pub 1999/06/18 'Created by laura_wingerd. ' 683# Branch p4hltest 2002/04/24 'Branch for testing FileLogCache stuff out. ' 684# Branch p4jsp 2002/07/30 'p4jsp to public depot ' 685# Branch p4package 2001/11/05 'Created by david_markley. ' 686# Branch scouten-jam 2000/08/18 'ES version of jam. ' 687# Branch scouten-webkeeper 2000/03/01 'ES version of webkeeper. ' 688# Branch srv_webkeep_guest_to_main 2001/09/04 'Created by stephen_vance. ' 689# Branch steve_howell_util 1998/12/31 'Created by steve_howell. ' 690# Branch tq_cvs2p4 2000/09/09 'Created by thomas_quinot. ' 691# Branch vsstop4_rc2ps 2002/03/06 'for pulling Roberts branch into mine ' 692 693sub load_p4_branches { 694# my $self = shift ; 695# 696# pr "running p4 branches"; 697# $self->p4( ['branches'], undef, \my $branches ) ; 698# 699# my @branches = map 700# /^Branch\s*(\S*)/ ? $1 : (), 701# split /^/m, $branches; 702# 703# for ( @branches ) { 704# $self->p4( ['branch', '-o', $_ ], undef, \my $branch_spec ); 705# $self->{P4_BRANCH_SPECS}->{$_} = $branch_spec; 706# } 707# 708# return ; 709} 710 711 712sub denormalize_name { 713 my $self = shift ; 714 my $fn = $self->SUPER::denormalize_name( @_ ); 715 $fn =~ s{^/*}{//}; 716 return $fn; 717} 718 719 720sub rev_labels_db { 721 return shift->{REV_LABELS_DB}; 722} 723 724 725sub get_rev_labels { 726 my $self = shift ; 727 728 my ( $id ) = @_ ; 729 return $self->rev_labels_db->get( [ $id ] ); 730} 731 732 733my $filter_prog = <<'EOPERL' ; 734 use strict ; 735 my ( $name, $working_path ) = ( shift, shift ) ; 736 } 737EOPERL 738 739 740sub get_source_file { 741 my $self = shift ; 742 743 my $r ; 744 745 ( $r ) = @_ ; 746 BUG "can't check out ", $r->as_string, "\n" 747 unless $r->is_real_rev; 748 ## Note that "integrate" is treated as an "edit" for this version 749 ## of VCP 750 751 my $fn = $r->source_name ; 752 my $rev = $r->source_rev_id ; 753 754 my $wp = $self->work_path( $fn, $rev ); 755 $self->mkpdir( $wp ) ; 756 die "$wp already exists\n" 757 if -f $wp; 758 759 my $p4_work_path = $self->work_path( "co", $fn ); 760 my $rev_spec = "$p4_work_path#$rev" ; 761 762 ## TODO: look for "+x" in the (...) and pass an executable bit 763 ## through the rev structure. 764 $self->p4( [ "sync", "-f", $rev_spec ] ) ; 765 766 die "$p4_work_path not created by sync -v $rev_spec\n" 767 unless -f $p4_work_path; 768 769 link $p4_work_path, $wp or die "$! linking $p4_work_path to $wp\n"; 770 771# close WP or die "$! closing wp" ; 772 return $wp; 773} 774 775 776sub handle_header { 777 my $self = shift ; 778 my ( $header ) = @_ ; 779 780 $header->{rep_type} = 'p4' ; 781 $header->{rep_desc} = $self->{P4_REP_DESC} ; 782 $header->{rev_root} = $self->rev_root ; 783 784 my $tmp_db_loc = $self->tmp_dir; 785 786 $self->{REV_LABELS_DB} = VCP::DB_File::big_records->new( 787 StoreLoc => $tmp_db_loc, 788 TableName => "rev_labels", 789 ); 790 791 $self->rev_labels_db->delete_db; 792 $self->rev_labels_db->open_db; 793 $self->load_p4_labels ; 794 795 $self->dest->handle_header( $header ); 796 return ; 797} 798 799 800 801=over 802 803=item repo_client 804 805The p4 client name. This is an accessor for a data member in each class. 806The data member should be part of VCP::Utils::p4, but the fields pragma 807does not support multiple inheritance, so the accessor is here but all 808derived classes supporting this accessor must provide for a key named 809"P4_REPO_CLIENT". 810 811=cut 812 813sub repo_client { 814 my $self = shift ; 815 816 $self->{P4_REPO_CLIENT} = shift if @_ ; 817 return $self->{P4_REPO_CLIENT} ; 818} 819 820=back 821 822=cut 823 824=head1 LIMITATIONS 825 826Treats each branched file as a separate branch with a unique branch_id, 827although files that are branched together should end up being submitted 828together in the destination repository due to change number aggregation. 829 830Ignores branch specs for now. There may be an option to enable 831automatic use of branch specs because most are probably well behaved. 832However, in the event of a branch spec being altered after the original 833branch, this could lead to odd results. Not sure how useful branch 834specs are vs. how likely a problem this is to be. We may also want to 835support "external" branch specs to allow deleted branch specs to be 836used. 837 838VCP::Source::p4 only emits "add", "branch", "delete" and "edit" actions; 839this is all most destinations can handle today. Anything other than one 840of these four is converted to "edit". Specifically, this means that 841when an integration into a file is found, this is treated as an edit. 842Transferring integration records that don't create branches is not 843implemented. 844 845p4 servers older than 2002.2 do not allow getting the submit date and 846time, only the submit *date*, so all changes will seem to happen at 847midnight. Upgrate to the most recent p4d to solve this. 848 849=head1 SEE ALSO 850 851L<VCP::Dest::p4>, L<vcp>. 852 853=head1 AUTHOR 854 855Barrie Slaymaker <barries@slaysys.com> 856 857=head1 COPYRIGHT 858 859Copyright (c) 2000, 2001, 2002 Perforce Software, Inc. 860All rights reserved. 861 862See L<VCP::License|VCP::License> (C<vcp help license>) for the terms of use. 863 864=cut 865 8661 867