@rem --*-Perl-*-- @if "%overbose%" == "" if "%_echo%"=="" echo off if not exist "%~dp0oenvtest.bat" (perl -x "%~dpnx0" %* & goto :eof) setlocal call %~dp0oenvtest.bat "%~dp0%PROCESSOR_ARCHITECTURE%\perl%OPERLOPT%" -wx "%~dpnx0" %* goto :eof #!perl require 5.004; BEGIN { # set library path for OTOOLS environment if (defined $ENV{"OTOOLS"}) { require "$ENV{'OTOOLS'}\\lib\\perl\\otools.pm"; import otools; } # Convert "use strict 'subs'" to the eval below so we don't # barf if the user's @INC is set up wrong. You'd be surprised # how often this happens. eval { require strict; import strict 'subs' }; } sub Usage { my $usage; for $usage (split(/\n/, <<'EOM')) { NAME $name - create a buddy build package SYNOPSIS $name -? $name [-c changelist] [-d] [-f] -o outputfile [-q] [-v-] [-x filename] [-FO] [-FN] [filelist] DESCRIPTION Combines up all files in a changelist into a self-contained package which can be used later to replicate the changelist on another (or the same) machine. If neither a changelist nor a filelist is specified on the command line, all files in the default changelist are used. OPTIONS -? Displays this help file. -c changelist Collect files from the specified changelist. As a special case, "-c all" requests all changelists, overriding the default of "-c default". Note that when a package is created from files from multiple changelists, they will still unpack into a single changelist. -d Turns on debugging spew to stdout. To avoid mixing debugging output from normal output, send the normal output to a file via the -o switch. -f Overwrite the output file if it already exists. -o outputfile -o - Generate the output to the specified file (or stdout if "-" is given as the filename). O| O| If no extension is provided, the ".bpk" extension will be O| assumed. -q Run quietly. Diagnostics are suppressed; only warnings and errors are displayed. -v- Disable autoverify. By default, $name verifies the package after building it if the output is to a file. (Output to stdout cannot be verified. Sorry.) -x filename Read the filelist from the specified file (or stdin if "-" is given as the filename). -FO -FN Set the $name flavor. O = Office project, N = NT project. See additional remarks below for a discussion of flavors. filelist Optional list of files to be included in the package. If no filelist is specified, then all files in the default changelist (or the changelist named by the -c option) are included in the package. sd wildcards are permitted here (such as "..." to package all files in the current directory and below). OUTPUT Output is a batch file which can be run on the same or another enlistment (into the same branch) to replicate the changelist on the target machine. See below (under "outputfile") for usage instructions for the output file. FLAVORS If the OTOOLS environment variable is defined, possibly by a successful, implicit call to oenvtest.bat, $name assumes the Office flavor; otherwise, it assumes the NT flavor. You can override this decision by using the -F command line option. The Office flavor differs from the NT flavor in the following aspects: Office flavor registers $name as the handler for the .bpk file extension. NT flavor does not. Office flavor appends the ".bpk" extension to the output file name if no extension is provided. NT flavor does not assume an extension. EXAMPLE Suppose you want to send your default changelist to Bob for a buddy build before you check the files in. N| $name -o buddybuild.cmd O| $name -o buddybuild N| You then copy buddybuild.cmd to a convenient location O| You then copy buddybuild.bpk to a convenient location or send it via email to Bob. Bob types N| buddybuild.cmd -u O| buddybuild.bpk -u The batch file first determines whether it is safe to unpack itself. If so, it regurgitates its contents into the default changelist. Bob can then do whatever he likes with the changelist. He can perform a code review with "sd diff". He can launch a buddy build. He can even submit it on your behalf. Or he can revert the entire changelist, thereby undoing the effect of running N| the buddybuild.cmd batch file. O| the buddybuild.bpk batch file. EXAMPLE Suppose you're working on a change, but you get tagged to fix a BVT break that requires changing a file you are already working on. You don't want to create a branch just for this one-off fix. Create a package that consists of all the files you were working on. N| $name -o %INIT%\hold.cmd O| $name -o %INIT%\hold N| (Notice that the file was output to your developer directory N| so it won't get scorched.) O| (This assumes that you have set the INIT environment variable O| to some safe directory.) Revert the changelist that you just packaged up. sd revert -c default ... Check in your BVT fix. (sd edit, build, sd submit) Restore the package you saved away. N| %INIT%\hold.cmd -s -u O| %INIT%\hold.bpk -s -u Continue your work. EXAMPLE Suppose you're working on a change and you've reached a stage where you've made a lot of progress but you're about to embark on some serious rewriting and you don't want to lose what you've done so far in case your rewrite turns out to be a bad idea. Create a package that consists of all the files you were working on. N| $name -o %INIT%\before_rewrite.cmd O| $name -o %INIT%\before_rewrite Do your rewrite. If you decide that your rewrite was a bad idea, you can back up to the package that you saved. sd revert -c default ... N| %INIT%\before_rewrite.cmd -u O| %INIT%\before_rewrite.bpk -u Paranoid people like me do this periodically and save the packages on another machine. LIMITATIONS The files in the package must be text or binary files with history. Unrecoverable files cannot be packaged. WARNINGS O| warning: cannot register .bpk file extension; continuing O| O| $name couldn't write to the registry to enable O| double-clicking of files with the .bpk extension. Your O| perl installation may be incomplete. $name will continue O| creating your package anyway. O| //depotpath: unrecoverable; skipping Unrecoverable files cannot be packaged by $name. They will be omitted from the resulting package. //depotpath: cannot package cmd; skipping The type of change is not one of the types supported by $name (add, delete, edit). The file will be omitted from the resulting package. //depotpath: will treat integrate as "edit" //depotpath: will treat branch as "add" The changelist contains "integrate" or "branch" records. $name does not know how to regenerate these changes, so it will treat them as if they were edits/adds instead. ERRORS error: Can't tell who you are, sorry $name was unable to connect to the Source Depot server to determine your identity. Make sure the server is up and you are running $name from the correct directory. error: You need to sd resolve before you can run $name There are changes that have not yet been resolved. $name cannot re-create an unresolved edit. error: outputfile exists; use -f -o to force overwrite By default, $name refuses to overwrite an existing file. Use the -f switch to force an overwrite. internal error: Cannot run sd diff The Source Depot "sd diff" command failed for some reason. internal error: filename in sd diff output but not in changelist The Source Depot "sd diff" command generated a diff entry for a file that wasn't listed in the output of "sd opened". Make sure you aren't running a Source Depot command in another window at the same time you are running $name. internal error: filename#rev in sd diff output; expected filename#rev2 The Source Depot "sd diff" command generated a diff entry for a version of the file different from the one listed in the output of "sd opened". Make sure you aren't running a Source Depot command in another window at the same time you are running $name. internal error: filename in sd diff output twice? The Source Depot "sd diff" command generated two diff entries for the same file. $name can't tell which one to trust. internal error: parsing sd diff output (expecting header) internal error: parsing sd diff output (expecting header or a/d) error: Could not parse output of sd diff $name had trouble parsing the output of the "sd diff" command, perhaps because one of the files participating in the diff does not end in a newline. Files must end in a newline in order for the output of "sd diff" to be parse-able. In environments running pre-2.0 versions of Source Depot, a potential reason is that you've asked $name to do Source Depot operations requiring the server to handle more than MaxResults records. Specify lists of individual files to work around this limit. error: cannot open filename for reading (reason) error: cannot open filename for writing (reason) The specified error occurred attempting to open the indicated file. error: writing (reason) The specified error occurred attempting to write to the output file (usually out of disk space). REMARKS 4NT users need to type perl -Sx $name.cmd instead of just $name. You can create a 4NT alias alias $name=perl -Sx $name.cmd if you use this script a lot. ENVIRONMENT Since $name runs sd internally, all the SD environment variables also apply. BUGS Barfs on text files with no trailing newline. VERSION O| This is version $packver (Office flavor) of $name. N| This is version $packver (NT flavor) of $name. AUTHOR raymondc. Office flavor by smueller. ----------------------- HELP ON HOW TO UNPACK --------------------------- EOM $usage =~ s/\$name/$main::name/g; $usage =~ s/\$packver/$main::packver/g; $usage =~ s/^$main::F\|/ /; next if $usage =~ /^.\|/; print $usage, "\n"; } # Now get the usage string from the output. 0 while ne " my \$usage = <<'EOM';\n"; while (($usage = ) ne "EOM\n") { $usage =~ s/\$name/outputfile/g; $usage =~ s/\$packver/$main::packver/g; $usage =~ s/\$pack/$main::name/g; print $usage; } } sub dprint { print "# ", @_, "\n" if $main::d; } sub vprint { print @_ unless $main::q; } sub Emit { print O @_ or die "error: writing ($!)\n"; } sub SpewBinaryFile { local($/); my $file = shift; open(B, $file) or die "error: cannot open $file for reading ($!)\n"; binmode(B); Emit pack("u", scalar ), "\n"; close(B); } @main::warnings = (); sub Warning { warn $_[0]; push(@main::warnings, $_[0]); } sub RepeatWarnings { if (@main::warnings) { warn "---- WARNING SUMMARY ----\n"; for my $warning (@main::warnings) { warn $warning; } } } sub QuoteSpaces { wantarray ? map { / / ? "\"$_\"" : $_ } @_ : $_[0] =~ / / ? "\"$_[0]\"" : $_[0]; } sub CreateTempFile { my $TEMP = $ENV{"TEMP"} || $ENV{"TMP"}; die "error: no TEMP directory" unless $TEMP; $TEMP =~ s/\\$//; # avoid the \\ problem $tempfile = "$TEMP\\bbpack.$$"; open(T, ">$tempfile") || die "error: Cannot create $tempfile\n"; my $success = print T @_; $success = close(T) && $success; unlink $tempfile, die "error: writing $tempfile ($!)\n" unless $success; $tempfile; } # # A "ChangeEntry" is a single line in a change list. # It is a hash of the form # # depotpath => //depot/blahblah # localpath => C:\nt\blahblah # rev => revision # cmd => "edit", "add" or "delete" # type => "text" or whatever # package ChangeEntry; sub dprint { main::dprint @_ } # For debugging # Constructs from a line in the "sd opened" output sub new { my ($class, $line) = @_; $line =~ m|^(//.*?)#(\d+) - (\S+) .* \((.*?)\)| || return undef; my $self = { depotpath => $1, rev => $2, cmd => $3, type => $4, }; bless $self, $class; } sub Format { my $self = shift; "$self->{depotpath}#$self->{rev} $self->{cmd} $self->{type}"; } sub dump { my ($self, $caller) = @_; dprint "$caller: ", $self->Format, " = $self->{localpath}\n"; } # # A ChangeList is a list of files to be packaged. # It is a hash of the form # # list => a hash, keyed by depot path, of ChangeEntry's # skipped => number of files skipped # add => number of files added # del => number of files deleted # edit => number of files edited # # We break from generality and do ChangeList pruning in situ. # package ChangeList; sub dprint { main::dprint @_ } # For debugging sub Warning { main::Warning @_ } sub new { my ($class, $change) = @_; my $list = { }; my $self = { list => $list, skipped => 0, add => 0, delete => 0, edit => 0, }; bless $self, $class; my @help = (); # Files we need help locating dprint "sd opened $change"; foreach $line (`sd opened $change 2>&1`) { my $entry = new ChangeEntry($line); $entry or die "error: $line"; #dprint $entry->{depotpath}; if ($entry->{type} !~ /(text|binary|unicode)/) { Warning "$entry->{depotpath}: is unknown type; skipping\n"; $self->{skipped}++; next; } elsif ($entry->{type} =~ /S/) { Warning "$entry->{depotpath}: unrecoverable; skipping\n"; $self->{skipped}++; next; } elsif ($entry->{cmd} =~ /^(add|delete)$/) { push(@help, $entry->{depotpath}); } elsif ($entry->{cmd} eq "integrate") { Warning "$entry->{depotpath}: will treat $entry->{cmd} as \"edit\"\n"; $entry->{cmd} = "edit"; } elsif ($entry->{cmd} eq "branch") { Warning "$entry->{depotpath}: will treat $entry->{cmd} as \"add\"\n"; $entry->{cmd} = "add"; push(@help, $entry->{depotpath}); } elsif ($entry->{cmd} ne "edit") { Warning "$entry->{depotpath}: cannot package $entry->{cmd}; skipping\n"; $self->{skipped}++; next; } $self->{$entry->{cmd}}++; $list->{lc $entry->{depotpath}} = $entry; dprint "$entry->{depotpath}#$entry->{rev}"; } # Now add local paths to all the add/delete's in the ChangeList. if (@help) { my $tempfile = main::CreateTempFile(join("\n", @help), "\n"); local($/) = ""; # "sd where -T" emits paragraphs dprint "sd -x \"$tempfile\" where"; foreach $line (`sd -x "$tempfile" where -T _ 2>&1`) { my($depotFile) = $line =~ m|^\.\.\. depotFile (.+)|m; next unless $depotFile; my $entry = $self->GetEntry($depotFile); next unless $entry; my($path) = $line =~ m|^\.\.\. path (.+)|m; next unless $path; if ($line =~ m|^\n\n\n unmap|m) { delete $entry->{localpath}; } else { $entry->{localpath} = $path; } dprint "$depotFile -> $path"; } unlink $tempfile; } # All done. $self; } sub GetEntry { my ($self, $depotpath) = @_; $self->{list}->{lc $depotpath}; } sub GetAllEntries { my $self = shift; values %{$self->{list}}; } sub dump { my ($self, $caller) = @_; for my $entry ($self->GetAllEntries()) { $entry->dump($caller); } dprint "$caller: ."; } package Register; sub Warning { main::Warning @_ } # # RegBpk - Register .bpk file extension and create file association. # Note that RegBpk is called early; can't assume much. # sub RegBpk { eval { require Win32::Registry; import Win32::Registry }; if ($@) { Warning "warning: cannot register .bpk file extension; continuing\n"; return; } # assoc .bpk=BBPackage my $hkey = $main::HKEY_LOCAL_MACHINE; if ($hkey->Create('SOFTWARE\\Classes\\.bpk', $hkey)) { $hkey->SetValueEx('', 0, ®_SZ, 'BBPackage'); $hkey->Close(); } my $binarch = "$ENV{OTOOLS}\\bin\\$ENV{PROCESSOR_ARCHITECTURE}"; my $libperl = "$ENV{OTOOLS}\\lib\\perl"; my $perl = qq/"$binarch\\perl" -I "$libperl" -x/; my $setup = "set OTOOLS=$ENV{OTOOLS}& set PATH=$binarch;%PATH%"; my $diffcmd = qq!cmd.exe /c ($setup& $perl "%1" -w %*)!; my $listcmd = qq!cmd.exe /c ($setup& $perl "%1" -l %*& pause)!; # ftype BBPackage=cmd /c (set OTOOLS/PATH & perl -I LIB -x "%1" -w %*) # (i.e., shell context menu Open command) $hkey = $main::HKEY_LOCAL_MACHINE; if ($hkey->Create( 'SOFTWARE\\Classes\\BBPackage\\Shell\\Open\\Command', $hkey)) { $hkey->SetValueEx('', 0, ®_EXPAND_SZ, $diffcmd); $hkey->Close(); } # default is usually Open, but let's be explicit $hkey = $main::HKEY_LOCAL_MACHINE; if ($hkey->Create( 'SOFTWARE\\Classes\\BBPackage\\Shell', $hkey)) { $hkey->SetValueEx('', 0, ®_SZ, 'Open'); $hkey->Close(); } # shell context menu Log command $hkey = $main::HKEY_LOCAL_MACHINE; if ($hkey->Create( 'SOFTWARE\\Classes\\BBPackage\\Shell\\Log\\Command', $hkey)) { $hkey->SetValueEx('', 0, ®_EXPAND_SZ, $listcmd); $hkey->Close(); } } package main; # # Okay, now initialize our globals. # $main::name = $0; $main::name =~ s/.*[\/\\:]//; $main::name =~ s/\.(bat|cmd)$//; $main::userid = $ENV{"USERNAME"} || getlogin || "userid"; ($main::packver) = '$Id: bbpack.cmd#70 2002/09/25 09:23:56 REDMOND\\raymondc $' =~ /#(\d+)/; $main::c = undef; $main::d = 0; $main::f = 0; $main::o = undef; $main::q = 0; $main::v = 1; @main::x = (); $main::F = defined $ENV{"OTOOLS"} ? "O" : "N"; # Set default flavor $main::oCleanup = undef; # Allow "bbpack /?" to be an alias for "bbpack -?" while ($#ARGV >= 0 && ($ARGV[0] =~ /^-/ || $ARGV[0] eq '/?')) { my $switch = shift; if ($switch eq '-c') { $main::c = shift; } elsif ($switch eq '-d') { $main::userid = "userid"; $main::d++; } elsif ($switch eq '-f') { $main::f++; } elsif ($switch eq '-o') { $main::o = shift; } elsif ($switch eq '-q') { $main::q++; } elsif ($switch eq '-v-') { $main::v = 0; } elsif ($switch eq '-x') { push(@main::x, shift); } elsif ($switch eq '-FN') { $main::F = 'N'; } elsif ($switch eq '-FO') { $main::F = 'O'; } elsif ($switch eq '-?' || $switch eq '/?') { if ($main::F eq 'O') { Register::RegBpk(); # Office flavor creates association } Usage(); exit 1; } else { die "Invalid command line switch; type $name -? for help\n"; } } if ($main::F eq 'O') { Register::RegBpk(); # Office flavor creates association } die "Mandatory -o parameter missing; type $name -? for help\n" unless defined $main::o; # Output file should be specified # # Get some preliminary information. # my %ClientProperties; @RequiredProperties = ("Client name", "User name", "Server address"); { # Intentionally let errors through to stderr foreach my $line (`sd info`) { $ClientProperties{$1} = $2 if $line =~ /^(.*?): (.*)$/; } foreach my $prop (@RequiredProperties) { die "error: Can't tell who you are, sorry\n" unless $ClientProperties{$prop}; } } # # Global filehandles: # # O = output file # SD = sd command if ($main::o eq '-') { open(O, ">&STDOUT"); } else { # Office flavor appends default extension $main::o .= '.bpk' if $main::F eq "O" && $main::o !~ /\./; die "error: $main::o exists; use -f -o to force overwrite\n" if !$main::f && -e $main::o; open(O, ">$main::o") or die "error: $main::o: $!\n"; $main::oCleanup = $main::o; } dprint ">$main::o"; # # Dump the header. # { my $line; while ($line = ) { $line =~ s/\$packver/$main::packver/; Emit $line; } } # # Dump out some meta-data. # { Emit "Packager: $main::name\n"; foreach my $prop (@RequiredProperties) { Emit "$prop: $ClientProperties{$prop}\n"; } my @today = localtime(time); printf O "Date: %04d/%02d/%02d %02d:%02d:%02d\n", 1900+$today[5], 1+$today[4], $today[3], $today[2], $today[1], $today[0]; } Emit "\n"; # # Gather up the files that belong to change $main::c and perhaps # also the files remaining on the command line. # # If no changelist or file list provided, then use -c default. $main::c = "default" if $#ARGV < 0 && !$main::c && !@main::x; # "-c all" means "all changelists" $main::c = "" if $main::c && $main::c eq "all"; my $ChangeSpec = $main::c ? "-c $main::c" : ""; @ARGV = QuoteSpaces(@ARGV); $ChangeSpec .= " @ARGV" if $#ARGV >= 0; # # Now add in the stuff from all the -x files. # foreach (@main::x) { open(I, $_) or die "error: cannot open $_ for reading ($!)\n"; while () { chomp; $_ = "\"$_\"" if / / && !/"/; $ChangeSpec .= " $_"; } close(I); } { my $line = `sd resolve -n @ARGV 2>&1`; die "error: You need to sd resolve before you can run $main::name\n" unless $line =~ /[Nn]o file\(s\) to resolve\.$/; } vprint "Collecting files from \"sd opened $ChangeSpec\"\n"; my $ChangeList = new ChangeList($ChangeSpec); vprint "Collecting files done (", join(", ", map { "$ChangeList->{$_} $_" } qw(edit add delete skipped)), ")\n"; # # Emit the file list, terminated by a blank line. # foreach my $entry ($ChangeList->GetAllEntries()) { Emit $entry->Format, "\n"; } Emit "\n"; # # Run a giant "sd diff" to collect the bulk of the information # The end of each diff is marked with a "q". if ($ChangeList->{edit}) { my $copy = 0; # number of lines to copy blindly to output my $files = 0; # number of files processed my $entry; # file being processed my $possibleBad = ""; # file that might be missing a newline my $line; my $tempfile; my $fUnicodeFile = 0; # # If the user has overridden SDDIFF in their sd config, we'll have # to temporarily reconfigure them. (Same goes for SDUDIFF.) # # First, try it the easy way: Remove SDDIFF from the environment. # delete $ENV{"SDDIFF"}; delete $ENV{"SDUDIFF"}; # Secret environment variable that also messes up sd... # Delete it while we still can. delete $ENV{"DIFF"}; # # Next, see if the user has overridden SDDIFF by "sd set SDDIFF=..." # if (`sd set SDDIFF SDUDIFF` =~ /^(SDDIFF|SDUDIFF)=/im) { # # Darn, we have to unset it by creating a temporary INI file # that explicitly clears SDDIFF and SDUDIFF. # $tempfile = CreateTempFile("SDDIFF=\nSDUDIFF=\n"); $ENV{"SDPORT"} = $ClientProperties{"Server address"}; $ENV{"SDCLIENT"} = $ClientProperties{"Client name"}; $ENV{"SDCONFIG"} = $tempfile; dprint "Force SDCONFIG=$ENV{'SDCONFIG'}"; dprint "Force SDPORT=$ENV{'SDPORT'}"; dprint "Force SDCLIENT=$ENV{'SDCLIENT'}"; } # Okay, we're ready to do the diff thing. dprint "sd diff -dn $ChangeSpec"; open(SD, "sd diff -dn $ChangeSpec 2>nul|") or die "internal error: Cannot run sd diff\n"; while ($line = ) { # Unlink the temp file the moment we get output, in case we die unlink($tempfile), $tempfile = undef if $tempfile; # Reset the Unicode flag if we hit a new file in the output $fUnicodeFile = 0 if $line =~ m,==== //.*?#\d+ - .+ ====,; next if $fUnicodeFile; next if substr($line, -1) eq ""; die "error: Could not parse output of sd diff\n". "file $entry->{localpath} does not end in newline\n" unless substr($line, -1); if ($copy > 0) { $copy--; Emit $line; # Just copy the line to the output $possibleBad = "-- it might be $entry->{localpath}\n" if $line =~ m,==== //.*?#\d+ - .+ ====,; } elsif ($line =~ /^==== (.*?)#(\d+) - (.+) ====(.*)$/) { # New file starting? # # $1 = depotpath # $2 = rev # $3 = localpath # $4 = isbinary Emit "q\n" if $entry; # Finish the previous diff $entry = $ChangeList->GetEntry($1) or die "internal error: $1 in sd diff output but not in changelist\n"; $entry->{rev} == $2 or die "internal error: $1#$2 in sd diff output; expected #$entry->{rev}\n"; $entry->{localpath} and die "internal error: $1 in sd diff output twice?\n"; $entry->{localpath} = $3; vprint "edit $3\n"; $files++; Emit $entry->Format, "\n"; if ($4) { SpewBinaryFile($3); $fUnicodeFile = 1 if $4 =~ /unicode/i; undef $entry; # finished with binary files } } elsif (!$entry) { # Expected file header die "internal error: parsing sd diff output (expecting header)\n". "-- perhaps a file does not end in a newline\n$possibleBad" unless $line eq "(... files differ ...)\n"; } elsif ($line =~ /^d/) { # Lines to delete Emit $line; # Copy to output } elsif ($line =~ /^a\d+ (\d+)/) { # lines to add Emit $line; $copy = $1; # Number of lines to copy blindly } else { dprint "barf: $line"; die "internal error: parsing sd diff output (expecting header or a/d)\n"; } } Emit "q\n" if $entry; # Finish that last diff (if any) close(SD); # Unlink the temp file again, in case the output was null unlink($tempfile), $tempfile = undef if $tempfile; die "error: Could not parse output of sd diff\n". "-- perhaps a file does not end in a newline\n$possibleBad". "-- or you've hit MaxResults -- try specifying files individually\n" unless $copy == 0 && $files == $ChangeList->{edit}; } # # Emit the added files. # foreach my $entry ($ChangeList->GetAllEntries()) { if ($entry->{cmd} eq 'add') { vprint "add $entry->{localpath}\n"; Emit $entry->Format, "\n"; if ($entry->{type} =~ /binary|unicode/) { SpewBinaryFile($entry->{localpath}); } else { open(I, $entry->{localpath}) or die "error: cannot open $entry->{localpath} for reading ($!)\n"; my @slurp = ; close(I); die "error: $entry->{localpath} does not end in newline\n" if scalar(@slurp) && substr($slurp[$#slurp], -1) ne "\n"; Emit "a1 ", scalar(@slurp), "\n", @slurp, "q\n"; } } elsif ($entry->{cmd} eq 'delete') { vprint "delete $entry->{localpath}\n"; Emit $entry->Format, "\n"; } } close(O) or die "error: writing ($!)\n"; $main::oCleanup = undef; if ($main::v && $main::o ne "-") { vprint "verifying package $main::o...\n"; system $^X, "-Sx", "\"$main::o\"", "-v"; } RepeatWarnings(); END { if ($main::oCleanup) { close(O); warn "Deleting failed package $main::oCleanup\n"; unlink $main::oCleanup; } } __END__ @rem --*-Perl-*-- @if "%overbose%" == "" if "%_echo%"=="" echo off setlocal for %%i in (oenvtest.bat) do call %%~$PATH:i perl -x "%~dpnx0" %* goto :eof #!perl BEGIN { # augment library path for OTOOLS environment if (defined $ENV{"OTOOLS"}) { require "$ENV{'OTOOLS'}\\lib\\perl\\otools.pm"; import otools; } # Convert "use strict 'subs'" to the eval below so we don't # barf if the user's @INC is set up wrong. You'd be surprised # how often this happens. eval { require strict; import strict 'subs' }; } require 5.004; sub Usage { my $usage = <<'EOM'; NAME $name - unpack a buddy build package SYNOPSIS $name -? $name [-d] [-c changelist] [-f] [-l] [-m from to] [-n] [-s] [-u] [-v] [-w] [-x] DESCRIPTION Unpack the buddy build generated by a previous $pack. OPTIONS -? Displays this help file. -d Turns on debugging spew. -c changelist Unpack the package onto the given changelist. If this option is omitted, the default changelist will be used. -f Unpack even if the changelist is nonempty. -l List contents of package. -m from to Unpack (merge) the package into a depot different from the one it was built from. "from" and "to" indicate the relationship between the source and target depots. For example, if the original package was built from //depot/branch1/... and you want to unpack to //depot/branch2/... you would specify -m //depot/branch1/ //depot/branch2/ Note the trailing slashes. The source depot can even be on a different server. May not be combined with the -s or -w switches. -n Display what would have happened without actually doing it. -s Synchronize to the versions of the files that are the bases for the changes contained in the package, but do not unpack them. This is a convenient step to perform separately from unpacking because it allows you to perform a pre-build to ensure that the build was not broken before you unpacked the files in the package. -u Perform the unpack. This switch can be combined with the -s switch to synchronize and unpack in one step. The unpack will fail if the changelist is nonempty. Use the "sd change" command to move files in the default changelist to a new changelist. This allows you to use "sd revert -c default ..." to undo the unpack. To force the unpack even if the changelist is empty, pass the -f flag. Note that doing so will result in the unpacked files being added to your changelist, which in turn makes reverting the unpack a much more cumbersome operation. -v Verify that the package will produce results identical to what's on the machine right now. Use this immediately after generating a package as a double-check. -w View contents of packages using windiff (or whatever your BBDIFF environment variable refers to). -x Unpack the files as UNIX-style (LF only) rather than Win32-style (CRLF). WARNINGS warning: filename merge cancelled by user; skipped A file in the package needed to be merged, but you abandoned the merge operation ("s" or "q"). The file was left in its original state; the changes were not merged in. warning: //depot/.../filename not affected by branch mapping; skipped The indicated file in the package is not affected by the from/to mapping, so it was omitted from the merge. ERRORS error: sd failed; unpack abandoned One of the sd commands necessary to complete the unpack failed. The sd error message should have been displayed immediately before this message. error: cannot find local copy of //depot/.../filename The indicated file in the package could not be found on your enlistment. Perhaps you have not included it in your view. internal error: cannot parse output of 'sd have' internal error: Cannot parse output of 'sd opened' There was a problem parsing the output of an sd command. error: changelist is not empty; use -f -u to unpack anyway The changelist is not empty, so the unpack was abandoned. To force unpacking into a nonempty changelist, use the -f switch. error: filename is already open on client The specified file is already open. It must be submitted or reverted before the package can be unpacked. error: adds in this package already exist on client The package contains an "add" operation, but the file already exists. It must be ghosted or deleted before the package can be unpacked. error: files to be edited/deleted do not exist on client The package contains an "edit" or "delete" operation, but the file does not exist on the client. Perhaps you have not included it in your view. error: wrong version of filename on client The base version of the file in the package does not match the base version on the client. Use the -s option to synchronize to the version in the package. error: filename does not match copy in package The verification process (-v) failed. error: corrupted package An internal consistency check on the package has failed. Either it has been corrupted, or there is a bug in the program. error: cannot open filename for writing (reason) The specified error occurred attempting to open the indicated file for writing. error: filename: errorstring The specified error occurred attempting to open the indicated file. error: no TEMP directory Neither the environment variable TEMP nor TMP could be found. error: Too many TEMP### directories Unable to create a temporary directory for windiff because there are too many already. Normally, temporary directories are cleaned up automatically when the script terminates, but if the script terminates abnormally, temporary directories may be left behind and need to be cleaned up manually. REMARKS 4NT users need to type perl -Sx $name.cmd instead of just $name. ENVIRONMENT BBDIFF The name of the diff program to use. If not defined, the SDDIFF variable is used to obtain the name of the file difference program. If neither is defined, then "windiff" is used. BBUNPACKDEFCMD The default command to execute if no command line options are specified. If not defined, then an error message is displayed. For example, you might set BBUNPACKDEFCMD=-w to make the default action when running a package to be to view the contents via windiff. Since $name runs sd internally, all the SD environment variables also apply. BUGS Several error messages leak out when you unpack an sd add. (This is happening while verifying that the file about to be added hasn't already been added.) If the package contains an "add" command and the file exists on the client but is not under source control, the file is overwritten without warning. There are almost certainly other bugs in this script somewhere. VERSION The package was generated by version $packver of $pack. EOM $usage =~ s/\$name/$main::name/g; $usage =~ s/\$pack/$main::pack/g; print $usage; } sub dprint { print STDERR "# ", @_, "\n" if $main::d; } # # $action is optional prefix for printing. # $sharp says whether or not revisions should be kept. # $ary is a ref to an array of [ $file, $rev ]. # # Returns a ref to an array of strings to pass to -x. sub sdarg { my ($action, $sharp, $ary) = @_; my @out = (); my $rc = ""; for my $file (@$ary) { my $arg = $file->[0]; $arg .= "#" . $file->[1] if $sharp; $arg .= "\n"; push(@out, $arg); print "$action $arg" if $action; } \@out; } # # $action is a command ("sync#", "edit", etc.) # # The revision number is stripped off the file specification # unless the action itself ends in a # (namely, sync#). # # $ary is a ref to an array of [ $file, $rev ]. sub sdaction { my ($action, $ary) = @_; my $sharp = $action =~ s/#$//; if ($#$ary >= 0) { my $args = sdarg($action, $sharp, $ary); unless ($main::n) { my $error = 0; my $tempfile = CreateTempFile(@$args); if (open(SD, "sd -x $tempfile -s $action |")) { my $line; while ($line = ) { if ($line =~ /^(\S+): /) { $error = 1 if $1 eq 'error'; print $' unless $1 eq 'exit'; } } close(SD); } unlink $tempfile; die "error: sd failed; unpack abandoned\n" if $error && !$bang; } } } sub slurpfile { my ($file, $type) = @_; my @file; if ($type =~ /binary|unicode/) { open(B, $file) or die "error: cannot open $file for reading ($!)\n"; binmode(B); local($/); push(@file, ); close(B); } else { open(I, $file) or die "error: cannot open $file for reading ($!)\n"; @file = ; close(I); } @file; } sub spewfile { my ($file, $ary, $type) = @_; if (!open(O, ">$file")) { # Maybe the parent directory hasn't been created yet my $dir = $file; $dir =~ s/\//\\/g; if ($dir =~ s/[^\\\/]+$//) { system "md \"$dir\"" unless -e $dir; # let cmd.exe do the hard work } open(O, ">$file") or die "error: cannot open $file for writing ($!)\n"; } binmode(O) if $main::x || $type =~ /binary|unicode/; print O @$ary; close(O); } sub GetUniqueName { my $name = shift; $name =~ s,^[/\\]*,,; # clean out leading slashes $name = substr($name, length($main::CommonPrefix)); $name =~ s,^[/\\]*,,; # clean out leading slashes again if (defined($main::UniqueNames{lc $name})) { my $i = 1; $i++ while $main::UniqueNames{lc "$name$i"}; $name .= $i; } $main::UniqueNames{lc $name} = 1; $name; } sub CreateTempFile { my $TEMP = $ENV{"TEMP"} || $ENV{"TMP"}; die "error: no TEMP directory" unless $TEMP; $TEMP =~ s/\\$//; # avoid the \\ problem $tempfile = "$TEMP\\bbpack.$$"; open(T, ">$tempfile") || die "error: Cannot create $tempfile\n"; my $success = print T @_; $success = close(T) && $success; unlink $tempfile, die "error: writing $tempfile ($!)\n" unless $success; $tempfile; } sub Remap { my $path = shift; if ($path =~ m#^\Q$main::fromDepot\E#i) { substr($path, $[, length($main::fromDepot)) = $main::toDepot; } $path; } # # $depotpath, $rev is the file to be edited/added. # $cmd is "edit" or "add" (indicates where basefile comes from) # sub ApplyEdit { my ($depotpath, $rev, $cmd, $type) = @_; my $destpath = $depotpath; my $destfile; my $where, $file; if ($main::w) { $file = $depotpath; # for the purpose of GetUniqueName } else { $destpath = Remap($depotpath) if $main::m; dprint "$depotpath -> $destpath" if $main::m; local($/) = ""; # "sd where -T" uses paragraphs foreach $line (`sd where -T _ \"$destpath\" 2>&1`) { undef $where, next if $line =~ m|^\.\.\. unmap|m; $where = $1 if $line =~ m|^\.\.\. path (.+)|m; } die "error: cannot find local copy of $destpath\n" unless $where; $destfile = $file = $where; } my @file; my $bias = -1; # perl uses zero-based arrays but diff uses 1-based line numbers if ($cmd eq 'add') { @file = (); $file = $destfile if $main::m; } elsif ($cmd eq 'edit') { my $src = $file; if ($main::v || $main::w || $main::m) { dprint "sd$main::ExtraFlags print -q \"$depotpath\"#$rev"; $src = "sd$main::ExtraFlags print -q \"$depotpath\"#$rev|"; } @file = slurpfile($src, $type); } elsif ($cmd eq 'delete') { if ($main::w) { dprint "sd$main::ExtraFlags print -q \"$depotpath\"#$rev"; @file = slurpfile("sd$main::ExtraFlags print -q \"$depotpath\"#$rev|", $type); } else { @file = (); } } my $unique; if ($main::w || ($main::m && $cmd eq "edit")) { # Write the original, set up for new $unique = GetUniqueName($file); spewfile("$main::BeforeDir\\$unique", \@file, $type) unless $cmd eq 'add'; $file = "$main::AfterDir\\$unique"; } if ($cmd ne 'delete') { # now read from and apply the edits. if ($type =~ /binary|unicode/) { local($/) = ""; @file = (unpack("u", scalar())); } else { while (($line = ) ne "q\n") { if ($line =~ /^a(\d+) (\d+)/) { my @added = (); my $count = $2; while ($count--) { push(@added, scalar()); } splice(@file, $1 + $bias + 1, 0, @added); # +1 because it's "add", not "insert" $bias += $2; } elsif ($line =~ /^d(\d+) (\d+)/) { splice(@file, $1 + $bias, $2); $bias -= $2; } else { die "error: corrupted package\n"; } } } if ($main::v) { my @file2 = slurpfile($file, $type); join("", @file) eq join("", @file2) or die "error: $file does not match copy in package\n"; print "$file is okay\n"; } else { spewfile($file, \@file, $type); } if ($cmd eq "edit" && $main::m) { dprint "sd resolve3 \"$main::BeforeDir\\$unique\" \"$main::AfterDir\\$unique\" \"$destfile\" \"$destfile.out\""; system("sd resolve3 \"$main::BeforeDir\\$unique\" \"$main::AfterDir\\$unique\" \"$destfile\" \"$destfile.out\""); if (-e "$destfile.out") { unlink $destfile; rename "$destfile.out", $destfile; chmod 0666, $destfile; } else { warn "warning: $destfile merge cancelled by user; skipped\n"; } unlink "$main::BeforeDir\\$unique"; unlink "$main::AfterDir\\$unique"; } } } sub IsDirectoryEmpty { my $dir = shift; my $empty = 1; if (opendir(D, $dir)) { while ($file = readdir(D)) { $empty = 0, last if $file ne '.' && $file ne '..'; } closedir(D); } else { $empty = 0; # Wacky directory, pretend nonempty so we skip it } $empty; } $main::NextUniqueDir = 0; sub GetNewTempDir { my $TEMP = $ENV{"TEMP"} || $ENV{"TMP"}; die "error: no TEMP directory" unless $TEMP; $TEMP =~ s/\\$//; # avoid the \\ problem # Look for suitable "before" and "after" directories; we'll # call them "bbtmp###". $TEMP .= "\\bbtmp"; while ($main::NextUniqueDir++ < 1000) { my $try = "$TEMP$main::NextUniqueDir"; if (!-e $try && mkdir($try, 0777)) { return $try; } if (-d _ && IsDirectoryEmpty($try)) { return $try; } } die "error: Too many ${TEMP}### directories\n"; } sub CleanDir { my $dir = shift; if (defined($dir) && -e $dir) { system "rd /q /s $dir"; } } sub AccumulateCommonPrefix { my $file = "/" . lc shift; # Remove filename component while ($file =~ s,[/\\][^/\\]*$,,) { last unless defined $main::CommonPrefix; last if substr($main::CommonPrefix, 0, length($file)) eq $file; } $main::CommonPrefix = $file; } # # Okay, now initialize our globals. # $main::name = $0; $main::name =~ s/.*[\/\\:]//; $main::name =~ s/\.(bat|cmd)$//; $main::c = "default"; $main::d = 0; $main::f = 0; $main::l = 0; $main::m = 0; $main::n = 0; $main::s = 0; $main::u = 0; $main::v = 0; $main::w = 0; $main::x = 0; $main::anyChanges = 0; $main::BeforeDir = undef; $main::AfterDir = undef; %main::UniqueNames = ("" => 1); # preinit to avoid blank name $main::ExtraFlags = ""; $main::fromDepot = undef; $main::toDepot = undef; $main::CommonPrefix = undef; my %PackerProperties; { my $line; while (($line = ) =~ /(.*?): (.*)/) { $PackerProperties{$1} = $2; } $main::pack = delete $PackerProperties{Packager}; die "error: corrupted package\n" unless $line eq "\n" && $main::pack; } # If there is no command line and there is a BBUNPACKDEFCMD, use that # variable instead. if ($#ARGV < 0 && defined $ENV{"BBUNPACKDEFCMD"}) { my $cmd = $ENV{"BBUNPACKDEFCMD"}; $cmd =~ s/^\s+//; while ($cmd =~ s/^\s*(?:"([^"]*)"|([^"]\S*))\s*//) { push(@ARGV, $+); } } while ($#ARGV >= 0 && $ARGV[0] =~ /^-/) { my $switch = shift; if ($switch eq '-d') { $main::d++; } elsif ($switch eq '-f') { $main::f++; } elsif ($switch eq '-l') { $main::l++; } elsif ($switch eq '-m') { $main::m++; $main::fromDepot = shift; $main::toDepot = shift; if ($main::fromDepot !~ m#^//# || $main::toDepot !~ m#^//#) { die "-m must be followed by two depot prefixes; type $name -? for help\n"; } } elsif ($switch eq '-c') { $main::c = shift; if ($main::c !~ m#^[0-9]#) { die "-c must be followed by a changelist number; type $name -? for help\n"; } } elsif ($switch eq '-n') { $main::n++; } elsif ($switch eq '-s') { $main::s++; } elsif ($switch eq '-u') { $main::u++; } elsif ($switch eq '-v') { $main::v++; } elsif ($switch eq '-w') { $main::w++; } elsif ($switch eq '-x') { $main::x++; } elsif ($switch eq '-?') { Usage(); exit 1; } else { die "Invalid command line switch; type $name -? for help\n"; } } # Should be no command line options die "Invalid command line; type $main::name -? for help\n" if $#ARGV >= 0; die "Must specify an action; type -? for help\n" unless $main::l || $main::s || $main::u || $main::v || $main::w; # suppress -w (presumably from registered .bpk extension) # if other actions found $main::w = 0 if $main::l || $main::s || $main::u || $main::v; die "Cannot combine -m with -s\n" if $main::m && $main::s; die "Cannot combine -m with -w\n" if $main::m && $main::w; # # -l wants some meta-information about the package. # if ($main::l) { my $key; foreach $key (split(/,/, "Client name,User name,Date")) { print "$key: $PackerProperties{$key}\n"; } print "\n"; } # # See which files are open on the client. This also establishes whether # the server is up and the user has proper permissions. # my %OpenedFiles; if ($main::s || $main::u) { # Intentionally let errors through to stderr # Use -s to suppress stderr if no files are opened foreach my $line (`sd -s opened -c $main::c`) { next if $line =~ m|^exit: |; next if $line =~ m!^(error|warning): File\(s\) not opened !; $line =~ m,^info: (//.*?)#(\d+|none), or die "error: Cannot parse output of 'sd opened -c $main::c'\n"; $OpenedFiles{$1} = 1; dprint "opened $1#$2"; $main::anyChanges = 1 if $' =~ /$main::c/; } } die "error: changelist $main::c is not empty; use -f -u to unpack anyway\n" if $main::anyChanges && $main::u && !$main::f; # # The -w and -m options require us to set up some directories for unpacking. # if ($main::w || $main::m) { $main::BeforeDir = GetNewTempDir(); $main::AfterDir = GetNewTempDir(); $main::ExtraFlags = " -p $PackerProperties{'Server address'}"; } # # Go through each file in the package and perform an appropriate # action on it. # { my @sync, @edit, @add, @delete; my $line; while (($line = ) =~ m|^(//.*?)#(\d+) (\S+) (\S+)|) { # $1 = depot path # $2 = rev # $3 = action # $4 = filetype (not currently used) if ($main::l) { print $line; } # If sync'ing or unpacking, then the file had better not be open # since we're the ones who are going to open it. die "error: $1 is already open on client\n" if defined $OpenedFiles{$1} && ($main::s || ($main::u && !$main::m)); # If sync'ing, add to list of files that need to be sync'd. # # If unpacking, then add to the appropriate list so we know # how to prepare the file for action. if ($main::s) { push(@sync, [ $1, $3 eq 'add' ? 'none' : $2 ]); } if ($main::u) { my $path = $1; if ($main::m) { $path = Remap($1); } if ($path) { if ($3 eq 'edit') { push(@edit, [ $path, $2 ]); } elsif ($3 eq 'add') { push(@add, [ $path, $2 ]); } elsif ($3 eq 'delete') { push(@delete, [ $path, $2 ]); } else { die "error: corrupted package\n"; } } } AccumulateCommonPrefix($1); } die "error: corrupted package\n" unless $line eq "\n"; $main::CommonPrefix =~ s,^[/\\]+,,; # clean off leading slashes if ($main::s || $main::u) { # # Make sure that no files being added currently exist. # if ($#add >= 0) { my $args = sdarg(undef, undef, \@add); my $tempfile = CreateTempFile(@$args); if (`sd -x $tempfile have 2>nul`) { unlink $tempfile; die "error: adds in this package already exist on client\n"; } unlink $tempfile; } # # Make sure that files being edited are the correct versions. # if (($#edit >= 0 || $#delete >= 0) && !$main::s && !$main::m) { my @have = (@edit, @delete); my %have; my $file; my $args = sdarg(undef, undef, \@have); my $tempfile = CreateTempFile(@$args); dprint "sd have @$args"; for $file (`sd -x $tempfile have`) { $file =~ m|(//.*?)#(\d+)| or die "error: parsing output of 'sd have'\n"; dprint "have $1#$2" if $main::d; $have{lc $1} = $2; } unlink $tempfile; die "error: files to be edited/deleted do not exist on client\n" if $?; for $file (@have) { die "error: wrong version of $file->[0] on client\n" if $have{lc $file->[0]} ne $file->[1]; } } sdaction("sync#", \@sync); sdaction("edit -c $main::c", \@edit); # Do not do the adds yet; wait until after the edits have been applied sdaction("delete -c $main::c", \@delete); } # # Now go extract the actual files. # if (!$main::n && ($main::u || $main::v || $main::w)) { my $line; while (($line = ) =~ m|^(//.*?)#(\d+) (\S+) (\S+)|) { ApplyEdit($1, $2, $3, $4); } } # Okay, now do the adds now that the output files have been created sdaction("add -c $main::c", \@add); } if ($main::w) { my $windiff = $ENV{"BBDIFF"} || $ENV{"SDDIFF"} || "windiff"; system("$windiff \"$main::BeforeDir\" \"$main::AfterDir\""); } CleanDir($main::BeforeDir); CleanDir($main::AfterDir); __END__