#!/usr/local/bin/perl # # $Id: //depot/scm/scripts/p4syncit.pl#7 $ # # # Copyright (c) 2000, Sandy Currier (sandy@releng.com) # Distributed under the GNU GENERAL PUBLIC LICENSE: # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 1, or (at your option) # any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software Foundation, # Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. # # first, see if unix or NT or what... # need a recent version of perl on NT to have win32 module/config stuff BEGIN: { require 5.004; unless ($Platform{'os'}) { unless ($Platform{'os'} = $^O) { require Config; $Platform{'os'} = $Config::Config{'osname'}; $Platform{'os'} = $Config::Config{'osname'}; # compiler warning } } # bottom layer OS specific variables/constants if ($Platform{'os'} =~ /cygwin/i) { # ugh - a cygwin perl $Platform{'os'} = "unix"; $Platform{'pd'} = '/'; $Platform{'p4glue'} = "-d `cygpath -aw \${PWD}`"; } elsif ($Platform{'os'}=~/Win/i) { ######################### # win32 ######################### if (exists($ENV{'BASH'}) or $ENV{'OSTYPE'} eq "cygwin") { # ugh - a windows perl running in a cygwin environment die "Window's perl not supported under cygwin environment - use [/cc]/usr/local/bin/perl instead\n"; } else { $Platform{'os'} = "win32"; $Platform{'pd'} = '\\'; } } else { ######################### # unix ######################### $Platform{'os'} = "unix"; $Platform{'pd'} = '/'; } } # # Unbuffer STDERR and STDOUT select(STDERR); $| = 1; # Make STDERR be unbuffered. select(STDOUT); $| = 1; # STDOUT too so, they can mix. # # set up some globals # Note: assume that the PATH EV is going to be used to find p4 $ThisCmd = "p4syncit.pl"; # this command name $P4 = "p4 $Platform{'p4glue'}"; # the p4 command to execute $vb = ">>>"; $err = "***"; $printonly = 0; $verbose = 1; $maxlevel = 128; $sync = "sync"; # whether to sync or flush $Error{'Errors'} = $Error{'Warnings'} = 0; # # local variables %ClientInfo = (); # the client object @UserNumbers = (); # the list of UserNumbers $norollup = 0; # weird switch $filespec = "//..."; $plevel = 1; # # now parse any args # the usage message (for -h or on error) $help = "$ThisCmd [change# ...] [-norollup] [-plevel ] Function: $ThisCmd assumes that a client has be sync'ed to some time consistant slice of the respository (like a change number or a timerule). From the sync'ed changenumber, if no changes are supplied, a list of available changes not yet sync'ed will be offered for selection. Once a list of changes has been supplied, $ThisCmd will datamine perforce to determine if any other changes need to be rolled up to have a properly sync'ed client (if the -norollup switch is not set). If there are such changes, the user will be prompted whether or not to proceed. $ThisCmd will then rollup the changes (unless -norollup has been specified) and sync those files. In all cases, the latest version of any given file across all incoming changes, even if catalogued by multiple changes, will be used. Args: changelist ... One or more comma separated changelist numbers. $ThisCmd will flag an error if the changelist does not exist between the baseline and the head. Switches/Options: -h Prints this help message -n Print only - do not perform the sync -plevel Sets the prompt level. (def=$plevel) 0 = no prompting whatsoever 1 = some prompting 2 = lots of prompting -norollup If specified, will not roll up dependent changes (effectively pulling in only parts the dependent changes) -filespec Will limit the inspection to a given depot syntax file spec. (def=$filespec) "; # # parse command line { my($i); my($param) = 0; while($i <= $#ARGV) { # scan for a help switch if ($ARGV[$i] =~ /^-h/i) { &DieHelp("", $help); } # scan for switches elsif ($ARGV[$i] =~ /^-norollup/i) { $norollup = 1; $i++; } elsif ($ARGV[$i] =~ /^-n/i) { $printonly = 1; $i++; } # scan for variable definitions (-variable value) elsif ($ARGV[$i] =~ /^-\w+/ and defined($ARGV[$i+1]) and $ARGV[$i+1] !~ /^-[^-]/) { # NOTE: nt has a difficult time with '=' on a command line... # process any variable value switches my($var) = $ARGV[$i]; $var =~ s/^-//; my($value) = $ARGV[$i+1]; if (defined $$var) { $$var = $value; } else { &DieHelp("Unknown parameter '$var'\n", $help); } $i=$i+2; } # catch unsupported switches elsif ($ARGV[$i] =~ /^-/) { &DieHelp("Unsupported switch \"$ARGV[$i]\"\n", $help); } elsif ($ARGV[$1] =~ /^[0-9]+$/) { # swallow files or a changeset push(@UserNumbers, $ARGV[$i]); $i++; $param++; } else { &DieHelp("Only numbers are valid change arguments - \"$ARGV[$i]\"\n", $help); } } } # # make sure that a valid client is selected { my($client_string) = "Client name: "; my($root_string) = "Client root: "; my($cwd_string) = "Current directory: "; my(@tmp, @info); @info = &ExecuteP4Cmd("$P4 info", $verbose); &TheEnd() if ($?); &mychomp(\@info); # now get client name @tmp = grep(/^$client_string/,@info); # grep out the client name $ClientInfo{'clientname'} = &other2unix($tmp[0]); # transfer to a scalar $ClientInfo{'clientname'} =~ s/^$client_string//; # ditch the uninteresting part if ($ClientInfo{'clientname'} eq "") { # check things die "$ThisCmd - something wrong - no client name found from p4 info output"; } &PrintMessage("Client name: $ClientInfo{'clientname'}"); # get the client root @tmp = grep(/^$root_string/,@info); # grep out the client name $ClientInfo{'clientroot'} = &other2unix($tmp[0]); # transfer to a scalar $ClientInfo{'clientroot'} =~ s/^$root_string//; # ditch the uninteresting part if ($ClientInfo{'clientroot'} eq "") { # check things die "$ThisCmd - something wrong - no client name found from p4 info output"; } &PrintMessage("Client root: $ClientInfo{'clientroot'}"); # get the ClientInfo{'cwd'} @tmp = grep(/^$cwd_string/,@info); # grep out the client name $ClientInfo{'cwd'} = &other2unix($tmp[0]); # transfer to a scalar $ClientInfo{'cwd'} =~ s/^$cwd_string//; # ditch the uninteresting part if ($ClientInfo{'cwd'} eq "") { # check things die "$ThisCmd - something wrong - no cwd found from p4 info output"; } &PrintMessage("cwd : $ClientInfo{'cwd'}"); } # # algorithm: # verify that the client is time-consistant # list the changes that are not in the baseline: p4 changes //...$maxchange,#head # if @Changes is specified # check: fail if not valid # else # print changes; read input; loop, or fail, or continue # # algorithm continued below # # # determine the max change { my($output); my($script) = "$P4 changes -s submitted -m1 \"$filespec#have\""; &PrintMessage("Running: $script") if ($verbose); $output = `$script`; # ignore errors ($maxchange = $output) =~ s/^Change ([0-9]+) .*$/$1/; &mychomp(\$maxchange); if ($maxchange eq "" or $maxchange == 0) { &PrintError("$err No valid max change\n$output"); exit 1; } } # # verify that the client is time consistant { my($count, $minchange, $list); # # get the output of the p4 files command... # Note: the -C switch returns files mapped to the client, which # usually includes deleted files. The -H will not return deleted files - this # is what is needed since it is better to ignore deleted files here my($script) = "$P4 fstat -s -H \"$filespec\@$maxchange\""; # the perforce screw - only change/time does the right thing here #$script = "$P4 fstat -s -C $filespec\#have,#head"; &PrintMessage("Running: $script") if ($verbose); if (!open(OUTPUT, "$script|")) { &PrintError("Could not execute '$script'\n$!"); exit 1; } else { my($depotFile, $headRev, $haveRev); while () { &mychomp(\$_); # parse a line and hash it if (/^\.\.\. depotFile (.+)$/) { $depotFile = $1; } elsif (/^\.\.\. headRev (.+)$/) { $headRev = $1; } elsif (/^\.\.\. haveRev (.+)$/) { $haveRev = $1; } elsif ($_ eq "") { # end of file - process it if ($headRev != $haveRev) { # not cross consistant my($out) = sprintf "(have=%3d, \@$maxchange=%3d) $depotFile", $haveRev, $headRev; &PrintError($out); $havefiles{$depotFile} = $haveRev; $headfiles{$depotFile} = $headRev; $count++; } $depotFile = $headRev = $haveRev = ""; } } close(OUTPUT); } # # now loop over files to find smallest change # $minchange = $maxchange; foreach my $file (sort(keys(%havefiles))) { &GetFileLog(\%FileLogs, $file); # returns it in %FileLog (cached) # this gives the last change in a file, not the real maximum time consistance # change in the filespec... # $minchange = &min($minchange, $FileLogs{$file}{'revmap'}{$havefiles{$file}}); my($i); for ($i=$havefiles{$file}+1; $i<=$headfiles{$file}; $i++) { $missingchanges{$FileLogs{$file}{'revmap'}{$i}} = 1; } } # # here is a list of the incomplete changes foreach my $chg (sort sortbynumber (keys(%missingchanges))) { $list = "$list,$chg"; } $list =~ s|^,||; $minchange = $list; $minchange =~ s|(^[0-9]+).*$|$1|; $minchange-- if ($minchange > 0); # # possibly the end if ($count) { &PrintMessage("Summary: found $count inconsistant file(s)") if ($verbose); &PrintMessage(" maxchange: $maxchange") if ($verbose); &PrintMessage("max consistant change: $minchange") if ($verbose); &PrintMessage(" incomplete changes: $list") if ($verbose and $list); &PrintError("Erroring and exiting due to the above errors..."); exit(1); } } # # retrieve the changes that can be specified { my($tmp); my($script) = "$P4 changes -s submitted \"$filespec\@$maxchange,#head\""; &PrintRaw("Retrieving missing changes..."); @MIAChanges = &ExecuteP4Cmd($script); &mychomp(\@MIAChanges); &TheEnd() if ($?); # the above will always return the head change pop @MIAChanges; $tmp = scalar(@MIAChanges); &PrintRaw(" found $tmp missing change(s)\n"); unless ($tmp) { &PrintRaw("\n"); &PrintNote("All changes are already in the baseline - exiting"); &TheEnd(); } # cache just the numbers in a hash foreach my $chg (@MIAChanges) { my($number) = $chg; $number =~ s|^Change ([0-9]+) .*$|$1|; $MIANumbers{$number} = $chg; } } # # if changes are specified, check if (scalar(@UserNumbers)) { my($tmp) = &CheckChanges(\@UserNumbers, 1); if ($tmp) { my($list) = join(',', (sort sortbynumber (keys(%MIANumbers)))); &PrintError("Here is a list of acceptable changes:\n$list"); &TheEnd(); } } else { # prompt for changes my($tmp, $list); $list = join(',', (sort sortbynumber (keys(%MIANumbers)))); &PrintMessage("Here is a list of acceptable changes to select from:\n$list"); loop: &PrintRaw("\nPlease enter a comma seperated list of change numbers\n"); &PrintRaw("(q to quit; p#### to print) "); $list = ; &mychomp(\$list); &PrintRaw("\n"); if ($list =~ /^q/) { &TheEnd(); } elsif ($list =~ /^[0-9,\s]+$/) { # close enough - take it $list =~ s|,| |g; @UserNumbers = split('\s+', $list); $tmp = &CheckChanges(\@UserNumbers, 1); goto loop if ($tmp); } elsif ($list =~ /^p([0-9]+)$/) { my($tmp, @tmp); $tmp[0] = $1; $tmp = &CheckChanges(\@tmp, 1); goto loop if ($tmp); &GetDescription(\%Descriptions, $tmp[0]); foreach my $line (@{$Descriptions{'raw'}{$tmp[0]}}) { &PrintMessage($line); } goto loop; } else { &PrintNote("Invalid input - try just entering change numbers separated by comma's"); goto loop; } # at this point, have a valis list of changes } # # algorithm: # # 1) first, call &UpdateUserFileInfo which will # - get the change description for all supplied changes (cached) # - for each file in the change, get the filelog info and baseline version (cached) # - generate the %UserFileRevs and %UserFileRevsDups hash # 2) loop over the files being updated # - record all changes for any revision (per file) being sucked in (smartly) # 3) if anything is incoming, query # 4) if yes, add those changes to list and goto step 1) # Note: this will loop until no more new changes are being sucked in # # # the following hashes are defined above: # @MIAChanges - ordered list of changes after the baseline (fully/partially not in) # @UserNumbers - ordered list of selected changes to add/sync to baseline # %MIANumbers - {$chg} = the full single-line change description # %UserFileRevs - {$file} = $revision (selected/latest past baseline) # %UserFileRevsDups - {$file}{$revision} = $chg (the missing change) # %Descriptions - {$chg}{$file} = $revision (revision in the changelist) # # the following hashes are defined below: # %FileLogs - {$file}{$revision} = $chg (the change for that revision) # %BaseLineRevs - {$file} = $revision (for the baseline version) # # do it once, then maybe again, then maybe again... &UpdateUserFileInfo(); { my($filerevcount); my(%missingchanges, %allmissingchanges); my($list, $changecount, $level, $ans); $level = 0; transitive_loop: $filerevcount = 0; $level++; if ($level > $maxlevel) { &PrintError("Recursion level exceeded max ($maxlevel). Set it (-maxlevel) higher."); &TheEnd(); } # loop over all missing changes that need to be pulled in foreach my $file (sort(keys(%UserFileRevs))) { &PrintMessage("Inspecting $file"); # can determine the changes that are missing my($i); for ($i=$BaseLineRevs{$file}+1; $i<$UserFileRevs{$file}; $i++) { # if here, then this $i rev is being skipped for $file # set the value to the change number # Note: important to skip those eclipsed changes that have already been covered if (!exists($UserFileRevsDups{$file}{$i})) { # print if not in %UserFileRevsDups if ($i == 1) { &PrintNote(" Overlap on change $FileLogs{$file}{'revmap'}{$i} - new file (add) via rev $i"); } else { &PrintNote(" OverLap on change $FileLogs{$file}{'revmap'}{$i} - new file (edit) via rev $i"); } $missingchanges{$FileLogs{$file}{'revmap'}{$i}} = 1; $allmissingchanges{$FileLogs{$file}{'revmap'}{$i}} = 1; $filerevcount++; } } } # now print and so something $list = join(',', sort sortbynumber (keys(%missingchanges))); $changecount = scalar(keys(%missingchanges)); if ($changecount) { my($ans); &PrintMessage("Overlapping change summary for all files:\n $list\n"); loop2: # if rollup, walk the list and add all dependencies if ($plevel >= 2) { &PrintRaw("Found $filerevcount file and $changecount change overlap(s)!\n"); if ($norollup) { &PrintRaw("No rollup has been specified - continue and ignore possible\n"); &PrintRaw("incomplete changes? [y] "); } else { &PrintRaw("Continue? (q to quit, y to proceed, changenumber to describe) [y] "); } $ans = ; &mychomp(\$ans); &PrintRaw("\n"); } if ($ans =~ /^q/) { &TheEnd(); } elsif ($norollup and ($ans eq "" or $ans =~ /^y/i)) { # continue on anyway } elsif ($ans eq "" or $ans =~ /^y/i) { # continue # now pull in all the dependent changes by adjusting: # 1) @UserNumbers - so to record all incoming changes foreach my $foo (keys(%missingchanges)) { push @UserNumbers, $foo; } # sort it @UserNumbers = &SortNumerically(@UserNumbers); # 2) %UserFileRevs and %UserFileRevsDups with the additional changes &UpdateUserFileInfo(); # 3) undef %missingchanges so to be able to loop again undef %missingchanges; # 4) do it until done goto transitive_loop; } elsif ($ans =~ /^([0-9]+)$/ or $ans =~ /^p([0-9]+)$/) { my($tmp, @tmp); $tmp[0] = $1; $tmp = &CheckChanges(\@tmp, 1); goto loop2 if ($tmp); &GetDescription(\%Descriptions, $tmp[0]); foreach my $line (@{$Descriptions{'raw'}{$tmp[0]}}) { &PrintMessage($line); } goto loop2; } else { goto loop2; } } else { if ($plevel >= 1) { my($ans); loop3: $list = join(',', sort sortbynumber (keys(%allmissingchanges))); $changecount = scalar(keys(%allmissingchanges)); if ($changecount) { &PrintMessage("Overlapping change summary for all files:\n $list\n"); &PrintRaw("Continue? (q to quit, y to proceed, p#### to print) [y] "); } else { &PrintRaw("\nFound no overlapping changes - proceed? [y] "); } $ans = ; &mychomp(\$ans); &PrintRaw("\n"); if ($ans =~ /^q/) { &TheEnd(); } elsif ($ans eq "" or $ans =~ /^y/i) { # continue on anyway } elsif ($ans =~ /^[0-9]+$/) { my($tmp, @tmp); $tmp[0] = $ans; $tmp = &CheckChanges(\@tmp, 1); goto loop3 if ($tmp); &GetDescription(\%Descriptions, $ans); foreach my $line (@{$Descriptions{'raw'}{$ans}}) { &PrintMessage($line); } goto loop3; } else { &TheEnd(); } } else { &PrintMessage("Found no more overlapping changes - proceeding"); } } } # # now, sync (preview) files beyond the baseline &SyncFiles(\%UserFileRevs); # # the end &TheEnd(); # # subroutines (these should come from an include file, but not # enough time now to set it up) # # will sync a bunch of explcit files wrapping as much as possible into # a single sync command sub SyncFiles { my($filerev) = @_; my($stringlimit) = 255; my($string, $cmd); if ($printonly) { $cmd = "$P4 $sync -n"; } else { $cmd = "$P4 $sync"; } foreach my $file (sort(keys(%{$filerev}))) { my($filename) = "$file\#$$filerev{$file}"; if (length("$cmd \"$filename\"") + 1 > $stringlimit) { &PrintError("Command line exceeds command line length limit\n$cmd \"$filename\""); &TheEnd(); } if (length("$cmd $string \"$filename\"") + 1 > $stringlimit) { # too big, run command now my($script) = "$cmd $string"; &ExecuteP4Cmd($script, $verbose, 1); # start string over $string = "\"$filename\""; } else { # add this filename since it fits $string = "$string \"$filename\""; } } # see if there is any string left if ($string) { my($script) = "$cmd $string"; &ExecuteP4Cmd($script, $verbose, 1); } } # will loop over all changes and make sure that all descriptions have been filled in # returns 1 if there were new files, 0 otherwise sub UpdateUserFileInfo { my($new) = 0; # reverse the list - guarantees a simple graph foreach my $chg (reverse(sort sortbynumber (@UserNumbers))) { my($tmp) = &GetDescription(\%Descriptions, $chg); if ($tmp) { # only if new $new++; foreach my $file (sort(keys(%{$Descriptions{$chg}}))) { # if this file is the first revision to be hit, record; otherwise, note if (!exists($UserFileRevs{$file})) { $UserFileRevs{$file} = $Descriptions{$chg}{$file}; } else { # duplicate - warn &PrintNote("Note: ignoring rev $Descriptions{$chg}{$file} during \@$chg for $file\#$UserFileRevs{$file}") if ($verbose > 1); # but, need to record this for later $UserFileRevsDups{$file}{$Descriptions{$chg}{$file}} = $chg; } # get the filelog output &GetFileLog(\%FileLogs, $file); # returns it in %FileLog (cached) # get the revision at the baseline if not defined yet &GetBaseLineRev(\%BaseLineRevs, $maxchange, $file); # returns it in %BaseLineRevs (cached) } } } return($new); } # returns 1 if new, 0 if existing sub GetDescription { my($hashref, $chg) = @_; my($script); if (!exists($$hashref{$chg}{'file'})) { $script = "$P4 describe -s $chg"; @{$$hashref{'raw'}{$chg}} = &ExecuteP4Cmd("$script"); &mychomp(\@{$$hashref{'raw'}{$chg}}); # see if @output contains a files foreach my $line (@{$$hashref{'raw'}{$chg}}) { # if not a valid file line, punt and go to next one next unless ($line =~ /^\.\.\. \/\//); $line =~ s|^\.\.\. ||; # remove beginning text my($file, $revision, $action) = &SplitFilename3($line); $$hashref{$chg}{$file} = $revision; } return(1); } return(0); } # returns 1 if new, 0 if existing sub GetBaseLineRev { my($hashref, $maxchange, $file) = @_; my($script, @output, $tmp, $rev); if (!exists($$hashref{$file})) { $script = "$P4 -s files \"$file\@$maxchange\""; @output = &ExecuteP4Cmd($script); &mychomp(\@output); if ($output[0] =~ /^error: /i) { # file is being added later $$hashref{$file} = 0; } else { ($tmp, $rev) = split(/\#/, $output[0], 2); $rev =~ s|^([0-9]+).*$|$1|; $$hashref{$file} = $rev; } return(1); } return(0); } # returns 1 if new, 0 if existing sub GetFileLog { my($hashref, $file) = @_; my($script) = "$P4 filelog \"$file\""; if (!exists($$hashref{$file}{'raw'})) { @{$$hashref{$file}{'raw'}} = &ExecuteP4Cmd($script); &mychomp(\@{$$hashref{$file}{'raw'}}); # hash it foreach my $line (@{$$hashref{$file}{'raw'}}) { next unless ($line =~ /^\.\.\. \#/o); $line =~ /^\.\.\. \#([0-9]+) change ([0-9]+) /o; $$hashref{$file}{'revmap'}{$1} = $2; } return(1); } return(0); } sub CheckChanges { my($arrayref, $error_p) = @_; my(@badchanges); foreach my $chg (@{$arrayref}) { if (!exists($MIANumbers{$chg})) { push @badchanges, $chg; } } if (scalar(@badchanges)) { my($list) = join(',', (sort sortbynumber (@badchanges))); &PrintError("The following specified changes cannot be added:\n$list") if ($error_p); return(1); } return(0); } # will convert a random OS delimited pathname to a perl pathname sub other2unix { my($filename) = @_; my($pattern) = $Platform{'pd'}; $pattern =~ s/(\W)/\\$1/g; # escape wildchars $filename =~ s|$pattern|/|g; return("/") if ($filename =~ /^\/+$/); # if just /+, return just / if ($filename =~ /^\/\//) { # add them back in later $filename =~ s|/+|/|g; # remove doubles $filename = "/$filename"; } else { $filename =~ s|/+|/|g; # remove doubles } # remove trailing $filename =~ s|/+$||; return($filename); } sub DieHelp { my($str, $help) = @_; print STDOUT "$err $str\nUsage: $help"; exit(2); } # # Note: this will actually execute any command... # returns the action of the revision of the specified file#revision sub ExecuteP4Cmd { my($script, $verbose, $print_output, $no_error_check, $stream_p) = @_; my(@output); if ($stream_p) { print $stream_p "$vb running: $script\n" if ($verbose); } else { print STDOUT "$vb running: $script\n" if ($verbose); } if (!$Platform{'nt'} and $Platform{'os'} eq "win32") { @output = `$script`; } else { @output = `$script 2>&1`; } if ($stream_p) { if ($print_output) { foreach my $line (@output) { print $stream_p $line; } } } else { if ($print_output) { foreach my $line (@output) { print STDOUT $line; } } } if (!$no_error_check and $?) { # now what - just keep going &PrintError("$ThisCmd - something happened with '$script'\n$?", $stream_p); } return(@output); } # can handle, somewhat, either # or @... # Note: the output of a 'p4 change ...' will not be of the form # ... //depot/main/scm/tests/bar#4 edit # ... //depot/main/scm/tests/xxx#1 add # ... //depot/main/scm/tests/zzz#1 add # # the output of s 'p4 files ...' will be something like # //depot/main/scm/tests/foo#4 - edit change 1833 (text) # try to handle both here... sub SplitFilename3 { my($thing) = @_; my($f, $tmp, $r, $a, $d, $junk); if ($thing =~ /\#/){ ($f, $tmp) = split('#', $thing); $d = "\#"; } elsif ($thing =~ /\@/) { ($f, $tmp) = split('@', $thing); $d = "\@"; } else { # hoping that the thing passed in is really a file... $f = $thing; } return($f, $r, $a, $d) unless ($tmp); # if empty $tmp, just return now if ($tmp =~ / - /) { ($r, $a) = split(/ - /, $tmp); # split on the first ' - ' (here's hoping again) } else { # if no ' - ', split on first space... ($r, $a) = split(/ /, $tmp); } ($a, $junk) = split(' ', $a); # just use first word return($f, $r, $a, $d); } # should not be called by a server sub TheEnd { my($tmp); print STDOUT "$err exiting with $Error{'Errors'} Error(s) & $Error{'Warnings'} Warning(s)\n"; # exit with the number of errors in the bottom 16 bits # and the number of warnings in the top # Note: make sure that if things shift off, that error is at least still set $tmp = $Error{'Warnings'} << 16; $tmp |= $Error{'Errors'}; # explicitly set $! to the explicit value # see the documentation on die exit($tmp); } sub PrintError { my($text, $stream_p) = @_; my($tmp); # first, increment error count $Error{'Errors'}++; # make sure $? is set $? = 1; # prepend with the correct prefix $text =~ s/^(.*)$/$err $1/gm; # store error away push(@{$Error{'ErrorSummary'}}, $text); # add a \n $text = "$text\n"; # print and log (maybe) if ($stream_p) { print $stream_p "$text"; } else { print STDOUT "$text"; } return($tmp); } # will increment $Error{'Warnings'} and append $err to every line sub PrintWarning { my($text, $stream_p) = @_; my($tmp); # first, increment warning count $Error{'Warnings'}++; # prepend with the correct prefix $text =~ s/^(.*)$/$err $1/gm; # store error away push(@{$Error{'WarningSummary'}}, $text); # add a \n $text = "$text\n"; # print and log (maybe) if ($stream_p) { print $stream_p "$text"; } else { print STDOUT "$text"; } return($tmp); } # will append $vb to every line sub PrintMessage { my($text, $stream_p) = @_; my($tmp); # prepend with the correct prefix $text =~ s/^(.*)$/$vb $1/gm; # add a \n $text = "$text\n"; # print and log (maybe) if ($verbose) { if ($stream_p) { print $stream_p "$text"; } else { print STDOUT "$text"; } } return($tmp); } # will append $err to every line (but not set or increment any error variables) sub PrintNote { my($text, $stream_p) = @_; my($tmp); # prepend with the correct prefix $text =~ s/^(.*)$/$err $1/gm; # add a \n $text = "$text\n"; # print and log (maybe) if ($stream_p) { print $stream_p "$text"; } else { print STDOUT "$text"; } return($tmp); } sub PrintRaw { my($text, $stream_p) = @_; my($tmp); # print and log (maybe) if ($stream_p) { print $stream_p "$text"; } else { print STDOUT "$text"; } return($tmp); } sub SortNumerically { my(@array) = @_; return(sort sortbynumber @array); } sub sortbynumber { my($tmpa) = $a; my($tmpb) = $b; $tmpa <=> $tmpb; } sub min { my($a, $b) = @_; return($a) if ($a <= $b); return($b); } # something to chew windows and unix trailings off sub mychomp{ my($ptr) = @_; if (ref($ptr) eq "ARRAY") { foreach my $s (@$ptr) { $s =~ s|[\n\r]*$||; } } elsif (ref($ptr) eq "SCALAR") { $$ptr =~ s|[\n\r]*$||; } else { die "internal error - unknown reference to mychomp\n"; } return; }