Leaked source code of windows server 2003
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

3622 lines
96 KiB

  1. #
  2. # Office::SD.pm
  3. #
  4. # Uniform Source Depot Access from Perl
  5. #
  6. # _ALL_ perl Source Depot operations should use routines in this package.
  7. #
  8. # Call smueller to add missing functions as necessary.
  9. #
  10. package Office::SD;
  11. require 5;
  12. =head1 NAME
  13. Office::SD - Uniform Source Depot Access from Perl
  14. =head1 SYNOPSIS
  15. use Office::SD;
  16. InitSD();
  17. ConfigSD(option => value); # see ConfigSD for complete list of options
  18. # query command 'sd command args' generally maps to:
  19. $rarray = SDCommandN(@args);
  20. $rhash = SDCommand($arg);
  21. or
  22. @array = SDCommandN(@args);
  23. %hash = SDCommand($arg);
  24. # for commands that have multiple forms (e.g. sd change -o reports on a
  25. # change, other forms edit a change), there are additional
  26. # 'verb-specialized' functions:
  27. SDChange(); # sd change (interactive form)
  28. $rhash = SDGetChange($ncl); # sd change -o
  29. SDSetChange($rhash); # sd change -i
  30. SDDelChange($ncl); # sd change -d
  31. # some forms are only accessible using option specifications as in the
  32. # SD command line. 'sd command -opts args' maps to:
  33. $rhash = SDCommand(\$opts, @args);
  34. # all exported functions return undef on failure. Error text (in case of
  35. # failure) and warning text (otherwise) is available using:
  36. $sdwarning = SDWarning(); # text as one string or as array of lines,
  37. @sderror = SDError(); # depending on return context
  38. =head1 EXAMPLES
  39. # return values can be fairly complex; use Data::Dumper to get a sense of
  40. # what the data looks like:
  41. use Data::Dumper;
  42. $ref = SDCommandN(@args);
  43. print Dumper($ref); # argument must be a reference
  44. # here's a canonical way to process a reference-to-array-of-references-to-
  45. # hashes return value:
  46. my $rlabels = SDLabels(); # get ref-to-array of refs-to-hashes
  47. foreach my $rlabel (@$rlabels) { # foreach ref-to-hash in refed-array
  48. my $label = $rlabel->{Label}; # get a value from ref-to-hash
  49. print "$label\n";
  50. }
  51. # often, these complex return values contain more data than you care about.
  52. # For example, If you're not interested in the access time and description
  53. # fields returned by SDLabels for each label, you can extract a list of
  54. # just the label names using:
  55. @labels = map $_->{Label}, SDLabels();
  56. # if after dereferencing and selecting fields and whatnot, you find a value
  57. # isn't what you expect, you can sometimes use that info to lead you in the
  58. # right direction. For example, if
  59. print $someexpression;
  60. # yields something like ARRAY(0x123456) it means you've printed the
  61. # reference, not what it references. You'll probably want to try
  62. # @$someexpression to get at the actual array. Similarly, a value of
  63. # HASH(0x123456) indicates you want to try %$someexpression.
  64. =head1 DESCRIPTION
  65. SD.pm provides access to Source Depot from perl, in a fashion similar to that
  66. provided by the SDAPI.
  67. Traditionally, source control behaviour is scripted in an 'unstructured'
  68. fashion -- calling code assembles command lines, spawns them, and parses the
  69. output. The SDAPI supports this model, but also offers 'structured' output
  70. for some commands, allowing the caller to ask for specific fields by name.
  71. SD.pm goes further in this direction. SD.pm functions generally take
  72. structured input -- specific positional parameters -- instead of strings of
  73. options and filenames, and produce structured output -- hashes of results --
  74. instead of streams of unparsed text. Using structured input, the caller is
  75. freed from having to worry about ordering and quoting of arguments.
  76. Additionally, SD.pm can potentially include code to work around limitations or
  77. irregularities of the SD command line and/or SDAPI.
  78. Each SD command is encapsulated by one or more exported functions. The default
  79. behaviour for 'sd command' is exported in the function SDCommand. More complex
  80. SD commands have multiple forms, whose behaviour is determined by command line
  81. options. Such commands are encapsulated in separate SDVerbCommand exported
  82. functions, with prefix verbs such as Get, Set and Del. Generally, the value
  83. returned by SDGetCommand can be passed to a subsequent SDSetCommand, with
  84. modifications in between. To delete existing entities, use SDDelCommand.
  85. Argument lists vary widely, but function argument order generally reflects the
  86. SD command line argument order: options (optional, and rarely needed) come
  87. first, followed by fixed arguments, followed by variable arguments (typically
  88. zero or more filenames). Most options are unnecessary because they're implied
  89. by the specific function being called. To differentiate the optional options
  90. from other arguments, they must be passed by reference, as the first function
  91. argument, in a single string. Options are copied unchecked into an SD command
  92. line. You're responsible for handling quoting, spacing and ensuring the
  93. options are appropriate for the particular command line. Functions accepting
  94. structured data can usually accept hashes or references to hashes. In cases
  95. where more arguments need to be passed after the hash, a hash reference is
  96. required.
  97. Generally, exported functions return a hash of their results. If called in
  98. scalar context, the returned value is really a reference to a hash. In array
  99. context, the actual hash is returned. Use the reference for slightly better
  100. performance, or the actual hash for slightly more convenience. In some cases,
  101. the return value is a scalar (such as a changelist# or simple boolean) which is
  102. uniformly returned, regardless of context. Some functions can return data
  103. about multiple files. These are named with a trailing N, and return lists of
  104. hashes (or references to them, depending on context). See specific function
  105. descriptions for argument and return details.
  106. The keys of returned hashes usually correspond to labels in SD command output.
  107. Non-uniformity with respect to names, case and use of spaces is inherited.
  108. All functions return undef (or empty list in array context) in case of total
  109. failure, generally defined as no recognized output from a spawned SD command,
  110. an error spawning an SD command, or, in simple cases, a non-zero exit code from
  111. a spawned SD command. Functions may perform parameter checking and other work
  112. before attempting to spawn SD, which can also result in failure. You can call
  113. SDError before any other SD.pm function to retrieve descriptive text for any
  114. failures (i.e. an internally generated message and/or the SD command's stderr
  115. output), even if a function doesn't return undef. Call SDWarning for
  116. non-failure descriptive text.
  117. Not all output is completely structured (so you may still have to parse fields
  118. of interest further), and not all input is either (so you may have to pass
  119. explicit options in the optional first reference-to-scalar argument). Where
  120. structured data is supported, use it. In future, more structured support will
  121. be added. Some SD commands and options are not supported at all. Call
  122. smueller to add missing functions as necessary, and in the meantime, use SDRun,
  123. which handles ordering of arguments and quoting for you.
  124. The SD.pm environment includes some global context information, such as whether
  125. to echo output and (eventually) the current user, that affects the behaviour of
  126. subsequent SD.pm functions. Configure the environment by passing options to
  127. ConfigSD. Manage multiple environments yourself by saving and restoring the
  128. hash returned by ConfigSD.
  129. Where SD.pm behaviour differs substantially from 'sd command' or the SDAPI,
  130. the differences will be noted in the function description. Most common such
  131. differences are in field names (select fields are renamed for consistency) and
  132. error reporting (an 'sd command's stdout, stderr and exit code may ultimately
  133. be considered in generating return values).
  134. Currently, SD.pm invokes SD command lines and parses the text output to provide
  135. structured results. In future, it may use the SDAPI through a perl extension
  136. DLL. SD.pm was developed and tested against SD 1.6, 1.7 and 2.0.
  137. =head1 CLIENTS
  138. Keep the list of all modules/scripts using this package current. Modules/
  139. scripts not in this list may be broken without warning as this module evolves.
  140. Known Clients:
  141. - bin\asserttag.bat
  142. - bin\asserttagall.bat
  143. - bin\astatus.bat
  144. - bin\ocheck.bat
  145. - bin\oclient.bat
  146. - bin\ohome.bat
  147. - bin\riddiff.bat
  148. - bin\syncchanges.bat
  149. - bin\tagall.pm
  150. - legacy\bin\applypaksd.bat
  151. - lib\perl\Office\OcheckSD.pm
  152. - lib\perl\Office\Oclient.pm
  153. =head1 TODO
  154. Things to do in the near term.
  155. - simplify use of Parse/CreateFormFile/Cmd to not require passing all callbacks
  156. - implement SDIntegrate.
  157. Assert tagging scripts use SDRun to do revert, submit, and resolve.
  158. - analog of SlmPak's InProject and friends to categorize status of files.
  159. NOTE: Slm bundles server and client status into one status field. In SD,
  160. these appear to be a bit more distinct and there's also a third,
  161. pending-not-submitted status to consider.
  162. - enhance %config global state control (e.g. current directory handling,
  163. options to sd.exe (as opposed to any particular command), SD env/registry
  164. variables)
  165. - should internally generated warnings/errors respect echoWarning/Error?
  166. =head1 FUTURE
  167. Things to consider in the long term.
  168. - generally support more commands, more options on commands, more structured
  169. parsing of output, more sophisticated error/success decisions
  170. - 'low-power mode' - a config entry controlling whether data is returned, or
  171. just success/failure. (Consider huge uninteresting returns from an SDSync.)
  172. - 'error parsing mode' - a config entry controlling whether known warnings/
  173. errors are returned in structured data. (Consider what to return if exists
  174. $_->{errorFile} foreach @open.)
  175. - document all the types of output lines that are expected by each command
  176. - file types are generally in the old but ubiquitous monolithic form; add a
  177. config entry controlling mapping to base type + modifiers form
  178. - allow options as a reference to a hash as well as a string?
  179. - podify function headers
  180. - should functions proactively provide fields not returned by corresponding sd
  181. commands?
  182. - define EXPORT_OK names without SD prefix; group these based on suitable
  183. EXPORT_TAGS
  184. - include command/function name in internally generated @sderrors
  185. - use prototypes on exported functions?
  186. - use pseudohashes for return values?
  187. - ensure non-N function arguments don't contain wildcards?
  188. - implement more extensive debug/verbose mode that doesn't delete temp files,
  189. logs spawned processes, etc. (when done, use osystem.pm's open() wrapper)
  190. - move Administrator commands into a separate SDAdmin module?
  191. - convert to SDAPI. First step: consider converting to use -ztag=1 structured
  192. output from command line SD.
  193. =head1 AUTHOR
  194. Stephan Mueller (smueller)
  195. =cut
  196. $VERSION = '0.84';
  197. use strict;
  198. use Exporter;
  199. @Office::SD::ISA = qw(Exporter);
  200. @Office::SD::EXPORT = qw(
  201. brnDefault nclDefault
  202. echoNone echoText echoInfo echoWarning echoError echoAll
  203. InitSD ConfigSD
  204. SDBranch SDGetBranch
  205. SDChange SDGetChange SDSetChange SDNewChange SDDelChange SDChanges
  206. SDClient SDGetClient SDSetClient SDDelClient SDClients
  207. SDGetCounter SDSetCounter SDDelCounter SDCounters
  208. SDDescribe SDDescribeN
  209. SDDiff SDDiffN
  210. SDDiff2 SDDiff2N
  211. SDDirs
  212. SDEdit SDEditN SDAdd SDAddN SDDelete SDDeleteN
  213. SDFileLog SDFileLogN
  214. SDFiles SDFilesN
  215. SDFstat SDFstatN
  216. SDGetGroup SDGroups
  217. SDHave SDHaveN
  218. SDInfo
  219. SDGetLabel SDSetLabel SDDelLabel SDLabels
  220. SDLabelSync
  221. SDOpened SDOpenedN
  222. SDReopen SDReopenN
  223. SDResolve SDResolveN
  224. SDRevert SDRevertN
  225. SDReview SDReviews
  226. SDSubmit SDSubmitError SDSubmitWarning
  227. SDSync SDSyncN SDBranchSync SDBranchSyncN
  228. SDUsers SDUsersN
  229. SDWhere SDWhereN
  230. SDRun
  231. SDSet
  232. SDWarning SDError
  233. SDSyncSD
  234. );
  235. @Office::SD::EXPORT_OK = qw(
  236. defechofunc
  237. ParseFormFile ParseFormCmd ParseForm
  238. ParseFiles ParseView ParseOptions ParseNames ParseProtections ParseTypeMap
  239. CreateFormFile CreateForm
  240. CreateFiles CreateView CreateOptions
  241. specnorm specmatch
  242. );
  243. # manifest constants
  244. sub nclDefault () { 0 } # default changelist
  245. sub brnDefault () { '' } # default branch
  246. sub echoNone () { 0 } # echo no output
  247. sub echoText () { 1 << 0 } # echo output matching ^text\d?:
  248. sub echoInfo () { 1 << 1 } # echo output matching ^info\d?:
  249. sub echoWarning () { 1 << 2 } # echo output matching ^warning\d?:
  250. sub echoError () { 1 << 3 } # echo output matching ^error\d?: (and unmarked)
  251. sub echoAll () { echoText | echoInfo | echoWarning | echoError }
  252. # globals
  253. use vars qw($frmfspec $argfspec $inifspec $sdexit @sdwarning @sderror);
  254. use vars qw(%bin %config $finitsd);
  255. #
  256. # Implementation Notes
  257. #
  258. # There is a certain monotonous consistency to the implementation of functions
  259. # in this module. This is a good thing.
  260. # - all SD commands are spawned using sdpopen to capture and parse stdout and
  261. # stderr through a pipe. info is returned immediately; warnings and errors
  262. # are saved for inspection on demand by SDWarning and SDError. Backticks
  263. # can't be overridden, avoid them.
  264. # - sd -s is used to coerce all (well, most) output to stdout, and prefix each
  265. # line with a type indicator. Output that's not prefixed is assumed to be an
  266. # error. Specific text is treated exceptionally. All output seen by callers
  267. # or written to stdout is mapped to standard (non -s) output using mappd;
  268. # callers should not know we use -s.
  269. # - simple functions respect the close PIPE return value: $? != 0 means
  270. # failure, so return undef. Otherwise, return parsed stdout/err.
  271. # - complex functions ignore close PIPE return value: parse stdout/err and
  272. # return parsed recognized text. Return undef only if there was no
  273. # recognized text.
  274. # - all command tokens are properly quoted using crtquote.
  275. # - options are separated from arguments by '--' when subsequent arguments may
  276. # look like options.
  277. # - if an SD command requires input beyond command line arguments (e.g. sd
  278. # command -i < input), input is written to a temp file, which is then passed
  279. # using input redirection in an open(PIPE, ...) as above.
  280. # - every exportable function ensures @sderror is updated to reflect the cause
  281. # of an internal error.
  282. #
  283. #
  284. # Utilities
  285. #
  286. # internal constant regular expressions
  287. # trailing count indicates number of paren groups in pattern, if any
  288. use vars qw($redatime $redu $reduc2 $reftype1);
  289. $redatime = qr!\d{4}/\d\d/\d\d \d\d:\d\d:\d\d!; # a d/a/te t:i:me pair
  290. $redu = qr/\S+\\\S+/; # domain\user
  291. $reduc2 = qr/(\S+\\\S+)\@(\S+)/; # domain\user@client
  292. $reftype1 = qr/[a-z]+(\+[kxwmeCDFS]+)?/; # type+modifier binary+Swx
  293. #
  294. # inlist - Return number of times val occurs in list.
  295. #
  296. sub inlist {
  297. my ($val, @list) = @_;
  298. return scalar(grep($_ eq $val, @list));
  299. }
  300. #
  301. # shiftopts - If first element of ary is a scalar reference, shift ary and
  302. # return the referent, else return the empty string.
  303. #
  304. sub shiftopts (\@) {
  305. return (ref $_[0]->[0] eq 'SCALAR') ? ${shift(@{$_[0]})} : '';
  306. }
  307. #
  308. # rshifthash - If first element of ary is a hash reference, shift ary and
  309. # return the reference, else return a reference to rest of ary as a hash.
  310. # Caller must be sure not to modify returned hash as it may belong to
  311. # caller's caller.
  312. #
  313. sub rshifthash (\@) {
  314. if (ref $_[0]->[0] eq 'HASH') {
  315. return shift(@{$_[0]});
  316. } else {
  317. my %hash = @{$_[0]};
  318. return \%hash;
  319. }
  320. }
  321. #
  322. # crtquote - Return list as string, quoted according to C RunTime rules, with
  323. # empty/undefined items removed.
  324. #
  325. # FUTURE: don't quote strings with no spaces
  326. #
  327. sub crtquote {
  328. my(@list) = @_;
  329. @list = grep defined $_ && $_ ne '', @list;
  330. return '' if @list == 0;
  331. # double trailing \es so they don't inadvertently escape delimiting ".
  332. map { s/(\\*)$/$1x2/e if defined $_ } @list;
  333. # escape quotes
  334. map { s/"/\\"/g } @list;
  335. return '"' . join('" "', @list) . '"';
  336. }
  337. #
  338. # mappd - Map 'prefixed' lines (e.g. 'warning1: blah') to 'dotted' lines
  339. # (e.g. '... blah'). Return mapped lines.
  340. #
  341. sub mappd {
  342. my(@lines) = @_;
  343. s/^\w+?(\d*):\s/'... ' x $1 if $1/e foreach @lines;
  344. return wantarray ? @lines : $lines[0];
  345. }
  346. #
  347. # mapdp - Map 'dotted' lines (e.g. '... blah') to 'prefixed' lines
  348. # (e.g. 'warning1: blah'). Return mapped lines.
  349. #
  350. sub mapdp {
  351. my($prefix, @lines) = @_;
  352. my $l;
  353. s!^((\.\.\.\s)*)!($l = ($1 ? length($1)/4 : '')), "$prefix$l: "!e
  354. foreach @lines;
  355. return wantarray ? @lines : $lines[0];
  356. }
  357. #
  358. # sdpopen - Open a pipe to read stdout and stderr from an sd command. stdin
  359. # is read from nul to remove need for user interaction with 'Hit return to
  360. # continue...' messages. cmd is left unmodified, args are quoted and appended
  361. # if present. If resulting command line would annoy cmd.exe, use sd -x file
  362. # to work around line length limitation. Return 1/undef on success/failure,
  363. # respectively. Set sderror in case of failure, too.
  364. #
  365. # FUTURE: add -- to command line here instead of in callers
  366. # FUTURE: to be tidy, don't include <nul if $cmd includes its own (in case of
  367. # multiple redirections, last one wins, so current behaviour is OK. Any
  368. # > redirection wins over |, which can also be exploited.) Alternatively,
  369. # allow more control, with an explicit argument, for commands that need to be
  370. # interactive.
  371. #
  372. sub sdpopen (*;$@) {
  373. my($ph, $cmd, @args) = @_;
  374. # reasonably central place to trap lack of initialization
  375. if (! $finitsd) {
  376. my ($pkg, $file, $line, $sub) = caller(1);
  377. $sub =~ s/.*:://; # trim package name
  378. die __PACKAGE__ . ".pm: $sub: InitSD not called\n"
  379. }
  380. my @opts;
  381. push @opts, '-i', crtquote($config{ini}) if defined $config{ini};
  382. push @opts, '-c', crtquote($config{client}) if defined $config{client};
  383. push @opts, '-d', crtquote($config{dir}) if defined $config{dir};
  384. push @opts, '-M', crtquote($config{maxresults})
  385. if defined $config{maxresults};
  386. push @opts, '-p', crtquote($config{port}) if defined $config{port};
  387. push @opts, '-P', crtquote($config{password})
  388. if defined $config{password};
  389. push @opts, '-u', crtquote($config{user}) if defined $config{user};
  390. my $opts = join ' ', @opts, '';
  391. my $opencmd = "$bin{sd} $opts<nul 2>&1 -s ";
  392. my $args = crtquote(@args);
  393. if (length($args) > 4000) {
  394. # mental note: cmd.exe is a bag of dirt
  395. # use response file if command line would be too long
  396. if (! open(FILE, "> $argfspec")) {
  397. push @sderror, "internal: can't open $argfspec for write\n";
  398. return;
  399. }
  400. print FILE join("\n", @args), "\n";
  401. close FILE;
  402. $opencmd .= "-x \"$argfspec\" $cmd";
  403. } else {
  404. $opencmd .= "$cmd $args";
  405. }
  406. print "sdpopen: spawning: $opencmd\n" if $config{verbose};
  407. if (! open($ph, "$opencmd |")) {
  408. push @sderror, "internal: can't run $opencmd\n";
  409. return;
  410. }
  411. return 1;
  412. }
  413. #
  414. # sdpclose - close pipe opened by sdpopen, cleaning up appropriately.
  415. #
  416. sub sdpclose (*) {
  417. my $ret = close $_[0];
  418. unlink $argfspec if ! $config{verbose};
  419. return $ret;
  420. }
  421. # Win32::Console.pm closes stdout when a buffer created on it is destroyed, so
  422. # keep console for duration of process to avoid. Keep attributes too, to
  423. # minimize sd set calls. Use echotype to communicate output type to internal
  424. # defechofunc without changing echofunc interface.
  425. use vars qw($fdoneconsole $rattr $console $echotype);
  426. #
  427. # getconsole - Emulate use Win32::Console at runtime and attach a console to
  428. # stdout if possible. Return new console or undef if none.
  429. #
  430. sub getconsole {
  431. my $console;
  432. local $SIG{__DIE__}; # prevent __DIE__ being called during eval
  433. if (eval { require Win32::Console }) {
  434. eval { import Win32::Console };
  435. eval "\$console = new Win32::Console(STD_OUTPUT_HANDLE)";
  436. }
  437. return $console;
  438. }
  439. #
  440. # defechofunc - Default echofunc used if none specified. Can be exported for
  441. # use in caller echofunc callbacks.
  442. #
  443. sub defechofunc {
  444. if (! $fdoneconsole && ($echotype eq 'error' || $echotype eq 'warning')) {
  445. if (-t STDOUT) { # stdout is a tty
  446. my %configSav = ConfigSD(echo => echoNone, echofunc => undef);
  447. $rattr = SDSet();
  448. ConfigSD(%configSav);
  449. if (! exists $rattr->{COLORIZEOUTPUT}
  450. || $rattr->{COLORIZEOUTPUT} != 0) {
  451. $console = getconsole;
  452. }
  453. }
  454. $fdoneconsole = 1;
  455. }
  456. if (defined $console && ($echotype eq 'error' || $echotype eq 'warning')) {
  457. my $attr = ($echotype eq 'error')
  458. ? ($rattr->{ATTRERROR} || '0x0c')
  459. : ($rattr->{ATTRWARNING} || '0x0e');
  460. my $attrSav = $console->Attr();
  461. $console->Attr(hex($attr));
  462. print @_; #$console->Write($_) foreach @_;
  463. $console->Attr($attrSav);
  464. } else {
  465. print @_;
  466. }
  467. }
  468. #
  469. # eprint - Echo print sd.exe output. Respects config{echofunc} to allow caller
  470. # access to the output stream.
  471. #
  472. # FUTURE: allow callback access to output type; need to fix all existing cases,
  473. # but can then eliminate echotype hack
  474. #
  475. sub eprint {
  476. $echotype = shift;
  477. if (defined $config{echofunc}) {
  478. &{$config{echofunc}}(@_);
  479. } else {
  480. defechofunc(@_);
  481. }
  482. $echotype = '';
  483. }
  484. #
  485. # readfilt - Filter warnings, errors and exit code into @sdwarning, @sderror
  486. # and $sdexit. Discard non-\n-terminated 'Hit return to continue...' messages,
  487. # which don't flush properly. User doesn't need to because of sdpopen <nul.
  488. # Otherwise, act like readline, returning next line of input. Depending on
  489. # config{echo}, write info, warning and/or error output to stdout as well.
  490. # Consider unrecognized text to be errors, or prefix-type if provided.
  491. #
  492. # FUTURE: tighten prefix matching to always expect exactly one space after foo:
  493. #
  494. sub readfilt (*;$) {
  495. my($fh, $prefix) = @_;
  496. my @recs;
  497. $prefix = 'error' if ! defined $prefix;
  498. my $fhSav = select STDOUT;
  499. my $afSav = $|;
  500. $| = 1;
  501. while () {
  502. my $rec = <$fh>;
  503. RETRY:
  504. if (! defined $rec) {
  505. $| = $afSav; select $fhSav;
  506. wantarray ? return @recs : return;
  507. } elsif ($rec =~ /^text/) {
  508. eprint 'text', scalar mappd $rec if $config{echo} & echoText;
  509. if (wantarray) {
  510. push @recs, $rec;
  511. } else {
  512. $| = $afSav; select $fhSav;
  513. return $rec;
  514. }
  515. } elsif ($rec =~ /^info/) {
  516. eprint 'info', scalar mappd $rec if $config{echo} & echoInfo;
  517. if (wantarray) {
  518. push @recs, $rec;
  519. } else {
  520. $| = $afSav; select $fhSav;
  521. return $rec;
  522. }
  523. } elsif ($rec =~ /^warning/) {
  524. eprint 'warning', scalar mappd $rec if $config{echo} & echoWarning;
  525. push @sdwarning, $rec;
  526. } elsif ($rec =~ /^error/) {
  527. eprint 'error', scalar mappd $rec if $config{echo} & echoError;
  528. push @sderror, $rec;
  529. } elsif ($rec =~ /^exit:\s*(\d+)$/) {
  530. $sdexit = +$1; # force numeric context
  531. } elsif ($rec =~ s/^Hit return to continue\.\.\.//) {
  532. goto RETRY; # prompt has no \n, absorbs following line
  533. } else { # assume prefix
  534. # lines following 'Source Depot client error:' will also be errors
  535. $prefix = 'error' if $rec =~ /^Source Depot client error:$/;
  536. $rec = mapdp $prefix, $rec;
  537. goto RETRY;
  538. }
  539. }
  540. }
  541. #
  542. # clearwarnerr - Clear any existing warnings and errors.
  543. #
  544. sub clearwarnerr {
  545. undef @sdwarning;
  546. undef @sderror;
  547. undef $sdexit;
  548. }
  549. #
  550. # enext - Consider argument text to be an internal error, then next.
  551. #
  552. sub enext {
  553. push @sderror, "internal: unrecognized sd.exe output:\n", mappd @_;
  554. local $^W = 0; # suppress 'Exiting subroutine via next'
  555. next;
  556. }
  557. #
  558. # nclnorm - Type check and normalize ncl (changelist#) in place. Return
  559. # 1/undef on success/failure. Set sderror in case of failure, too. default
  560. # indicates what value to normalize nclDefault to. default undefined indicates
  561. # nclDefault is inappropriate.
  562. #
  563. sub nclnorm (\$;$) {
  564. my($rncl, $default) = @_;
  565. if (defined $$rncl && $$rncl !~ /^\d+$/) {
  566. push @sderror, "caller: changelist# must be numeric\n";
  567. return;
  568. } elsif (! defined $$rncl || $$rncl == nclDefault) {
  569. if (! defined $default) {
  570. push @sderror, "caller: can't use default changelist\n";
  571. return;
  572. } else {
  573. $$rncl = $default;
  574. }
  575. }
  576. return 1;
  577. }
  578. #
  579. # brnnorm - Type check and normalize brn (branch) in place. Return 1/undef on
  580. # success/failure. Set sderror in case of failure, too. default indicates
  581. # what value to normalize brnDefault to. default undefined indicates
  582. # brnDefault is inappropriate. Note that normalized value always gains '-b'
  583. # switch if not the empty string.
  584. #
  585. sub brnnorm (\$;$) {
  586. my($rbrn, $default) = @_;
  587. if ($$rbrn eq brnDefault) {
  588. if (! defined $default) {
  589. push @sderror, "caller: can't use default branch\n";
  590. return;
  591. } else {
  592. $$rbrn = $default;
  593. }
  594. }
  595. $$rbrn = '-b ' . crtquote($$rbrn) if $$rbrn ne '';
  596. return 1;
  597. }
  598. #
  599. # lblnorm - Type check and normalize lbl (label) in place. Return 1/undef on
  600. # success/failure. Set sderror in case of failure, too. Note that normalized
  601. # value always gains '-l' switch if not the empty string, at least for now.
  602. #
  603. sub lblnorm (\$) {
  604. my($rlbl) = @_;
  605. if ($$rlbl eq '') {
  606. push @sderror, "caller: must specify label\n";
  607. return;
  608. }
  609. $$rlbl = '-l ' . crtquote($$rlbl);
  610. return 1;
  611. }
  612. #
  613. # nto1 - Return a single struct (or reference) from the value of a single key
  614. # hash reference returned by another SD* call, a lot like %{(SDFooN(args))[0]}.
  615. #
  616. sub nto1 ($) {
  617. my($ref) = @_;
  618. return if ! defined $ref;
  619. if (ref $ref ne 'ARRAY' || @$ref != 1) {
  620. my ($pkg, $file, $line, $sub) = caller(1);
  621. $sub =~ s/.*:://; # remove package qualification from sub name
  622. push @sderror,
  623. "caller: argument must be single-element array reference\n",
  624. "caller: (did you mean to call ${sub}N instead of $sub?)\n";
  625. return;
  626. }
  627. $ref = $ref->[0];
  628. if (ref $ref ne 'HASH') {
  629. push @sderror,
  630. "internal: argument's value must be a hash reference\n";
  631. return;
  632. }
  633. return wantarray ? %$ref : $ref;
  634. }
  635. #
  636. # ShowForm - Display interactive change/client/etc. form.
  637. #
  638. # FUTURE: this is really generic enough to be 'SimpleCmd'. Replace innards of
  639. # (for example) SDDel* with calls here.
  640. #
  641. sub ShowForm {
  642. my($cmd) = @_;
  643. sdpopen(*PIPE, $cmd) || return;
  644. my @out = readfilt PIPE;
  645. sdpclose PIPE;
  646. return if $? != 0;
  647. return \@out;
  648. }
  649. #
  650. # ParseFiles - ParseForm callback parses sd change Files lines. Keep in sync
  651. # with CreateFiles.
  652. #
  653. sub ParseFiles {
  654. my($key, $rvalue) = @_;
  655. return if $key ne 'Files';
  656. my @files;
  657. foreach my $rec (@$rvalue) {
  658. next if $rec =~ /^\s*(#.*)?$/;
  659. if ($rec =~ /^\s*([^#\@]+?)\s*#\s*(\w+)\s*$/) { # //file # edit
  660. push @files, { 'depotFile' => $1, 'action' => $2 };
  661. } elsif ($rec =~ /^\s*([^#\@]+?)\s*(#.*)?$/) { # //file (# comment)?
  662. push @files, { 'depotFile' => $1 };
  663. } else {
  664. enext $rec;
  665. }
  666. }
  667. return \@files;
  668. }
  669. #
  670. # ParseView - ParseForm callback parses sd client/label View lines. Keep in
  671. # sync with CreateView.
  672. #
  673. # FUTURE: compare field names with SDAPI when complete.
  674. # NOTE: leading '+' is undocumented but supported in sd
  675. #
  676. sub ParseView {
  677. my($key, $rvalue) = @_;
  678. return if $key ne 'View';
  679. my @mappings;
  680. foreach my $rec (@$rvalue) {
  681. next if $rec =~ /^\s*(#.*)?$/;
  682. enext $rec if $rec !~ m!^\s*([-+])?(//.+?)(\s+(//.+?))?\s*(#.*)?$!;
  683. my $rh = { 'depotSpec' => $2 };
  684. $rh->{targetSpec} = $4 if defined $4;
  685. $rh->{unmap} = ($1 eq '-') if defined $1;
  686. push @mappings, $rh;
  687. }
  688. return \@mappings;
  689. }
  690. #
  691. # ParseOptions - ParseForm callback parses sd client Options lines. Keep in
  692. # sync with CreateOptions.
  693. #
  694. # FUTURE: should false options be undef instead of 0?
  695. #
  696. sub ParseOptions {
  697. my($key, $rvalue) = @_;
  698. return if $key ne 'Options';
  699. my (%options, $done1);
  700. foreach my $rec (@$rvalue) {
  701. next if $rec =~ /^\s*(#.*)?$/;
  702. if (! $done1) {
  703. foreach my $field (split " ", $rec) {
  704. $field =~ /^(no|un)?(.*)$/;
  705. $options{$2} = defined $1 ? 0 : 1;
  706. }
  707. $done1 = 1;
  708. } else {
  709. enext $rec; # there can be only one (line of options)
  710. }
  711. }
  712. return \%options;
  713. }
  714. #
  715. # ParseNames - ParseForm callback parses sd group Subgroups and Users sections.
  716. # Keep in sync with CreateNames, when it exists.
  717. #
  718. sub ParseNames {
  719. my($key, $rvalue) = @_;
  720. return if $key ne 'Subgroups' && $key ne 'Users';
  721. my @names;
  722. foreach my $rec (@$rvalue) {
  723. next if $rec =~ /^\s*(#.*)?$/;
  724. enext "$rec\n"
  725. if $key eq 'Subgroups' && $rec !~ /^\s*([^\\]+?)\s*(#.*)?$/;
  726. enext "$rec\n"
  727. if $key eq 'Users' && $rec !~ /^\s*(.+\\.+?)\s*(#.*)?$/;
  728. push @names, $1;
  729. }
  730. return \@names;
  731. }
  732. #
  733. # ParseProtections - ParseForm callback parses sd protect Protections sections.
  734. # Keep in sync with CreateProtections, when it exists.
  735. #
  736. # FUTURE: better handling of quoted fields (here and in all form parsing/
  737. # creating); right now it's a hack assuming only the name field will ever be
  738. # quoted and/or contain spaces.
  739. #
  740. sub ParseProtections {
  741. my($key, $rvalue) = @_;
  742. return if $key ne 'Protections';
  743. my @protections;
  744. foreach my $rec (@$rvalue) {
  745. next if $rec =~ /^\s*(#.*)?$/;
  746. enext $rec
  747. if $rec !~ /^\s*(=?\w+)\s+(\w+)\s+([^#]+)\s+([^#]+?)\s+([^#]+?)\s*(#.*)?$/;
  748. my $rh = { 'Mode' => $1, 'Type' => $2, 'Name' => $3,
  749. 'Host' => $4, 'Path' => $5 };
  750. $rh->{Name} =~ s/\s+$//; # strip trailing spaces
  751. $rh->{Name} =~ s/^("?)(.*)\1$/$2/; # strip quotes
  752. push @protections, $rh;
  753. }
  754. return \@protections;
  755. }
  756. #
  757. # ParseTypeMap - ParseForm callback parses sd typemap TypeMap lines. Keep in
  758. # sync with CreateTypeMap, when it exists.
  759. #
  760. # FUTURE: compare field names with SDAPI when complete.
  761. # FUTURE: better handling of quoted fields (here and in all form parsing/
  762. # creating); right now it's a hack counting on only the name field will ever be
  763. # quoted and/or contain spaces.
  764. #
  765. sub ParseTypeMap {
  766. my($key, $rvalue) = @_;
  767. return if $key ne 'TypeMap';
  768. my @mappings;
  769. foreach my $rec (@$rvalue) {
  770. next if $rec =~ /^\s*(#.*)?$/;
  771. enext $rec if $rec !~ /^\s*($reftype1)\s+([^#]+)\s*(#.*)?$/;
  772. my $rh = { 'Filetype' => $1, 'Path' => $3 };
  773. $rh->{Path} =~ s/\s+$//; # strip trailing spaces
  774. $rh->{Path} =~ s/^("?)(.*)\1$/$2/; # strip quotes
  775. push @mappings, $rh;
  776. }
  777. return \@mappings;
  778. }
  779. #
  780. # ParseDefault - ParseForm callback implements default parsing.
  781. #
  782. sub ParseDefault {
  783. my($key, $rvalue) = @_;
  784. my $join = join "\n", @$rvalue;
  785. local $/ = '';
  786. chomp $join; # strip trailing empty lines
  787. return $join;
  788. }
  789. #
  790. # SetFormRecord - insert record defined by lines in rvalue into form in rform.
  791. # rfns is a list of callbacks for parsing records in a form-specific way.
  792. #
  793. sub SetFormRecord {
  794. my($rform, $rvalue, @rfns) = @_;
  795. my $key;
  796. ($key, $rvalue->[0]) = $rvalue->[0] =~ /^(\w+):\s*(.*)$/;
  797. if (! defined $key) {
  798. my ($pkg, $file, $line, $sub) = caller(2);
  799. push @sderror, "internal: error parsing form output in $sub\n";
  800. return;
  801. }
  802. shift @$rvalue if $rvalue->[0] eq '';
  803. foreach my $rfn (@rfns, \&ParseDefault) {
  804. $rform->{$key} = &$rfn($key, $rvalue);
  805. last if defined $rform->{$key};
  806. }
  807. }
  808. #
  809. # ParseForm - Read and parse client/change -o style output. fh is filehandle
  810. # to read from. rfns is a list of callbacks for parsing records in an fh-
  811. # specific way. Each rfn returns specialized parsed output or undef for
  812. # records to be handled by another callback. Records not handled by any
  813. # callback are handled in the default fashion -- as simple scalars, with
  814. # multiple lines joined separated (but not terminated) by \n. Return form.
  815. # A record starts with a line matching ^\w+: and ends before the first line not
  816. # matching ^\s. Leading blank/comment lines are ignored. Embedded full-line
  817. # comments (i.e. those starting with a # in column 0) become empty lines.
  818. # The leading \s of other data lines is stripped. Callbacks are responsible
  819. # for handling embedded comments and whitespace as they see fit. These
  820. # convoluted rules are an approximation of a rationalization of what SD
  821. # itself seems to do, leaning towards being more permissive than SD with the
  822. # placement of comments.
  823. #
  824. sub ParseForm (*;@) {
  825. my($fh, @rfns) = @_;
  826. my (@value, %form);
  827. my $fheader = '\\s*'; # also 'true'
  828. while (my $rec = readfilt $fh, 'info') {
  829. # skip header comments/whitespace lines
  830. next if $fheader && $rec =~ /^info: \s*(#.*)?$/;
  831. if ($rec =~ /^info: $fheader(\w+:.*)$/) {
  832. # process accumulated value and start a new one
  833. SetFormRecord(\%form, \@value, @rfns) if @value > 0;
  834. undef @value;
  835. push @value, $1; # first line is definition line
  836. } elsif ($rec =~ /^info: \s(.*)$/) {
  837. enext $rec if $fheader; # should have seen a first line by now
  838. push @value, $1; # accumulate continuation line bodies
  839. } elsif ($rec =~ /^info: (#|$)/) {
  840. push @value, ''; # full-line comments and empty lines
  841. } else { # become empty lines
  842. enext $rec;
  843. }
  844. $fheader = ''; # also 'false'
  845. }
  846. # process remaining accumulated value
  847. SetFormRecord(\%form, \@value, @rfns) if @value > 0;
  848. return \%form;
  849. }
  850. #
  851. # ParseFormFile - Open file specified by fspec and parse its contents as a
  852. # form. Return form/undef on success/failure.
  853. #
  854. sub ParseFormFile {
  855. my($fspec, @rfns) = @_;
  856. if (! open(FILE, $fspec)) {
  857. push @sderror, "internal: can't open $fspec for read\n";
  858. return;
  859. }
  860. my $rform = ParseForm(*FILE, @rfns);
  861. close FILE;
  862. return if $? != 0;
  863. return wantarray ? %$rform : $rform;
  864. }
  865. #
  866. # ParseFormCmd - Spawn command specified by cmd and parse its output as a form.
  867. # Return form/undef on success/failure.
  868. #
  869. sub ParseFormCmd {
  870. my($cmd, @rfns) = @_;
  871. sdpopen(*PIPE, $cmd) || return;
  872. my $rform = ParseForm(*PIPE, @rfns);
  873. sdpclose PIPE;
  874. return if $? != 0;
  875. return wantarray ? %$rform : $rform;
  876. }
  877. #
  878. # CreateFiles - CreateForm callback creates sd change Files lines. Keep in
  879. # sync with ParseFiles.
  880. #
  881. sub CreateFiles {
  882. my($fh, $key, $rvalue) = @_;
  883. return if $key ne 'Files';
  884. foreach my $rhash (@$rvalue) {
  885. print $fh "\t$rhash->{depotFile}\t# $rhash->{action}\n";
  886. }
  887. return 1;
  888. }
  889. #
  890. # CreateView - CreateForm callback creates sd client View lines. Keep in sync
  891. # with ParseView.
  892. #
  893. sub CreateView {
  894. my($fh, $key, $rvalue) = @_;
  895. return if $key ne 'View';
  896. foreach my $rhash (@$rvalue) {
  897. my $m = $rhash->{unmap} ? '-' : (exists $rhash->{unmap} ? '+' : '');
  898. my $t = $rhash->{targetSpec} ? " $rhash->{targetSpec}" : '';
  899. print $fh "\t$m$rhash->{depotSpec}$t\n";
  900. }
  901. return 1;
  902. }
  903. #
  904. # CreateOptions - CreateForm callback creates sd client Options lines. Keep in
  905. # sync with ParseOptions.
  906. #
  907. sub CreateOptions {
  908. my($fh, $key, $rvalue) = @_;
  909. return if $key ne 'Options';
  910. my @fields;
  911. foreach my $field (sort keys %$rvalue) {
  912. my $prefix =
  913. $rvalue->{$field} ? '' : ($field eq 'locked' ? 'un' : 'no');
  914. push @fields, "$prefix$field";
  915. }
  916. print $fh "\t", join(' ', @fields), "\n";
  917. return 1;
  918. }
  919. #
  920. # CreateDefault - CreateForm callback implements default output.
  921. #
  922. sub CreateDefault {
  923. my($fh, $key, $value) = @_;
  924. if (ref $value ne 'ARRAY') { # non-arrays
  925. print $fh "\t", join("\n\t", split(/\n/, $value)), "\n";
  926. } else { # arrays
  927. print $fh "\t$_\n" foreach @$value;
  928. }
  929. return 1;
  930. }
  931. #
  932. # CreateForm - Write client/change -i style input file to filehandle fh.
  933. # Non-arrays are emitted first, followed by arrays. rfns is a list of
  934. # callbacks for emitting records in a form-specific way. Each rfn returns
  935. # undef for records to be handled by another callback. Records not handled by
  936. # any callback are handled in the default way -- where layout is inferred from
  937. # structure of rform:
  938. # - non-array values are split on \n, and emitted starting on same line as key
  939. # (if room)
  940. # - array values are emitted one per line starting on the next line.
  941. # Return 1 for success.
  942. #
  943. # FUTURE: match -o output more closely (principally, order)
  944. #
  945. sub CreateForm {
  946. my($fh, $rform, @rfns) = @_;
  947. print $fh "# A Source Depot Form Specification created by ",
  948. __PACKAGE__, ".pm\n\n";
  949. my ($key, $value);
  950. while (($key, $value) = each %$rform) { # non-arrays
  951. next if ref $value eq 'ARRAY';
  952. print $fh "$key:";
  953. print $fh "\n" if length $key > 6;
  954. foreach my $rfn (@rfns, \&CreateDefault) {
  955. last if defined &$rfn($fh, $key, $value);
  956. }
  957. print $fh "\n";
  958. }
  959. while (($key, $value) = each %$rform) { # array references
  960. next if ref $value ne 'ARRAY';
  961. print $fh "$key:\n";
  962. foreach my $rfn (@rfns, \&CreateDefault) {
  963. last if defined &$rfn($fh, $key, $value);
  964. }
  965. print $fh "\n";
  966. }
  967. return 1;
  968. }
  969. #
  970. # CreateFormFile - Create file specified by fspec and write rform to it.
  971. # Return 1/undef on success/failure.
  972. #
  973. sub CreateFormFile {
  974. my($fspec, $rform, @rfns) = @_;
  975. if (! open(FILE, "> $fspec")) {
  976. push @sderror, "internal: can't open $fspec for write\n";
  977. return;
  978. }
  979. my $ret = CreateForm(*FILE, $rform, @rfns);
  980. close FILE;
  981. return $ret;
  982. }
  983. #
  984. # InitSD - Ensure non-constant package globals are initialized. May be called
  985. # multiple times with no harm. Passing force will cause unconditional
  986. # re-initialization, restoring all configurable options to their defaults.
  987. # Return whether any significant work was done. Adding configurable options
  988. # typically requires changes to InitSD (to set defaults) and to ConfigSD (to
  989. # override).
  990. #
  991. sub InitSD (;$) { # find existing callers who may be passing options
  992. my($force) = @_;
  993. # all internal errors are stored in sderror
  994. # those including 'caller:' indicate coding errors,
  995. # those including 'internal:' indicate SD.pm errors
  996. clearwarnerr;
  997. if (! $finitsd || $force) { # first time or forced only
  998. # environmental sanity
  999. my $temp = $ENV{TEMP};
  1000. if (! defined $temp || ! -d $temp) {
  1001. # warn __PACKAGE__ . ".pm: %TEMP% not defined or not a valid directory\n";
  1002. $temp = 'c:\\';
  1003. } else {
  1004. # keep internal fspecs short to reduce need for quoting
  1005. $temp = Win32::GetShortPathName($temp);
  1006. }
  1007. # all forms are written to frmfspec
  1008. # argument lists too long for cmd.exe are written to argfspec
  1009. # ini files to suppress options are written to inifspec
  1010. $frmfspec = "$temp\\sdpm$$.frm";
  1011. $argfspec = "$temp\\sdpm$$.arg";
  1012. $inifspec = "$temp\\sdpm$$.ini";
  1013. my $binarch = '';
  1014. if (defined $ENV{OTOOLS}) {
  1015. $binarch = "$ENV{OTOOLS}\\bin\\$ENV{PROCESSOR_ARCHITECTURE}\\";
  1016. # short name avoids spaces; quoting commands confuses system
  1017. $binarch = Win32::GetShortPathName($binarch);
  1018. }
  1019. # all referenced tools are in bin
  1020. %bin = (
  1021. copy => "$ENV{COMSPEC} /c copy >nul",
  1022. sd => "${binarch}sd.exe",
  1023. sd2 => "${binarch}sd$$.exe", # created on demand
  1024. );
  1025. # all configurable options are in config
  1026. %config = (
  1027. binarch => $binarch,
  1028. client => undef,
  1029. dir => undef,
  1030. echo => echoNone,
  1031. echofunc => undef,
  1032. ini => undef,
  1033. maxresults => undef,
  1034. password => undef,
  1035. port => undef,
  1036. safesync => 0,
  1037. user => undef,
  1038. verbose => defined $ENV{OVERBOSE},
  1039. );
  1040. $finitsd = 1;
  1041. return 1;
  1042. }
  1043. return;
  1044. }
  1045. #
  1046. # ConfigSD - Configure specified SD options. Only those options specified are
  1047. # affected by a call to ConfigSD. Return previous set of options. Adding
  1048. # options typically requires changes to InitSD (to set defaults) and to
  1049. # ConfigSD (to override).
  1050. #
  1051. # Options:
  1052. # binarch => 'd:\\bin' - directory containing sd.exe
  1053. # client => 'CLIENT' - client name (overrides sd.ini, etc.)
  1054. # dir => 'd:\\client' - assumed current directory (overrides real cd)
  1055. # echo => echoText | echoInfo | echoWarning | echoError
  1056. # - stdout echos sd text/info/warning/error output
  1057. # echofunc => &myecho - caller-provided function handles echo output
  1058. # maxresults=> 50000 - set maxresults (to value smaller than default)
  1059. # ini => 'd:\\MY.INI' - settings file (overrides sd.ini)
  1060. # password => 'itgrules' - user password (overrides logged-on credentials)
  1061. # port => 'DEPOT:4000' - server port (overrides sd.ini, etc.)
  1062. # safesync => 1 - sync operations protect themselves against
  1063. # attempts to sync sd.exe
  1064. # user => 'DOMAIN\\user'
  1065. # - user name (overrides logged-on credentials)
  1066. # verbose => 1 - print debugging text
  1067. #
  1068. # NOTE: echo may not be supportable using SDAPI
  1069. #
  1070. # FUTURE: warn if directory doesn't exist for dir, file doesn't exist for ini?
  1071. #
  1072. sub ConfigSD {
  1073. my $roptions = rshifthash(@_);
  1074. die __PACKAGE__ . ".pm: ConfigSD: InitSD not called\n" if ! $finitsd;
  1075. foreach my $key (keys %$roptions) {
  1076. warn __PACKAGE__ . ".pm: ConfigSD: unrecognized option '$key' ignored\n"
  1077. if ! exists $config{$key};
  1078. }
  1079. my %configSav = %config;
  1080. if (exists $roptions->{binarch}) {
  1081. my $binarch = $roptions->{binarch};
  1082. $binarch .= '\\' if $binarch !~ /[:\\]$/;
  1083. # short name avoids spaces; quoting commands confuses system
  1084. $binarch = Win32::GetShortPathName($binarch);
  1085. $config{binarch} = $binarch;
  1086. $bin{sd} = "${binarch}sd.exe";
  1087. $bin{sd2} = "${binarch}sd$$.exe"; # created on demand
  1088. }
  1089. if (exists $roptions->{echofunc}) {
  1090. my $rfunc = $roptions->{echofunc};
  1091. if (! defined $rfunc || ref $rfunc eq 'CODE') {
  1092. $config{echofunc} = $roptions->{echofunc};
  1093. } else {
  1094. warn __PACKAGE__ .
  1095. ".pm: ConfigSD: echofunc argument not a code reference\n";
  1096. }
  1097. }
  1098. if (exists $roptions->{maxresults}) {
  1099. my $maxresults = $roptions->{maxresults};
  1100. if (! defined $maxresults || $maxresults =~ /^\d+$/) {
  1101. $config{maxresults} = $roptions->{maxresults};
  1102. } else {
  1103. warn __PACKAGE__ .
  1104. ".pm: ConfigSD: maxresults argument not numeric\n";
  1105. }
  1106. }
  1107. my @keys = qw(client dir echo ini password port safesync user verbose);
  1108. foreach my $key (@keys) {
  1109. $config{$key} = $roptions->{$key} if exists $roptions->{$key};
  1110. }
  1111. return wantarray ? %configSav : \%configSav;
  1112. }
  1113. #
  1114. # Standard exports - map directly to SD commands. Function descriptions are
  1115. # short reminders about syntax and otherwise, specific to perl implementation;
  1116. # see sd help command for more detailed info.
  1117. #
  1118. #
  1119. # SD*Branch - Create or edit a branch specification and its view.
  1120. #
  1121. #
  1122. # sd branch [-f] name
  1123. # SDBranch([\'-f',] 'name')
  1124. #
  1125. # Return name/undef on success/failure.
  1126. #
  1127. sub SDBranch {
  1128. my $opts = shiftopts(@_);
  1129. my $name = crtquote(@_);
  1130. clearwarnerr;
  1131. my $rout = ShowForm("branch $opts -- $name");
  1132. return if ! defined $rout;
  1133. return $1 if @$rout == 1 && $rout->[0] =~ /^info: Branch (.*) (sav|not chang)ed\.$/;
  1134. return;
  1135. }
  1136. #
  1137. # sd branch -o name
  1138. # SDGetBranch('name')
  1139. #
  1140. # %branch = (
  1141. # 'Branch' => 'branch',
  1142. # ... # other scalar fields
  1143. # 'Options' => {
  1144. # 'locked' => 1,
  1145. # },
  1146. # 'View' => [
  1147. # { 'depotSpec' => '//depot/dev/...', # NOTE: SD.pm invention
  1148. # 'targetSpec' => '//depot/pts/...' }, # NOTE: SD.pm invention
  1149. # 'unmap' => 1 }, # if file is not mapped
  1150. # ...
  1151. # ]
  1152. # )
  1153. #
  1154. # Return %branch/undef on success/failure.
  1155. #
  1156. sub SDGetBranch {
  1157. my $name = crtquote(@_);
  1158. clearwarnerr;
  1159. return ParseFormCmd("branch -o $name", \&ParseOptions, \&ParseView);
  1160. }
  1161. #
  1162. # SD*Change - Create or edit a changelist description.
  1163. #
  1164. #
  1165. # sd change [-f] [changelist#]
  1166. # SDChange([\'-f',] [$ncl])
  1167. #
  1168. # sd change -C description
  1169. # SDChange([\'-C description'])
  1170. #
  1171. # Return ncl/undef on success/failure.
  1172. #
  1173. sub SDChange {
  1174. my $opts = shiftopts(@_);
  1175. my($ncl) = @_;
  1176. clearwarnerr;
  1177. nclnorm($ncl, '') || return;
  1178. my $rout = ShowForm("change $opts -- $ncl");
  1179. return if ! defined $rout;
  1180. return $1 if @$rout == 1 && $rout->[0] =~ /^info: Change (\d+) (creat|updat)ed/;
  1181. return;
  1182. }
  1183. #
  1184. # sd change -o [changelist#]
  1185. # SDGetChange([$ncl])
  1186. #
  1187. # %change = (
  1188. # 'Change' => 12345, # or 'new'
  1189. # 'Client' => 'MYCLIENTNAME',
  1190. # 'Date' => '2001/05/07 09:25:24',
  1191. # 'Description' => 'text description of change'
  1192. # 'Status' => 'submitted',
  1193. # 'User' => 'MYDOMAIN\\myalias',
  1194. # 'Files' => [
  1195. # { 'depotFile' => '//depot/dev/src/code.c',
  1196. # 'rev' => 23, # only in SDDescribe
  1197. # 'action' => 'edit' },
  1198. # ...
  1199. # ]
  1200. # )
  1201. #
  1202. # Return %change/undef on success/failure.
  1203. #
  1204. # FUTURE: parse Files, Jobs info further
  1205. #
  1206. sub SDGetChange {
  1207. my($ncl) = @_;
  1208. clearwarnerr;
  1209. nclnorm($ncl, '') || return;
  1210. return ParseFormCmd("change -o $ncl", \&ParseFiles);
  1211. }
  1212. #
  1213. # sd change -i [-f] < changefspec
  1214. # SDSetChange([\'-f',] [\]%change)
  1215. #
  1216. # %change formatted as described at SDGetChange.
  1217. #
  1218. # Return changelist#/undef on success/failure.
  1219. #
  1220. sub SDSetChange {
  1221. my $opts = shiftopts(@_);
  1222. my $rchange = rshifthash(@_);
  1223. clearwarnerr;
  1224. # Status field not allowed to be sent back to server (1.7)
  1225. # FUTURE: when someone notices, restore Status in case it's caller's
  1226. delete $rchange->{Status};
  1227. return if ! CreateFormFile($frmfspec, $rchange, \&CreateFiles);
  1228. sdpopen(*PIPE, "change -i $opts <\"$frmfspec\"") || return;
  1229. my @out = readfilt PIPE;
  1230. sdpclose PIPE;
  1231. unlink $frmfspec if ! $config{verbose};
  1232. return if $? != 0;
  1233. return $1 if @out == 1 && $out[0] =~ /^info: Change (\d+) (creat|updat)ed/;
  1234. return;
  1235. }
  1236. #
  1237. # SDNewChange - Create a new, empty change. Prototyped like SDSetChange.
  1238. #
  1239. sub SDNewChange {
  1240. return SDSetChange(@_, {
  1241. Change => 'new',
  1242. Description => '<created empty by ' . __PACKAGE__ . '.pm>',
  1243. });
  1244. }
  1245. #
  1246. # sd change -d [-f] changelist#
  1247. # SDDelChange([\'-f',] $ncl)
  1248. #
  1249. # Return changelist#/undef on success/failure.
  1250. #
  1251. sub SDDelChange {
  1252. my $opts = shiftopts(@_);
  1253. my($ncl) = @_;
  1254. clearwarnerr;
  1255. nclnorm($ncl) || return;
  1256. sdpopen(*PIPE, "change -d $opts $ncl") || return;
  1257. my @out = readfilt PIPE;
  1258. sdpclose PIPE;
  1259. return if $? != 0;
  1260. return $1 if @out == 1 && $out[0] =~ /^info: Change (\d+) deleted\.$/;
  1261. return;
  1262. }
  1263. #
  1264. # SDChanges - Display list of pending and submitted changelists.
  1265. #
  1266. # sd changes [-i -l -m [skip,]count -r -s status -u user] [file[revRange] ...]
  1267. # SDChanges([\'-i -m [skip,]count -r -s status -u user',]
  1268. # 'file[revRange]'[, ...])
  1269. #
  1270. # @changes = (
  1271. # \%change1, # subset of structure described at SDGetChange
  1272. # \%change2,
  1273. # ...
  1274. # )
  1275. #
  1276. # Return @changes/undef on success/failure.
  1277. #
  1278. # NOTE: In SD.pm, field names match sd change -o, not SDAPI (i.e. proper case
  1279. # not lower case, Description, not desc.)
  1280. # FUTURE: handle output from -l option
  1281. #
  1282. sub SDChanges {
  1283. my $opts = shiftopts(@_);
  1284. my @files = @_;
  1285. clearwarnerr;
  1286. my @changes;
  1287. sdpopen(*PIPE, "changes $opts --", @files) || return;
  1288. while (my $rec = readfilt PIPE) {
  1289. enext $rec if $rec !~ m!^info: Change (\d+) on ($redatime) by $reduc2 (\*pending\* )?'(.*)'$!;
  1290. my $rh = { 'Change' => $1, 'Date' => $2, 'User' => $3,
  1291. 'Client' => $4, 'Description' => $6 };
  1292. $rh->{Status} = defined $5 ? 'pending' : 'submitted';
  1293. push @changes, $rh;
  1294. }
  1295. sdpclose PIPE;
  1296. return if $? != 0;
  1297. return wantarray ? @changes : \@changes;
  1298. }
  1299. #
  1300. # SD*Counter - Display, set, or delete a counter.
  1301. #
  1302. #
  1303. # sd counter name
  1304. # SDGetCounter('name')
  1305. #
  1306. # Return counter value/undef on success/failure.
  1307. #
  1308. sub SDGetCounter {
  1309. my $name = crtquote(shift @_);
  1310. clearwarnerr;
  1311. sdpopen(*PIPE, "counter $name") || return;
  1312. my @out = readfilt PIPE;
  1313. sdpclose PIPE;
  1314. return if $? != 0;
  1315. return $1 if @out == 1 && $out[0] =~ /^info: (\d+)$/;
  1316. return;
  1317. }
  1318. #
  1319. # sd counter name value
  1320. # SDSetCounter('name', value)
  1321. #
  1322. # Return name/undef on success/failure.
  1323. #
  1324. sub SDSetCounter {
  1325. my $name = crtquote(shift @_);
  1326. my $value = crtquote(shift @_);
  1327. clearwarnerr;
  1328. sdpopen(*PIPE, "counter $name $value") || return;
  1329. my @out = readfilt PIPE;
  1330. sdpclose PIPE;
  1331. return if $? != 0;
  1332. return $1 if @out == 1 && $out[0] =~ /^info: Counter (.+) set\.$/;
  1333. return;
  1334. }
  1335. #
  1336. # sd counter -d name
  1337. # SDDelCounter('name')
  1338. #
  1339. # Return name/undef on success/failure.
  1340. #
  1341. sub SDDelCounter {
  1342. my($name) = crtquote(shift @_);
  1343. clearwarnerr;
  1344. sdpopen(*PIPE, "counter -d $name") || return;
  1345. my @out = readfilt PIPE;
  1346. sdpclose PIPE;
  1347. return if $? != 0;
  1348. return $1 if @out == 1 && $out[0] =~ /^info: Counter (.+) deleted\.$/;
  1349. return;
  1350. }
  1351. #
  1352. # SDCounters - Display list of known counters.
  1353. #
  1354. # sd counters
  1355. # SDCounters()
  1356. #
  1357. # %counters = (
  1358. # 'CHANGE' => 123456,
  1359. # 'USERCOUNTER' => 234,
  1360. # ...
  1361. # )
  1362. #
  1363. # Return %counters/undef on success/failure.
  1364. #
  1365. # NOTE: In SD.pm, counter names are guaranteed to be upper-case; in sd.exe user
  1366. # case is preserved.
  1367. #
  1368. sub SDCounters {
  1369. clearwarnerr;
  1370. my %counters;
  1371. sdpopen(*PIPE, "counters") || return;
  1372. while (my $rec = readfilt PIPE) {
  1373. enext $rec if $rec !~ /^info: (.*?) = (\d+)$/;
  1374. $counters{"\U$1\E"} = $2;
  1375. }
  1376. sdpclose PIPE;
  1377. return if $? != 0;
  1378. return wantarray ? %counters : \%counters;
  1379. }
  1380. #
  1381. # SD*Client - Create or edit a client specification and its view.
  1382. #
  1383. #
  1384. # sd client [-f -t template] [name]
  1385. # SDClient([\'-f -t template',] ['name'])
  1386. #
  1387. # Return 1/undef on success/failure.
  1388. #
  1389. sub SDClient {
  1390. my $opts = shiftopts(@_);
  1391. my $name = crtquote(@_);
  1392. clearwarnerr;
  1393. my $rout = ShowForm("client $opts -- $name");
  1394. return if ! defined $rout;
  1395. return $1 if @$rout == 1 && $rout->[0] =~ /^info: Client (.+) (sav|not chang)ed\.$/;
  1396. return;
  1397. }
  1398. #
  1399. # sd client -o [-t template] [name]
  1400. # SDGetClient([\'-t template',] ['name'])
  1401. #
  1402. # %client = (
  1403. # 'Client' => 'MYCLIENTNAME',
  1404. # ... # other scalar fields
  1405. # 'Options' => {
  1406. # 'allwrite' => 0,
  1407. # 'clobber' => 0, # values shown
  1408. # 'compress' => 0, # here match sd
  1409. # 'crlf' => 1, # defaults
  1410. # 'locked' => 1,
  1411. # 'modtime' => 0,
  1412. # 'rmdir' => 1,
  1413. # },
  1414. # 'View' => [
  1415. # { 'depotSpec' => '//depot/dev/...', # NOTE: SD.pm invention
  1416. # 'targetSpec' => '//CLIENT/dev/...' }, # NOTE: SD.pm invention
  1417. # { 'depotSpec' => '//depot/dev/intl/...',
  1418. # 'targetSpec' => '//CLIENT/dev/intl/...'
  1419. # 'unmap' => 1 }, # if file is not mapped
  1420. # ...
  1421. # ]
  1422. # )
  1423. #
  1424. # Return %client/undef on success/failure.
  1425. #
  1426. sub SDGetClient {
  1427. my $opts = shiftopts(@_);
  1428. my $name = crtquote(@_);
  1429. clearwarnerr;
  1430. return ParseFormCmd("client -o $opts -- $name", \&ParseOptions, \&ParseView);
  1431. }
  1432. #
  1433. # sd client -i [-f] < clientfspec
  1434. # SDSetClient([\'-f',] [\]%client)
  1435. #
  1436. # %client formatted as described at SDGetClient.
  1437. #
  1438. # Return name/undef on success/failure.
  1439. #
  1440. sub SDSetClient {
  1441. my $opts = shiftopts(@_);
  1442. my $rclient = rshifthash(@_);
  1443. clearwarnerr;
  1444. return if ! CreateFormFile($frmfspec, $rclient, \&CreateOptions, \&CreateView);
  1445. sdpopen(*PIPE, "client -i $opts <\"$frmfspec\"") || return;
  1446. my @out = readfilt PIPE;
  1447. sdpclose PIPE;
  1448. unlink $frmfspec if ! $config{verbose};
  1449. return if $? != 0;
  1450. return $1 if @out == 1 && $out[0] =~ /^info: Client (.+) (sav|not chang)ed\.$/;
  1451. return;
  1452. }
  1453. #
  1454. # sd client -d [-f] name
  1455. # SDDelClient([\'-f',] 'name')
  1456. #
  1457. # Return name/undef on success/failure.
  1458. #
  1459. sub SDDelClient {
  1460. my $opts = shiftopts(@_);
  1461. my $name = crtquote(@_);
  1462. clearwarnerr;
  1463. sdpopen(*PIPE, "client -d $opts -- $name") || return;
  1464. my @out = readfilt PIPE;
  1465. sdpclose PIPE;
  1466. return if $? != 0;
  1467. return $1 if @out == 1 && $out[0] =~ /^info: Client (.*) deleted\.$/;
  1468. return;
  1469. }
  1470. #
  1471. # SDClients - Display list of clients.
  1472. #
  1473. # sd clients [-d date[,date] -u user]
  1474. # SDClients([\'-d date[,date] -u user'])
  1475. #
  1476. # @clients = (
  1477. # \%client1, # subset of structure described at SDGetClient
  1478. # \%client2,
  1479. # ...
  1480. # )
  1481. #
  1482. # Return @clients/undef on success/failure.
  1483. #
  1484. sub SDClients {
  1485. my $opts = shiftopts(@_);
  1486. clearwarnerr;
  1487. my @clients;
  1488. sdpopen(*PIPE, "clients $opts") || return;
  1489. while (my $rec = readfilt PIPE) {
  1490. enext $rec if $rec !~ m!^info: Client (\S+) ($redatime) root (.*?) (host (.*) )?'(.*)'$!;
  1491. my $rh = { 'Client' => $1, 'Access' => $2, 'Root' => $3,
  1492. 'Description' => $6 };
  1493. $rh->{Host} = $5 if defined $5;
  1494. push @clients, $rh;
  1495. }
  1496. sdpclose PIPE;
  1497. return if $? != 0;
  1498. return wantarray ? @clients : \@clients;
  1499. }
  1500. #
  1501. # SDDescribe[N] - Display a changelist description
  1502. #
  1503. # sd describe [-d<flag> -s] changelist# ...
  1504. # SDDescribeN([\'-d<flag> -s',] 'changelist#' [, ...])
  1505. #
  1506. # @changes = (
  1507. # \%change1, # as described at SDGetChange
  1508. # \%change2,
  1509. # ...
  1510. # )
  1511. #
  1512. # Return @changes/undef on success/failure.
  1513. #
  1514. # SDDescribe([\'-d<flag> -s',] 'changelist#')
  1515. #
  1516. # Return %change/undef on success/failure.
  1517. #
  1518. # FUTURE: handle output without -s option
  1519. #
  1520. sub SDDescribeN {
  1521. my $opts = shiftopts(@_);
  1522. my @changenums = @_;
  1523. if ($opts !~ /-s/) {
  1524. push @sderror,
  1525. "caller: SDDescribe[N] currently requires passing \\'-s' option\n";
  1526. return;
  1527. }
  1528. clearwarnerr;
  1529. my (%change, @changes, %file, @files);
  1530. sdpopen(*PIPE, "describe $opts --", @changenums) || return;
  1531. while (my $rec = readfilt PIPE) {
  1532. # completely blank lines are just filler
  1533. next if $rec =~ /^text: $/;
  1534. # Change line indicates start of record
  1535. if ($rec =~ /^text: Change (\d+) by $reduc2 on ($redatime)$/) {
  1536. if (keys %change > 0) {
  1537. chomp $change{Description} if exists $change{Description};
  1538. push @changes, { %change };
  1539. }
  1540. undef %change;
  1541. @change{qw(Change User Client Date)} = ($1, $2, $3, $4);
  1542. next;
  1543. }
  1544. if ($rec =~ /^text: Affected files \.\.\.$/) {
  1545. next;
  1546. }
  1547. if ($rec =~ /^text: \t(.*)$/) {
  1548. $change{Description} .= "$1\n";
  1549. next;
  1550. }
  1551. if ($rec =~ /^info1: (.*)#(\d+) (.*)$/) {
  1552. push @{$change{Files}},
  1553. { 'depotFile' => $1, 'rev' => $2, 'action' => $3 };
  1554. next;
  1555. }
  1556. enext $rec;
  1557. }
  1558. sdpclose PIPE;
  1559. # handle any partial record
  1560. if (keys %change > 0) {
  1561. chomp $change{Description} if exists $change{Description};
  1562. push @changes, { %change };
  1563. }
  1564. return if @changes == 0;
  1565. return wantarray ? @changes : \@changes;
  1566. }
  1567. sub SDDescribe { return nto1 SDDescribeN(@_); }
  1568. #
  1569. # SDDiff[N] - Display diff of client file with depot file.
  1570. #
  1571. # sd diff [-d<flag> -f -s<flag> -t] [-c changelist#] [file[rev] ...]
  1572. # SDDiffN([\'-d<flag> -f -s<flag> -t -c changelist#',] ['file[rev]'][, ...])
  1573. #
  1574. # @diffs = (
  1575. # \%diff1, # as described below
  1576. # \%diff2,
  1577. # ...
  1578. # )
  1579. #
  1580. # Return @diffs/undef on success/failure.
  1581. #
  1582. # SDDiff([\'-d<flag> -f -s<flag> -t -c changelist#',] 'file[rev]')
  1583. #
  1584. # %diff = {
  1585. # 'depotFile' => '//depot/dev/src/code.c',
  1586. # 'depotRev' => 4, # FUTURE: haveRev?
  1587. # 'localFile' => 'd:\\Office\\dev\\src\\code.c',
  1588. # 'diff' => ["5c5\n", "< old\n", "---\n", "> new\n"]
  1589. # }
  1590. #
  1591. # Return %diff/undef on success/failure. Depending on options, not all
  1592. # fields will exist.
  1593. #
  1594. # FUTURE: parse expected errors
  1595. # /(.*) - file\(s\) not opened on this client\.$/
  1596. #
  1597. sub SDDiffN {
  1598. my $opts = shiftopts(@_);
  1599. my @files = @_;
  1600. clearwarnerr;
  1601. # SD prefers settings from user .ini file, sd.ini, environment and registry
  1602. # (in that order) for all but DIFF, which is environment-only. Suppress
  1603. # any user configuration of diff tool to use to ensure we get expected text
  1604. # output. First, eliminate the easy-to-clobber environment variables.
  1605. local $ENV{SDDIFF};
  1606. local $ENV{SDUDIFF};
  1607. local $ENV{DIFF};
  1608. # If something's still set, override with a private .ini file. Multiple
  1609. # .ini files are processed left to right, so make private one last to
  1610. # ensure it overrides all (including any ConfigSD-specified ones).
  1611. # FUTURE: should we override ConfigSD-specified values?
  1612. # FUTURE: adding $iniarg as start of $cmd is a mildly evil hack
  1613. my $iniarg = '';
  1614. my $rset = SDSet();
  1615. if (exists $rset->{SDDIFF} || exists $rset->{SDUDIFF}) {
  1616. if (! open(FILE, "> $inifspec")) {
  1617. push @sderror, "internal: can't open $inifspec for write\n";
  1618. return;
  1619. }
  1620. print FILE "SDDIFF=\nSDUDIFF=\n";
  1621. close FILE;
  1622. $iniarg = "-i \"$inifspec\"";
  1623. }
  1624. my (%diff, @diffs);
  1625. sdpopen(*PIPE, "$iniarg diff $opts --", @files) || return;
  1626. while (my $rec = readfilt PIPE, 'text') {
  1627. # ==== line indicates start of record
  1628. if ($rec =~ /^info: ==== (.*?)#(\d+) - (.*) ====$/) {
  1629. push @diffs, { %diff } if keys %diff > 0;
  1630. undef %diff;
  1631. @diff{qw(depotFile depotRev localFile)} = ($1, $2, $3);
  1632. next;
  1633. }
  1634. # no ==== line indicates summary (localFile only)
  1635. if (keys %diff == 0) {
  1636. $rec =~ /^info: (.*)$/;
  1637. $diff{localFile} = $1;
  1638. push @diffs, { %diff };
  1639. undef %diff;
  1640. next;
  1641. }
  1642. enext $rec if $rec !~ /^text: (.*)$/;
  1643. push @{$diff{diff}}, $1;
  1644. }
  1645. sdpclose PIPE;
  1646. unlink $inifspec if $iniarg ne '' && ! $config{verbose};
  1647. # handle any partial record
  1648. push @diffs, { %diff } if keys %diff > 0;
  1649. return if @diffs == 0;
  1650. return wantarray ? @diffs : \@diffs;
  1651. }
  1652. sub SDDiff { return nto1 SDDiffN(@_); }
  1653. #
  1654. # SDDiff2[N] - Display diff of two depot files.
  1655. #
  1656. # sd diff2 [-d<flag> -q -r -t] file1 file2
  1657. # SDDiff2N([\'-d<flag> -q -r -t',] 'file1', 'file2')
  1658. #
  1659. # @diffs = (
  1660. # \%diff1, # as described below
  1661. # \%diff2,
  1662. # ...
  1663. # )
  1664. #
  1665. # Return @diffs/undef on success/failure.
  1666. #
  1667. # SDDiff2([\'-d<flag> -q -r -t',] 'file1', 'file2')
  1668. #
  1669. # %diff = {
  1670. # 'how' => 'content',
  1671. # 'depotFileLeft' => '//depot/dev/src/code.c',
  1672. # 'depotRevLeft' => 4,
  1673. # 'depotTypeLeft' => 'text',
  1674. # 'depotFileRight' => '//depot/dev/src/code.c',
  1675. # 'depotRevRight' => 5,
  1676. # 'depotTypeRight' => 'text',
  1677. # 'diff' => ["5c5\n", "< old\n", "---\n", "> new\n"]
  1678. # }
  1679. #
  1680. # Return %diff/undef on success/failure. Depending on options, not all
  1681. # fields will exist.
  1682. #
  1683. # FUTURE: parse expected errors
  1684. # /^==== <none> - //depot/dev/src/code.c#4 ====$/
  1685. #
  1686. sub SDDiff2N {
  1687. my $opts = shiftopts(@_);
  1688. my @files = @_;
  1689. clearwarnerr;
  1690. my (%diff, @diffs);
  1691. sdpopen(*PIPE, "diff2 $opts --", @files) || return;
  1692. while (my $rec = readfilt PIPE) {
  1693. # ==== line indicates start of record
  1694. if ($rec =~ /^info: ==== (.*?)#(\d+) \((.*?)\) - (.*?)#(\d+) \((.*?)\) ==== (.*)$/) {
  1695. push @diffs, { %diff } if keys %diff > 0;
  1696. undef %diff;
  1697. @diff{qw(depotFileLeft depotRevLeft depotTypeLeft)} = ($1, $2, $3);
  1698. @diff{qw(depotFileRight depotRevRight depotTypeRight)} = ($4, $5, $6);
  1699. $diff{how} = $7;
  1700. next;
  1701. }
  1702. next if $rec =~ /^info: \(\.\.\. files differ \.\.\.\)$/;
  1703. enext $rec if $rec !~ /^text: (.*)$/;
  1704. push @{$diff{diff}}, $1;
  1705. }
  1706. sdpclose PIPE;
  1707. # handle any partial record
  1708. push @diffs, { %diff } if keys %diff > 0;
  1709. return if @diffs == 0;
  1710. return wantarray ? @diffs : \@diffs;
  1711. }
  1712. sub SDDiff2 { return nto1 SDDiff2N(@_); }
  1713. #
  1714. # SDDirs - List subdirectories of a given depot directory.
  1715. #
  1716. # sd dirs [-C -D -H] dir[revRange] ...
  1717. # SDDirs([\'-C -D -H',] 'dir[revRange]'[, ...])
  1718. #
  1719. # @dirs = (
  1720. # 'dir1',
  1721. # 'dir2',
  1722. # ...
  1723. # )
  1724. #
  1725. # Return @dirs/undef on success/failure.
  1726. #
  1727. sub SDDirs {
  1728. my $opts = shiftopts(@_);
  1729. my @indirs = @_;
  1730. clearwarnerr;
  1731. my @dirs;
  1732. sdpopen(*PIPE, "dirs $opts --", @indirs) || return;
  1733. while (my $rec = readfilt PIPE) {
  1734. enext $rec if $rec !~ m!^info: (.+)$!;
  1735. push @dirs, $1;
  1736. }
  1737. sdpclose PIPE;
  1738. return if $? != 0;
  1739. return wantarray ? @dirs : \@dirs;
  1740. }
  1741. #
  1742. # OpenFilesN - Edit/Add/Delete implementation. Keep in sync with SDReopenN.
  1743. #
  1744. # FUTURE: parse expected errors
  1745. # /(.*) - file\(s\) not on client\.$/
  1746. # /(.*) - missing, unable to determine file type/
  1747. #
  1748. sub OpenFilesN {
  1749. my $command = shift(@_);
  1750. my $opts = shiftopts(@_);
  1751. my $ncl = shift(@_);
  1752. my @files = @_;
  1753. clearwarnerr;
  1754. nclnorm($ncl, 'default') || return;
  1755. my @open;
  1756. sdpopen(*PIPE, "$command -c $ncl $opts --", @files) || return;
  1757. while (my $rec = readfilt PIPE) {
  1758. enext $rec
  1759. if $rec !~ /^info: (.*)#(\d+) -( currently)? opened for (\w+)( \(\w+\))?$/;
  1760. push @open, { 'depotFile' => $1, 'haveRev' => $2, 'action' => $4 };
  1761. }
  1762. sdpclose PIPE;
  1763. return if @open == 0;
  1764. return wantarray ? @open : \@open;
  1765. }
  1766. #
  1767. # SDEdit[N] - Open an existing file for edit.
  1768. # SDAdd[N] - Open a new file to add it to the depot.
  1769. # SDDelete[N] - Open an existing file to delete it from the depot.
  1770. #
  1771. # sd edit [-c changelist#] [-t type] [-y] file ...
  1772. # SDEditN([\'-t type -y',] $ncl, 'file'[, ...])
  1773. #
  1774. # sd add [-c changelist#] [-t type] file ...
  1775. # SDAddN([\'-t type',] $ncl, 'file'[, ...])
  1776. #
  1777. # sd delete [-c changelist#] [-y] file ...
  1778. # SDDeleteN([\'-y',] $ncl, 'file'[, ...])
  1779. #
  1780. # @open = (
  1781. # \%open1, # as described below
  1782. # \%open2,
  1783. # ...
  1784. # )
  1785. #
  1786. # Return @open/undef on success/failure.
  1787. #
  1788. # SDEdit([\'-t type -y',] $ncl, 'file')
  1789. # SDAdd([\'-t type',] $ncl, 'file')
  1790. # SDDelete([\'-y',] $ncl, 'file')
  1791. #
  1792. # %open = {
  1793. # 'depotFile' => '//depot/dev/src/code.c',
  1794. # 'action' => 'edit', # or 'add' or 'delete'
  1795. # 'haveRev' => 4 # 1 for action => 'add' # FUTURE: actually workRev
  1796. # }
  1797. #
  1798. # Return %open (subset of structure described at SDFstat)/undef on
  1799. # success/failure.
  1800. #
  1801. # A changelist# is always required; specify nclDefault to use default
  1802. # changelist.
  1803. #
  1804. sub SDEditN { return OpenFilesN('edit', @_); }
  1805. sub SDAddN { return OpenFilesN('add', @_); }
  1806. sub SDDeleteN { return OpenFilesN('delete', @_); }
  1807. sub SDEdit { return nto1 OpenFilesN('edit', @_); }
  1808. sub SDAdd { return nto1 OpenFilesN('add', @_); }
  1809. sub SDDelete { return nto1 OpenFilesN('delete', @_); }
  1810. #
  1811. # SDFileLog[N] - List revision history of files.
  1812. #
  1813. # sd filelog [-d<flag> -i -l -m [skip,]count -t] file[revRange] ...
  1814. # SDFileLogN([\'-d<flag> -i -l -m [skip,]count -t',] 'file[revRange]'[, ...])
  1815. #
  1816. # @filelogs = (
  1817. # \%filelog1, # as described below
  1818. # \%filelog2,
  1819. # ...
  1820. # )
  1821. #
  1822. # Return @filelogs/undef on success/failure.
  1823. #
  1824. # SDFileLog([\'-d<flag> -i -l -m [skip,]count -t',] 'file[revRange]')
  1825. #
  1826. # %filelog = (
  1827. # 'depotFile' => '//depot/dev/src/code.c',
  1828. # 'changes' => [
  1829. # \%change1, # as described below
  1830. # \%change2,
  1831. # ...
  1832. # ],
  1833. # )
  1834. #
  1835. # %change = (
  1836. # 'rev' => 23,
  1837. # 'change' => 12345,
  1838. # 'action' => 'edit',
  1839. # 'time' => '2001/05/07 09:25:24',
  1840. # 'user' => 'MYDOMAIN\\myalias',
  1841. # 'client' => 'MYCLIENTNAME',
  1842. # 'type' => 'text',
  1843. # )
  1844. #
  1845. # Return %filelog/undef on success/failure.
  1846. #
  1847. # FUTURE: handle output from -d and -l options
  1848. # FUTURE: handle integration history (info2:) according to SDAPI
  1849. #
  1850. sub SDFileLogN {
  1851. my $opts = shiftopts(@_);
  1852. my @files = @_;
  1853. clearwarnerr;
  1854. my @filelogs;
  1855. my %filelog;
  1856. sdpopen(*PIPE, "filelog $opts --", @files) || return;
  1857. while (my $rec = readfilt PIPE) {
  1858. if ($rec =~ /^info: (.*)$/) {
  1859. push @filelogs, { %filelog } if keys %filelog > 0;
  1860. undef %filelog;
  1861. $filelog{depotFile} = $1;
  1862. next;
  1863. }
  1864. if ($rec =~ /^info1: #(\d+) change (\d+) (\w+) on ($redatime) by $reduc2 \((\w+(\+\w+)?)\) '.*'$/) {
  1865. push @{$filelog{changes}},
  1866. { 'rev' => $1, 'change' => $2, 'action' => $3, 'time' => $4,
  1867. 'user' => $5, 'client' => $6, 'type' => $7 };
  1868. next;
  1869. }
  1870. enext $rec if $rec !~ /^info2:/;
  1871. }
  1872. sdpclose PIPE;
  1873. # handle any partial record
  1874. push @filelogs, { %filelog } if keys %filelog > 0;
  1875. return if $? != 0;
  1876. return wantarray ? @filelogs : \@filelogs;
  1877. }
  1878. sub SDFileLog { return nto1 SDFileLogN(@_); }
  1879. #
  1880. # SDFiles[N] - List files in the depot
  1881. #
  1882. # sd files [ -d ] file[revRange] ...
  1883. # SDFilesN([\'-d',] 'file[revRange]'[, ...])
  1884. #
  1885. # @files = (
  1886. # \%file1, # as described below
  1887. # \%file2,
  1888. # ...
  1889. # )
  1890. #
  1891. # Return @files/undef on success/failure.
  1892. #
  1893. # SDFiles([\'-d',] 'file[revRange]')
  1894. #
  1895. # %file = (
  1896. # 'depotFile' => '//depot/dev/src/code.c',
  1897. # 'depotRev' => 3,
  1898. # 'action' => 'edit',
  1899. # 'change' => 33,
  1900. # 'type' => 'text',
  1901. # )
  1902. #
  1903. # Return %file/undef on success/failure.
  1904. #
  1905. sub SDFilesN {
  1906. my $opts = shiftopts(@_);
  1907. my @infiles = @_;
  1908. clearwarnerr;
  1909. my @files;
  1910. sdpopen(*PIPE, "files $opts --", @infiles) || return;
  1911. while (my $rec = readfilt PIPE) {
  1912. enext $rec if $rec !~ m!^info: (.*)#(\d+) - (\w+) change (\d+) \((.*)\)$!;
  1913. push @files, { 'depotFile' => $1, 'depotRev' => $2, 'action' => $3,
  1914. 'change' => $4, 'type' => $5 };
  1915. }
  1916. sdpclose PIPE;
  1917. return if @files == 0;
  1918. return wantarray ? @files : \@files;
  1919. }
  1920. sub SDFiles { return nto1 SDFilesN(@_); }
  1921. #
  1922. # SDFstat[N] - Dump file info.
  1923. #
  1924. # sd fstat [-c changelist#] [-C -H -L -P -s -W] file[rev] ...
  1925. # SDFstatN([\'-c changelist# -C -H -L -P -s -W',] 'file[rev]'[, ...])
  1926. #
  1927. # @files = (
  1928. # \%file1, # as described below
  1929. # \%file2,
  1930. # ...
  1931. # )
  1932. #
  1933. # Return @files/undef on success/failure.
  1934. #
  1935. # SDFstat([\'-c changelist# -C -H -L -P -s -W',] 'file[rev]')
  1936. #
  1937. # %file = (
  1938. # 'depotFile' => '//depot/dev/src/code.c',
  1939. # 'clientFile' => '//CLIENT/dev/src/code.c',
  1940. # 'localFile' => 'd:\\Office\\dev\\src\\code.c',
  1941. # 'action' => 'edit',
  1942. # 'change' => 'default',
  1943. # 'headRev' => 8,
  1944. # 'haveRev' => 8,
  1945. # 'otherOpens' => [ # NOTE: SD.pm invention
  1946. # { 'otherUser' => 'SOMEDOMAIN\\somealias', # NOTE: SD.pm invention
  1947. # 'otherClient' => 'SOMECLIENTNAME', # NOTE: SD.pm invention
  1948. # 'otherAction' => 'edit' }, # or 'add' or 'delete'
  1949. # { 'otherUser' => 'SOMEDOMAIN\\someotheralias',
  1950. # 'otherClient' => 'SOMEOTHERCLIENT',
  1951. # 'otherAction' => 'edit' },
  1952. # ...
  1953. # ]
  1954. # ... # other scalar fields
  1955. # )
  1956. #
  1957. # Return %file/undef on success/failure. Various functions take/return
  1958. # subsets of this structure.
  1959. #
  1960. # These functions are fairly expensive; avoid calling them.
  1961. #
  1962. # NOTE: In SD.pm, clientFile is always in depot syntax, localFile is always
  1963. # in local syntax. sd.exe may put localFile into clientFile, and not provide
  1964. # localFile. For otherOpens, sd.exe provides a username@client, which SD.pm
  1965. # splits into otherUser and otherClient
  1966. #
  1967. # FUTURE: SDFstat('filesyncedtobuildlablabel') (no 'N') will fail because sd
  1968. # fstat returns two records. Merge these into one, perhaps renaming the
  1969. # non-#have depotFile.
  1970. #
  1971. sub SDFstatN {
  1972. my $opts = shiftopts(@_);
  1973. my @infiles = @_;
  1974. clearwarnerr;
  1975. my (%file, @files);
  1976. sdpopen(*PIPE, "fstat $opts --", @infiles) || return;
  1977. while (my $rec = readfilt PIPE) {
  1978. # empty line indicates end of record
  1979. if ($rec =~ /^info:\s*$/ && keys %file > 0) {
  1980. push @files, { %file };
  1981. undef %file;
  1982. next;
  1983. } elsif ($rec =~ /^info1: (\w+) (.*)$/) {
  1984. $file{$1} = $2;
  1985. # without -P, clientFile field is really localFile syntax
  1986. if ($1 eq 'clientFile' && $file{clientFile} !~ m!^//!) {
  1987. $file{localFile} = $file{clientFile};
  1988. delete $file{clientFile};
  1989. }
  1990. } elsif ($rec =~ /^info2:/) {
  1991. if ($rec =~ /^info2: (otherOpen)(\d+) $reduc2$/) {
  1992. $file{otherOpens}->[$2]->{otherUser} = $3;
  1993. $file{otherOpens}->[$2]->{otherClient} = $4;
  1994. } elsif ($rec =~ /^info2: (otherAction)(\d+) (\w+)$/) {
  1995. $file{otherOpens}->[$2]->{$1} = $3;
  1996. } elsif ($rec =~ /^info2: (otherOpen) (\d+)$/) {
  1997. $file{$1} = $2;
  1998. } else {
  1999. enext $rec;
  2000. }
  2001. } else {
  2002. enext $rec;
  2003. }
  2004. }
  2005. sdpclose PIPE;
  2006. # handle any partial record
  2007. push @files, { %file } if keys %file > 0;
  2008. return if @files == 0;
  2009. return wantarray ? @files : \@files;
  2010. }
  2011. sub SDFstat { return nto1 SDFstatN(@_); }
  2012. #
  2013. # SD*Group - Change members of user group.
  2014. #
  2015. #
  2016. # sd group -o name
  2017. # SDGetGroup('name')
  2018. #
  2019. # %group = (
  2020. # 'Group' => 'mygroup',
  2021. # 'MaxResults' => 'default',
  2022. # 'Subgroups' => [
  2023. # 'subgroup1',
  2024. # 'subgroup2',
  2025. # ...
  2026. # ],
  2027. # 'Users' => [
  2028. # 'user1',
  2029. # 'user2',
  2030. # ...
  2031. # ],
  2032. # )
  2033. #
  2034. # Return %group/undef on success/failure.
  2035. #
  2036. sub SDGetGroup {
  2037. my $name = crtquote(@_);
  2038. clearwarnerr;
  2039. return ParseFormCmd("group -o -- $name", \&ParseNames);
  2040. }
  2041. #
  2042. # SDGroups - Display list of defined groups.
  2043. #
  2044. # sd groups
  2045. # SDGroups()
  2046. #
  2047. # @groups = (
  2048. # 'group1',
  2049. # 'group2',
  2050. # ...
  2051. # )
  2052. #
  2053. # Return @groups/undef on success/failure.
  2054. #
  2055. sub SDGroups {
  2056. clearwarnerr;
  2057. my @groups;
  2058. sdpopen(*PIPE, "groups") || return;
  2059. while (my $rec = readfilt PIPE) {
  2060. enext $rec if $rec !~ m!^info: (\S+)$!;
  2061. push @groups, $1;
  2062. }
  2063. sdpclose PIPE;
  2064. return if $? != 0;
  2065. return wantarray ? @groups : \@groups;
  2066. }
  2067. #
  2068. # SDHave[N] - List revisions last synced.
  2069. #
  2070. # sd have [file[revRange] ...]
  2071. # SDHaveN(['file[revRange]', ...])
  2072. #
  2073. # @have = (
  2074. # \%have1, # as described below
  2075. # \%have2,
  2076. # ...
  2077. # )
  2078. #
  2079. # Return @have/undef on success/failure.
  2080. #
  2081. # SDHave('file')
  2082. #
  2083. # %have = {
  2084. # 'depotFile' => '//depot/dev/src/code.c',
  2085. # 'localFile' => 'd:\\Office\\dev\\src\\code.c',
  2086. # 'haveRev' => 4
  2087. # }
  2088. #
  2089. # Return %have (subset of structure described at SDFstat)/undef on
  2090. # success/failure.
  2091. #
  2092. # FUTURE: parse expected errors
  2093. # /(.*) - file\(s\) not on this client\.$/
  2094. #
  2095. sub SDHaveN {
  2096. my @files = @_;
  2097. clearwarnerr;
  2098. my @have;
  2099. sdpopen(*PIPE, "have --", @files) || return;
  2100. while (my $rec = readfilt PIPE) {
  2101. enext $rec if $rec !~ m!^info: (.*)#(\d+) - (.*)$!;
  2102. push @have, { 'depotFile' => $1, 'haveRev' => $2, 'localFile' => $3 };
  2103. }
  2104. sdpclose PIPE;
  2105. return if @have == 0;
  2106. return wantarray ? @have : \@have;
  2107. }
  2108. sub SDHave { return nto1 SDHaveN(@_); }
  2109. #
  2110. # SDInfo - Return client/server information.
  2111. #
  2112. # sd info [-s]
  2113. # SDInfo()
  2114. #
  2115. # %info = (
  2116. # 'Client root' => 'd:\\Office',
  2117. # 'Current directory' => 'd:\\Office\\dev\\lib\\perl\\office',
  2118. # 'Server version' => 'SDS 1.60.2606.0 (NT X86)',
  2119. # ... # other scalar fields
  2120. # )
  2121. #
  2122. # Return %info/undef on success/failure.
  2123. #
  2124. # FUTURE: allow and handle output from -s option?
  2125. # FUTURE: collect non-matching lines as InfoBoilerplateFile?
  2126. #
  2127. sub SDInfo {
  2128. clearwarnerr;
  2129. my %info;
  2130. sdpopen(*PIPE, "info") || return;
  2131. while (my $rec = readfilt PIPE) {
  2132. enext $rec if $rec !~ /^info: (.*?): (.*)$/;
  2133. $info{$1} = $2;
  2134. }
  2135. sdpclose PIPE;
  2136. return if $? != 0;
  2137. return wantarray ? %info : \%info;
  2138. }
  2139. #
  2140. # SD*Label - Create or edit a label specification and its view.
  2141. #
  2142. #
  2143. # sd label -o [-t template] name
  2144. # SDGetLabel([\'-t template',] 'name')
  2145. #
  2146. # %label = (
  2147. # 'Label' => 'latest',
  2148. # ... # other scalar fields
  2149. # 'Options' => {
  2150. # 'locked' => 1
  2151. # },
  2152. # 'View' => [
  2153. # { 'depotSpec' => '//depot/dev/...' }, # NOTE: SD.pm invention
  2154. # ...
  2155. # ]
  2156. # )
  2157. #
  2158. # Return %label/undef on success/failure.
  2159. #
  2160. sub SDGetLabel {
  2161. my $opts = shiftopts(@_);
  2162. my $name = crtquote(@_);
  2163. clearwarnerr;
  2164. return ParseFormCmd("label -o $opts -- $name", \&ParseOptions, \&ParseView);
  2165. }
  2166. #
  2167. # sd label -i < labelfspec
  2168. # SDSetLabel([\'-f',] [\]%label)
  2169. #
  2170. # %label formatted as described at SDGetLabel.
  2171. #
  2172. # Return label/undef on success/failure.
  2173. #
  2174. sub SDSetLabel {
  2175. my $opts = shiftopts(@_);
  2176. my $rlabel = rshifthash(@_);
  2177. clearwarnerr;
  2178. return if ! CreateFormFile($frmfspec, $rlabel, \&CreateOptions, \&CreateView);
  2179. sdpopen(*PIPE, "label -i $opts <\"$frmfspec\"") || return;
  2180. my @out = readfilt PIPE;
  2181. sdpclose PIPE;
  2182. unlink $frmfspec if ! $config{verbose};
  2183. return if $? != 0;
  2184. return $1 if @out == 1 && $out[0] =~ /^info: Label (.+) (sav|not chang)ed\.$/;
  2185. return;
  2186. }
  2187. #
  2188. # sd label -d [-f] name
  2189. # SDDelLabel([\'-f',] 'name')
  2190. #
  2191. # Return name/undef on success/failure.
  2192. #
  2193. sub SDDelLabel {
  2194. my $opts = shiftopts(@_);
  2195. my $name = crtquote(@_);
  2196. clearwarnerr;
  2197. sdpopen(*PIPE, "label -d $opts -- $name") || return;
  2198. my @out = readfilt PIPE;
  2199. sdpclose PIPE;
  2200. return if $? != 0;
  2201. return $1 if @out == 1 && $out[0] =~ /^info: Label (.*) deleted\.$/;
  2202. return;
  2203. }
  2204. #
  2205. # sd labelsync [ -a -d -n ] -l label [ file[revRange] ... ]
  2206. # SDLabelSync([\'-a -d -n',] $label, 'file[revRange]')
  2207. #
  2208. # %labelsync = (
  2209. # 'depotFile' => '//depot/dev/src/code.c',
  2210. # 'action' => 'updated' # or 'added' or 'deleted' or unavailable
  2211. # 'haveRev' => 4
  2212. # )
  2213. #
  2214. # Return %labelsync/undef on success/failure.
  2215. #
  2216. # FUTURE: parse expected errors
  2217. # /(.*) - file\(s\) not on client\.$/
  2218. #
  2219. sub SDLabelSync {
  2220. my $opts = shiftopts(@_);
  2221. my $label = shift(@_);
  2222. my @filerevs = @_;
  2223. clearwarnerr;
  2224. lblnorm($label) || return;
  2225. my @labelsync;
  2226. sdpopen(*PIPE, "labelsync $label $opts --", @filerevs) || return;
  2227. while (my $rec = readfilt PIPE) {
  2228. if ($rec =~ /^info: (.*)#(\d+) - (.*ed)$/) {
  2229. push @labelsync, { 'depotFile' => $1, 'haveRev' => $2,
  2230. 'action' => $3 };
  2231. } elsif ($rec =~ /^info: (.*)#(\d+) - /) {
  2232. push @labelsync, { 'depotFile' => $1, 'haveRev' => $2 };
  2233. } else {
  2234. enext $rec;
  2235. }
  2236. }
  2237. sdpclose PIPE;
  2238. return if @labelsync == 0;
  2239. return wantarray ? @labelsync : \@labelsync;
  2240. }
  2241. #
  2242. # SDLabels - Display list of defined labels.
  2243. #
  2244. # sd labels [file[revRange]]
  2245. # SDLabels(['file[revRange]'])
  2246. #
  2247. # @labels = (
  2248. # \%label1, # subset of structure described at SDGetLabel
  2249. # \%label2,
  2250. # ...
  2251. # )
  2252. #
  2253. # Return @labels/undef on success/failure.
  2254. #
  2255. sub SDLabels {
  2256. my @files = @_;
  2257. clearwarnerr;
  2258. my @labels;
  2259. sdpopen(*PIPE, "labels --", @files) || return;
  2260. while (my $rec = readfilt PIPE) {
  2261. enext $rec if $rec !~ m!^info: Label (\S+) ($redatime) '(.*)'$!;
  2262. push @labels, { 'Label' => $1, 'Access' => $2, 'Description' => $3 };
  2263. }
  2264. sdpclose PIPE;
  2265. return if $? != 0;
  2266. return wantarray ? @labels : \@labels;
  2267. }
  2268. #
  2269. # SDOpened[N] - Display list of files opened for pending changelist.
  2270. #
  2271. # sd opened [-a -c changelist# -l -u user] [file ...]
  2272. # SDOpenedN([\"-a -c $ncl -l -u user",] ['file', ...])
  2273. #
  2274. # @opened = (
  2275. # \%opened1, # as described below
  2276. # \%opened2,
  2277. # ...
  2278. # )
  2279. #
  2280. # Return @opened/undef on success/failure.
  2281. #
  2282. # SDOpened([\"-a -c $ncl -l -u user",] 'file')
  2283. #
  2284. # %opened = {
  2285. # 'depotFile' => '//depot/dev/src/code.c',
  2286. # 'haveRev' => 4,
  2287. # 'action' => 'edit',
  2288. # 'change' => 12345, # or 'default'
  2289. # 'user' => 'MYDOMAIN\\myalias', # optional
  2290. # 'client' => 'MYCLIENTNAME', # optional
  2291. # 'ourLock' => 1, # only exists if locked
  2292. # }
  2293. #
  2294. # Return %opened (subset of structure described at SDFstat)/undef on
  2295. # success/failure.
  2296. #
  2297. # NOTE: In SD.pm, depotFile is always in depot syntax, localFile is always in
  2298. # local syntax. sd.exe may put localFile into depotFile, and not provide
  2299. # localFile.
  2300. #
  2301. # FUTURE: parse expected errors
  2302. # /(.*) - file\(s\) not opened on this client\.$/
  2303. # /(.*) - file\(s\) not opened anywhere\.$/
  2304. #
  2305. sub SDOpenedN {
  2306. my $opts = shiftopts(@_);
  2307. my @files = @_;
  2308. clearwarnerr;
  2309. my @opened;
  2310. sdpopen(*PIPE, "opened $opts --", @files) || return;
  2311. while (my $rec = readfilt PIPE) {
  2312. enext $rec
  2313. if $rec !~ m!^info: (.*)#(\d+) - (\w+) ((default) change |change (\d+) ).*\((\w+)\)( by $reduc2)?( \*locked\*)?$!;
  2314. my $rh = { 'depotFile' => $1, 'haveRev' => $2, 'action' => $3,
  2315. 'type' => $7 };
  2316. $rh->{change} = (defined $5) ? $5 : $6;
  2317. if (defined $8) { $rh->{user} = $9; $rh->{client} = $10; }
  2318. if (defined $11) { $rh->{ourLock} = 1; }
  2319. if ($1 !~ m!^//!) {
  2320. $rh->{localFile} = $rh->{depotFile};
  2321. delete $rh->{depotFile};
  2322. }
  2323. push @opened, $rh;
  2324. }
  2325. sdpclose PIPE;
  2326. return if @opened == 0;
  2327. return wantarray ? @opened : \@opened;
  2328. }
  2329. sub SDOpened { return nto1 SDOpenedN(@_); }
  2330. #
  2331. # SDReopen[N] - Change the type or changelist number of an opened file. Keep
  2332. # in sync with OpenFilesN.
  2333. #
  2334. # sd reopen [-c changelist#] [-t type] file ...
  2335. # SDReopenN([\'-t type',] $ncl, 'file'[, ...])
  2336. #
  2337. # @open = (
  2338. # \%open1, # as described below
  2339. # \%open2,
  2340. # ...
  2341. # )
  2342. #
  2343. # Return @open/undef on success/failure.
  2344. #
  2345. # SDReopen([\'-t type',] $ncl, 'file')
  2346. #
  2347. # %open = {
  2348. # 'depotFile' => '//depot/dev/src/code.c',
  2349. # 'haveRev' => 4
  2350. # }
  2351. #
  2352. # Return %open (subset of structure described at SDFstat)/undef on
  2353. # success/failure.
  2354. #
  2355. # A changelist# is always required; specify nclDefault to use default
  2356. # changelist.
  2357. #
  2358. # FUTURE: collect change when available
  2359. # FUTURE: parse expected errors
  2360. # /(.*) - file\(s\) not opened on this client\.$/
  2361. #
  2362. sub SDReopenN {
  2363. my $opts = shiftopts(@_);
  2364. my $ncl = shift(@_);
  2365. my @files = @_;
  2366. clearwarnerr;
  2367. nclnorm($ncl, 'default') || return;
  2368. my @open;
  2369. sdpopen(*PIPE, "reopen -c $ncl $opts --", @files) || return;
  2370. while (my $rec = readfilt PIPE) {
  2371. enext $rec
  2372. if $rec !~ /^info: (.*)#(\d+) - (nothing changed|reopened;)/;
  2373. push @open, { 'depotFile' => $1, 'haveRev' => $2 };
  2374. }
  2375. sdpclose PIPE;
  2376. return if @open == 0;
  2377. return wantarray ? @open : \@open;
  2378. }
  2379. sub SDReopen { return nto1 SDReopenN(@_); }
  2380. #
  2381. # SDResolve[N] - Merge open files with other revisions or files.
  2382. #
  2383. # sd resolve [-a<flag> -d<flag> -f -n -ob -ot -t -v] [file ...]
  2384. # SDResolveN([\"-a<flag> -d<flag> -f -n -ob -ot -t -v",] ['file', ...])
  2385. #
  2386. # @resolve = (
  2387. # \%resolve1, # as described below
  2388. # \%resolve2,
  2389. # ...
  2390. # )
  2391. #
  2392. # Return @resolve/undef on success/failure.
  2393. #
  2394. # SDResolve([\"-a<flag> -d<flag> -f -n -ob -ot -t -v",] 'file')
  2395. #
  2396. # %resolve = {
  2397. # 'depotTheirs' => '//depot/dev/src/code.c', # NOTE: SDAPI includes #rev
  2398. # 'depotTheirsRev' => 6, # in depotTheirs
  2399. # 'depotTheirsRevRange' => '#4,#6', # NOTE: experimental
  2400. # 'localMerged' => 'd:\\Office\\dev\\src\\code.c',
  2401. # 'chunksYours' => 4,
  2402. # 'chunksTheirs' => 3, # chunks* only exist for
  2403. # 'chunksBoth' => 0, # 3-way merges
  2404. # 'chunksConflict' => 1,
  2405. # 'action' => 'merge', # or 'copy' or 'ignored'
  2406. # } # or not defined if skipped
  2407. #
  2408. # Return %resolve/undef on success/failure.
  2409. #
  2410. # FUTURE: support more SDAPI ISDResolveUser field names/semantics:
  2411. # - derive depotBase[Rev] (3-way, consider cross-branch cases)
  2412. # - fetch depotYours[Rev] with SDHave, type with SDFstat
  2413. # - after merge, localYours has been replaced by localMerged
  2414. # - after merge, localBase (3-way), localTheirs no longer exist
  2415. # FUTURE: handle interactive mode with -ai option (or none)
  2416. # FUTURE: parse expected errors (SDResolveWarnings?)
  2417. # /(.*) - no file\(s\) to resolve.$/
  2418. # /^Must resolve manually.$/
  2419. # /(.*) - resolve skipped.$/
  2420. #
  2421. sub SDResolveN {
  2422. my $opts = shiftopts(@_);
  2423. my @files = @_;
  2424. if ($opts =~ /(-a[in])/) {
  2425. push @sderror,
  2426. "caller: SDResolve[N] currently doesn't support \\'$1' option\n";
  2427. return;
  2428. }
  2429. if ($opts !~ /-a/) {
  2430. push @sderror,
  2431. "caller: SDResolve[N] currently requires \\'-a<flag>' option\n";
  2432. return;
  2433. }
  2434. clearwarnerr;
  2435. my @resolve;
  2436. my %resolve;
  2437. sdpopen(*PIPE, "resolve $opts --", @files) || return;
  2438. while (my $rec = readfilt PIPE) {
  2439. # fspec - merging/resolving line indicates start of record
  2440. if ($rec =~ m!^info: (.+) - (merging|resolving) (//.+?)(#(\d+)(,#(\d+))?)$!) {
  2441. push @resolve, { %resolve } if keys %resolve > 0;
  2442. undef %resolve;
  2443. @resolve{qw(depotTheirs depotTheirsRev depotTheirsRevRange localMerged)} =
  2444. ($3, (defined $7 ? $7 : $5), $4, $1);
  2445. } elsif ($rec =~ /^info: Diff chunks: (\d+) yours \+ (\d+) theirs \+ (\d+) both \+ (\d+) conflicting$/) {
  2446. @resolve{qw(chunksYours chunksTheirs chunksBoth chunksConflict)} =
  2447. ($1, $2, $3, $4);
  2448. } elsif ($rec =~ m!^info: (//.+) - (merge from|copy from|ignored) (//.*)$!) {
  2449. $resolve{action} = $2;
  2450. $resolve{action} =~ s/ from$//;
  2451. } else {
  2452. enext $rec;
  2453. }
  2454. }
  2455. sdpclose PIPE;
  2456. # handle any partial record
  2457. push @resolve, { %resolve } if keys %resolve > 0;
  2458. return if @resolve == 0;
  2459. return wantarray ? @resolve : \@resolve;
  2460. }
  2461. sub SDResolve { return nto1 SDResolveN(@_); }
  2462. #
  2463. # SDRevert[N] - Discard changes from an opened file.
  2464. #
  2465. # sd revert [-a -c changelist# -f] file ...
  2466. # SDRevertN([\"-a -c $ncl -f",] 'file'[, ...])
  2467. #
  2468. # @revert = (
  2469. # \%revert1, # as described below
  2470. # \%revert2,
  2471. # ...
  2472. # )
  2473. #
  2474. # Return @revert/undef on success/failure.
  2475. #
  2476. # SDRevert([\"-a -c $ncl -f",] 'file')
  2477. #
  2478. # %revert = {
  2479. # 'depotFile' => '//depot/dev/src/code.c',
  2480. # 'haveRev' => 4,
  2481. # 'action' => 'edit'
  2482. # }
  2483. #
  2484. # Return %revert (subset of structure described at SDFstat)/undef on
  2485. # success/failure.
  2486. #
  2487. # FUTURE: parse expected errors
  2488. # /(.*) - file\(s\) not opened on this client\.$/
  2489. #
  2490. sub SDRevertN {
  2491. my $opts = shiftopts(@_);
  2492. my @files = @_;
  2493. clearwarnerr;
  2494. my @revert;
  2495. sdpopen(*PIPE, "revert $opts --", @files) || return;
  2496. while (my $rec = readfilt PIPE) {
  2497. enext $rec
  2498. if $rec !~ /^info: (.*)#(\d+) - was (.*), (abandoned|reverted)$/;
  2499. push @revert, { 'depotFile' => $1, 'haveRev' => $2, 'action' => $3 };
  2500. }
  2501. sdpclose PIPE;
  2502. return if @revert == 0;
  2503. return wantarray ? @revert : \@revert;
  2504. }
  2505. sub SDRevert { return nto1 SDRevertN(@_); }
  2506. #
  2507. # SDReview - List and track changelists (for the review daemon).
  2508. #
  2509. # sd review [-c changelist#] [-t counter]
  2510. # SDReview([\'-c ncl -t counter'])
  2511. #
  2512. # @reviews = (
  2513. # \%review1, # as described below
  2514. # \%review2,
  2515. # ...
  2516. # )
  2517. #
  2518. # %review = (
  2519. # 'Change' => 12345,
  2520. # 'User' => 'MYDOMAIN\\myalias',
  2521. # 'Email' => 'myalias', # default 'MYDOMAIN\\myalias@machine'
  2522. # 'FullName' => 'My Real Name', # default 'MYDOMAIN\\myalias'
  2523. # )
  2524. #
  2525. # Return @reviews/undef on success/failure.
  2526. #
  2527. sub SDReview {
  2528. my $opts = shiftopts(@_);
  2529. clearwarnerr;
  2530. my @reviews;
  2531. sdpopen(*PIPE, "review $opts") || return;
  2532. while (my $rec = readfilt PIPE) {
  2533. enext $rec if $rec !~ m!^info: Change (\d+) ($redu) <(.*)> \((.*)\)$!;
  2534. push @reviews, { 'Change' => $1, 'User' => $2, 'Email' => $3,
  2535. 'FullName' => $4 };
  2536. }
  2537. sdpclose PIPE;
  2538. return if $? != 0;
  2539. return wantarray ? @reviews : \@reviews;
  2540. }
  2541. #
  2542. # SDReviews - Show what users are subscribed to review files.
  2543. #
  2544. # sd reviews [-c changelist#] [file ...]
  2545. # SDReviews([\'-c ncl'], ['file', ...])
  2546. #
  2547. # @reviews = (
  2548. # \%review1, # subset of structure described at SDReview
  2549. # \%review2,
  2550. # ...
  2551. # )
  2552. #
  2553. # Return @reviews/undef on success/failure.
  2554. #
  2555. sub SDReviews {
  2556. my $opts = shiftopts(@_);
  2557. my @files = @_;
  2558. clearwarnerr;
  2559. my @reviews;
  2560. sdpopen(*PIPE, "reviews $opts --", @files) || return;
  2561. while (my $rec = readfilt PIPE) {
  2562. enext $rec if $rec !~ m!^info: ($redu) <(.*)> \((.*)\)$!;
  2563. push @reviews, { 'User' => $1, 'Email' => $2, 'FullName' => $3 };
  2564. }
  2565. sdpclose PIPE;
  2566. return if $? != 0;
  2567. return wantarray ? @reviews : \@reviews;
  2568. }
  2569. #
  2570. # SDSubmit - Submit open files to the depot
  2571. #
  2572. # submit [-u user [-l client]] [-i] [-c changelist#] [-C description] [file]
  2573. #
  2574. # SDSubmit([\"[-u user [-l client]] [-i] [-c changelist#] [-C description]",]
  2575. # ['file'])
  2576. #
  2577. # Returns the change number that was successfully submitted on success.
  2578. # Returns undef on error (meaning that the change was not submitted).
  2579. # On error, call SDSubmitError() and/or SDSubmitWarning() to get more
  2580. # details.
  2581. #
  2582. sub SDSubmit {
  2583. my $opts = shiftopts(@_);
  2584. my @files = @_;
  2585. clearwarnerr;
  2586. my $valid = 1;
  2587. my $change;
  2588. sdpopen(*PIPE, "submit $opts --", @files) || return;
  2589. while (my $rec = readfilt PIPE) {
  2590. next if $rec =~ /^info: Change \d+ created with \d+ open file(s)?.\s*$/;
  2591. next if $rec =~ /^info: Locking \d+ file(s)? \.\.\.\s*$/;
  2592. next if $rec =~ m!^info: \w+ //.*\#\d+\s*!;
  2593. next if $rec =~ /^info: Submitting change (.*)\.\s*$/;
  2594. if (!defined($change)
  2595. && ($rec =~ /^info: Change (\d+) submitted\.\s*$/
  2596. || $rec =~ /^info: Change \d+ renamed change (\d+) and submitted\.\s*$/)) {
  2597. $change = $1;
  2598. next;
  2599. }
  2600. $valid = 0;
  2601. enext $rec;
  2602. }
  2603. sdpclose PIPE;
  2604. return if !$valid || !defined($change);
  2605. return $change;
  2606. }
  2607. #
  2608. # SDSubmitError - parse error text from SDSubmit
  2609. #
  2610. # @error = SDError(\'-s');
  2611. # SDSubmitError(@error)
  2612. #
  2613. # \%error = {
  2614. # 'Description' => "text description of the error",
  2615. # 'Change' => 23, # from SDSubmit error text (may not be defined)
  2616. # }
  2617. #
  2618. # Return \%error/undef on success/failure.
  2619. #
  2620. # FUTURE: assume SDError() if no argument passed?
  2621. #
  2622. sub SDSubmitError {
  2623. my @error = @_;
  2624. clearwarnerr;
  2625. if (!defined(@error)) {
  2626. push @sderror, "internal: bad input to SDSubmitError\n";
  2627. return;
  2628. }
  2629. my $valid = 1;
  2630. my %error;
  2631. $error{Description} = "";
  2632. foreach my $rec (@error) {
  2633. $error{Description} = "$error{Description}$rec";
  2634. next if $rec =~ /^error: Out of date files must be resolved or reverted\.\s*$/;
  2635. next if $rec =~ /^error: Merges still pending -- use 'sd resolve' to merge files\.\s*$/;
  2636. if ($rec =~ /^error: Submit failed -- fix problems above then use 'sd submit -c (\d+)'\.\s*$/) {
  2637. $error{Change} = $1;
  2638. next;
  2639. }
  2640. next if $rec =~ /^error: No files to submit from the default changelist\.\s*$/;
  2641. next if $rec =~ /^error: Change (\d+) unknown\.\s*$/;
  2642. next if $rec =~ /^error: Client side operations\(s\) failed. Command aborted\.\s*$/;
  2643. $valid = 0;
  2644. enext $rec;
  2645. }
  2646. return if !$valid;
  2647. return wantarray ? %error : \%error;
  2648. }
  2649. #
  2650. # SDSubmitWarning - parse warning text from SDSubmit
  2651. #
  2652. # @warning = SDWarning(\'-s');
  2653. # SDSubmitWarning(@warning)
  2654. #
  2655. # \%warning = {
  2656. # 'Description' => "text description of the error",
  2657. # 'Changes' => [
  2658. # 'pendingchangenumber1',
  2659. # 'pendingchangenumber2',
  2660. # ...
  2661. # ],
  2662. # 'Files' => [
  2663. # 'resolvefile1',
  2664. # 'resolvefile2',
  2665. # ...
  2666. # ],
  2667. # }
  2668. #
  2669. # Return \%error/undef on success/failure.
  2670. #
  2671. # FUTURE: assume SDWarning() if no argument passed?
  2672. #
  2673. sub SDSubmitWarning {
  2674. my @warning = @_;
  2675. clearwarnerr;
  2676. if (!defined(@warning)) {
  2677. push @sderror, "internal: bad input to SDSubmitWarning\n";
  2678. return;
  2679. }
  2680. my $valid = 1;
  2681. my %warning;
  2682. $warning{Description} = "";
  2683. foreach my $rec (@warning) {
  2684. $warning{Description} = "$warning{Description}$rec";
  2685. if ($rec =~ /^warning: Use 'sd submit -c (\d+)' to submit file\(s\) in pending change (\d+)\.\s*$/) {
  2686. enext $rec if $1 != $2;
  2687. push @{$warning{Changes}}, $1;
  2688. next;
  2689. }
  2690. if ($rec =~ m!^warning: (//.*) - must resolve before submitting\s*$!
  2691. || $rec =~ m!^warning1: (//.*) - must resolve (\#\d+,?)+\s*$!
  2692. || $rec =~ m!^warning: .* - must resolve (//.*)\#\d+\s*$!) {
  2693. push @{$warning{Files}}, $1 if !inlist($1, @{$warning{Files}});
  2694. next;
  2695. }
  2696. $valid = 0;
  2697. enext $rec;
  2698. }
  2699. return if !$valid;
  2700. return wantarray ? %warning : \%warning;
  2701. }
  2702. #
  2703. # SD[Branch]Sync[N] - Synchronize the client with its view of the depot.
  2704. #
  2705. # sd sync [-f -n -i] [file[revRange] ...]
  2706. # SDSyncN([\'-f -n -i',] ['file[revRange]', ...])
  2707. #
  2708. # sd sync -b branch [-f -n -i -r] [file[revRange] ...]
  2709. # SDBranchSyncN([\'-f -n -i -r',] $brn, ['file[revRange]', ...])
  2710. #
  2711. # @sync = (
  2712. # \%sync1, # as described below
  2713. # \%sync2,
  2714. # ...
  2715. # )
  2716. #
  2717. # Return @sync/undef on success/failure.
  2718. #
  2719. # SDSync([\'-f -n -i',] 'file[revRange]')
  2720. # SDBranchSync([\'-f -n -i -r',] $brn, 'file[revRange]')
  2721. #
  2722. # %sync = (
  2723. # 'depotFile' => '//depot/dev/src/code.c',
  2724. # 'localFile' => 'd:\\Office\\dev\\src\\code.c', # not always available
  2725. # 'action' => 'updating' # or 'added' or 'deleted' or unavailable
  2726. # 'haveRev' => 4
  2727. # )
  2728. #
  2729. # Return %sync/undef on success/failure.
  2730. #
  2731. # FUTURE: parse expected errors
  2732. # /(.*) - file\(s\) up-to-date\.$/
  2733. # /(.*) - no such file\(s\)\.$/
  2734. # /(.*) - must resolve #\d+(,#\d+) before submitting\.$/
  2735. #
  2736. sub SDBranchSyncN {
  2737. my $opts = shiftopts(@_);
  2738. my $brn = shift(@_);
  2739. my @filerevs = @_;
  2740. clearwarnerr;
  2741. brnnorm($brn, '') || return;
  2742. if ($config{safesync}) {
  2743. my $ret = ! (system("$bin{copy} $bin{sd} $bin{sd2}") >> 8);
  2744. if (! $ret) {
  2745. push @sderror,
  2746. "internal: can't copy $bin{sd} to $bin{sd2} for safe sync\n";
  2747. return;
  2748. }
  2749. }
  2750. # Get sdpopen to use sd2 for safesync. Use local $bin{sd} instead of
  2751. # ConfigSD(binarch => 'foo') which would require putting sd$$.exe somewhere
  2752. # else, instead of in the same directory as sd.exe with a different name.
  2753. # Not changing directories avoids changing semantics when spawning other
  2754. # exes, not on the path, assumed to live in the same directory as sd.exe.
  2755. # Also, local is automatically restored on exit.
  2756. local $bin{sd} = $bin{sd2} if $config{safesync};
  2757. my @sync;
  2758. sdpopen(*PIPE, "sync $brn $opts --", @filerevs) || return;
  2759. while (my $rec = readfilt PIPE) {
  2760. if ($rec =~ /^info: (.*)#(\d+) - (updating|refreshing|replacing|deleted as|added as) (.*)$/) {
  2761. my $rh = { 'depotFile' => $1, 'haveRev' => $2,
  2762. 'action' => $3, 'localFile' => $4 };
  2763. $rh->{action} =~ s/ as$//;
  2764. push @sync, $rh;
  2765. } elsif ($rec =~ /^info: (.*)#(\d+) - /) {
  2766. push @sync, { 'depotFile' => $1, 'haveRev' => $2 };
  2767. } else {
  2768. enext $rec;
  2769. }
  2770. }
  2771. sdpclose PIPE;
  2772. unlink $bin{sd2} if $config{safesync};
  2773. return if @sync == 0;
  2774. return wantarray ? @sync : \@sync;
  2775. }
  2776. sub SDSyncN {
  2777. # insert brnDefault into argument list
  2778. my $opts = shiftopts(@_);
  2779. unshift @_, brnDefault;
  2780. unshift @_, \$opts if $opts ne '';
  2781. return SDBranchSyncN(@_);
  2782. }
  2783. sub SDBranchSync { return nto1 SDBranchSyncN(@_); }
  2784. sub SDSync { return nto1 SDSyncN(@_); }
  2785. #
  2786. # SDUsers - Display list of known users.
  2787. #
  2788. # sd users [-d date -p] [user ...]
  2789. # SDUsersN([\'-d date -p',] ['user', ...])
  2790. #
  2791. # @users = (
  2792. # \%user1, # as described below
  2793. # \%user2,
  2794. # ...
  2795. # )
  2796. #
  2797. # Return @users/undef on success/failure.
  2798. #
  2799. # SDUsers([\'-d date -p',] 'user')
  2800. #
  2801. # %user = (
  2802. # 'User' => 'MYDOMAIN\\myalias',
  2803. # 'Email' => 'myalias', # default 'MYDOMAIN\\myalias@machine'
  2804. # 'FullName' => 'My Real Name', # default 'MYDOMAIN\\myalias'
  2805. # 'Access' => '2001/05/07 09:25:24',
  2806. # 'Password' => 'NTSECURITY', # or '******', but only if using -p
  2807. # )
  2808. #
  2809. # Return %user/undef on success/failure.
  2810. #
  2811. sub SDUsersN {
  2812. my $opts = shiftopts(@_);
  2813. my @inusers = @_;
  2814. clearwarnerr;
  2815. my @users;
  2816. sdpopen(*PIPE, "users $opts --", @inusers) || return;
  2817. while (my $rec = readfilt PIPE) {
  2818. enext $rec if $rec !~ m!^info: ($redu) <(.*)> \((.*)\) accessed ($redatime)( (NTSECURITY|\*+))?$!;
  2819. my $rh = { 'User' => $1, 'Email' => $2, 'FullName' => $3,
  2820. 'Access' => $4 };
  2821. $rh->{Password} = $6 if defined $6;
  2822. push @users, $rh;
  2823. }
  2824. sdpclose PIPE;
  2825. return if $? != 0;
  2826. return wantarray ? @users : \@users;
  2827. }
  2828. sub SDUsers { return nto1 SDUsersN(@_); }
  2829. #
  2830. # SDWhere[N] - Show how file names map through the client view.
  2831. #
  2832. # sd where [file ...]
  2833. # SDWhereN(['file', ...])
  2834. #
  2835. # @files = (
  2836. # \%file1, # as described below
  2837. # \%file2,
  2838. # ...
  2839. # )
  2840. #
  2841. # Return @files/undef on success/failure.
  2842. #
  2843. # SDWhere('file')
  2844. #
  2845. # %file = (
  2846. # 'depotFile' => '//depot/dev/src/code.c',
  2847. # 'clientFile' => '//CLIENT/dev/src/code.c',
  2848. # 'localFile' => 'd:\\Office\\dev\\src\\code.c',
  2849. # 'unmap' => 1 # if file is not mapped
  2850. # # deprecated fields (enabled on request)
  2851. # 'path' => $file{localFile}
  2852. # )
  2853. #
  2854. # Return %file (super/subset of structure described at SDFstat)/undef on
  2855. # success/failure. File represents selective mapping if it exists, or
  2856. # exclusionary mapping if not.
  2857. #
  2858. # NOTE: In SD.pm, the name localFile is substituted for path, used in sd.exe.
  2859. # NOTE: sd where //depot/root doesn't work as expected, and trailing slashes
  2860. # cause grief too.
  2861. #
  2862. sub SDWhereN {
  2863. my @infiles = @_;
  2864. clearwarnerr;
  2865. my (%file, @files);
  2866. sdpopen(*PIPE, "where -Ttag --", @infiles) || return;
  2867. while (my $rec = readfilt PIPE) {
  2868. # empty line indicates end of record
  2869. if ($rec =~ /^info:\s*$/ && keys %file > 0) {
  2870. push @files, { %file };
  2871. undef %file;
  2872. next;
  2873. }
  2874. enext $rec if $rec !~ /^info1: (\w+)/;
  2875. next if $1 eq 'tag';
  2876. if ($1 eq 'unmap') {
  2877. $file{$1} = 1;
  2878. next;
  2879. }
  2880. enext $rec if $rec !~ /^info1: (\w+) (.+)$/;
  2881. if ($1 eq 'path') {
  2882. $file{localFile} = $2;
  2883. next;
  2884. }
  2885. $file{$1} = $2;
  2886. }
  2887. sdpclose PIPE;
  2888. # handle any partial record
  2889. push @files, { %file } if keys %file > 0;
  2890. return if @files == 0;
  2891. return wantarray ? @files : \@files;
  2892. }
  2893. sub SDWhere {
  2894. my $ref = SDWhereN(@_);
  2895. return if ! defined $ref;
  2896. my @ary = grep ! exists $_->{unmap}, @$ref;
  2897. # return single selective mapping if one exists ...
  2898. return nto1 \@ary if @ary > 0;
  2899. # ... or single exclusionary mapping if not
  2900. return nto1 $ref;
  2901. }
  2902. #
  2903. # SDRun - Run an arbitrary SD command.
  2904. #
  2905. # sd command [-opts] [arg ...]
  2906. # SDRun('command', [\'-opts',] ['arg', ...])
  2907. #
  2908. # Return @out/undef on success/failure.
  2909. #
  2910. sub SDRun {
  2911. my $command = shift(@_);
  2912. my $opts = shiftopts(@_);
  2913. my @args = @_;
  2914. clearwarnerr;
  2915. sdpopen(*PIPE, "$command $opts --", @args) || return;
  2916. my @out = readfilt PIPE;
  2917. sdpclose PIPE;
  2918. return if $? != 0;
  2919. return wantarray ? @out : \@out;
  2920. }
  2921. #
  2922. # SDSet - Set variables in the registry, or, more commonly, retrieve variables
  2923. # from the environment/.ini file/registry. EXPERIMENTAL INTERFACE MAY CHANGE.
  2924. #
  2925. # sd set [-s -S service] [var[=[value]] ...]
  2926. # SDSet()
  2927. #
  2928. # %set = (
  2929. # 'SDVAR1' => 'sdvalue1',
  2930. # 'SDVAR1_type' => 'set', # (i.e. registry) or 'config' (i.e. ini
  2931. # 'SDVAR2' => 'sdvalue2', # file) or 'environment'
  2932. # 'SDVAR2_type' => 'config',
  2933. # ...
  2934. # )
  2935. #
  2936. # Return %set/undef on success/failure.
  2937. #
  2938. # NOTE: Returned value does not reflect settings in %config.
  2939. # NOTE: In SD.pm, variable names are guaranteed to be upper-case; in sd.exe
  2940. # user case is preserved.
  2941. #
  2942. # FUTURE: support setting variables? with a hash (reference)?
  2943. # FUTURE: split getting and setting into SDGet and SDSet?
  2944. #
  2945. sub SDSet {
  2946. clearwarnerr;
  2947. my %set;
  2948. my $ph = do { local *PH; }; # FUTURE: local *PH for all
  2949. sdpopen($ph, "set") || return; # essential here for recursive
  2950. while (my $rec = readfilt $ph, 'info') { # calls from eprint in subs
  2951. next if $rec =~ /^info: (\[.*\])?$/; # using PIPE, SDDiff directly
  2952. enext $rec if $rec !~ /^info: (.*?)=(.*) \((\w+)\)$/;
  2953. $set{"\U$1\E"} = $2;
  2954. $set{"\U$1\E_type"} = $3;
  2955. }
  2956. sdpclose $ph;
  2957. return if $? != 0;
  2958. return wantarray ? %set : \%set;
  2959. }
  2960. #
  2961. # Non-standard exports - 'extra-value' operations that do not correspond
  2962. # directly to SD commands.
  2963. #
  2964. #
  2965. # specnorm - Normalize depot- (or client-) syntax mapping specification rspec.
  2966. # If rspec is a reference, normalize referenced spec in place. Regardless,
  2967. # return normalized mapping spec.
  2968. #
  2969. sub specnorm {
  2970. my($rspec) = @_;
  2971. my $spec = ref $rspec ? $$rspec : $rspec;
  2972. $spec = "/$spec/"; # so ends aren't special
  2973. $spec =~ s!\.{4,}!...!; # ., .. caught by sd client, more, here
  2974. $spec =~ s!([^/])\.\.\.!$1/...!g; # ensure preceding /
  2975. $spec =~ s!\.\.\.([^/])!.../$1!g; # ensure following /
  2976. $spec =~ s!^/(.*)/$!$1!; # remove temporary ends we added
  2977. $$rspec = $spec if ref $rspec;
  2978. return $spec;
  2979. }
  2980. #
  2981. # specmatch - Return 'spec1 matches spec2'. Currently, both specs must be in
  2982. # depot syntax, and only spec2 can contain wildcards (*, %n, ...).
  2983. # EXPERIMENTAL INTERFACE MAY CHANGE.
  2984. #
  2985. # FUTURE: consider \es
  2986. # FUTURE: accept multiple match specs or perhaps a full view
  2987. #
  2988. sub specmatch {
  2989. my($spec1, $spec2) = @_;
  2990. if ($spec1 =~ /(\.\.\.|[*%@#])/) {
  2991. push @sderror,
  2992. "caller: spec1 must not contain wildcards or revision specifiers\n";
  2993. return;
  2994. }
  2995. if ($spec2 =~ /[@#]/) {
  2996. push @sderror, "caller: spec2 must not contain revision specifiers\n";
  2997. return;
  2998. }
  2999. # translate spec2 into regex:
  3000. # - hide wildcards
  3001. $spec2 =~ s/(\*|%.)/\xff/g;
  3002. $spec2 =~ s/\.\.\./\xfe/g;
  3003. # quotemeta (but also ignoring \xff and \xfe)
  3004. $spec2 =~ s/([^A-Za-z_0-9\xff\xfe])/\\$1/g;
  3005. # - restore hidden sequences as regex equivalents
  3006. $spec2 =~ s/\xfe/.*?/g;
  3007. $spec2 =~ s/\xff/[^\\\/]*?/g;
  3008. # - make pattern match only complete string
  3009. $spec2 = "^$spec2\$";
  3010. # finally, match as a regex
  3011. return $spec1 =~ /$spec2/i;
  3012. }
  3013. #
  3014. # SDWarning/Error - Return warning/error text in sdwarning/error from last SD*
  3015. # call, or undef if no warning/error text available. If called with \'-s'
  3016. # argument, (actually, any true argument, right now) text returned is suitable
  3017. # for further parsing (sd -s format). Otherwise, it's suitable for immediate
  3018. # printing (as output by sd without -s). THE MEANING OF THE ARGUMENT WAS
  3019. # REVERSED PRIOR TO $VERSION 0.33 OF SD.PM. Adjust old code.
  3020. #
  3021. sub SDWarning {
  3022. if (! $_[0]) {
  3023. my @ret = mappd @sdwarning;
  3024. return wantarray ? @ret : join '', @ret;
  3025. } else {
  3026. return wantarray ? @sdwarning : join '', @sdwarning;
  3027. }
  3028. }
  3029. sub SDError {
  3030. if (! $_[0]) {
  3031. my @ret = mappd @sderror;
  3032. return wantarray ? @ret : join '', @ret;
  3033. } else {
  3034. return wantarray ? @sderror : join '', @sderror;
  3035. }
  3036. }
  3037. #
  3038. # SDSyncSD - Ensure sd.exe is newest in this branch (or specified revision, if
  3039. # revision is specified,) syncing it if necessary. Return %sync/undef on
  3040. # sync/no-sync needed. Use copy of current sd.exe from client to do the sync.
  3041. # It's inappropriate to call this if binarch\sd.exe is not in the client or
  3042. # depot.
  3043. #
  3044. # FUTURE: explicit handling of interesting cases such as user has old revision
  3045. # opened for edit
  3046. # FUTURE: use sd.exe#head instead of sd.exe#have? Get it with
  3047. # SDRun('print', \"-o $bin{sd2}", $sd);
  3048. #
  3049. sub SDSyncSD {
  3050. my($rev) = @_;
  3051. $rev = '' if ! defined $rev;
  3052. my $sd = "$bin{sd}$rev";
  3053. my $rh = SDSync(\'-n', $sd);
  3054. if (defined $rh) {
  3055. local $config{safesync} = 1; # instead of ConfigSD(safesync => 1) so
  3056. return SDSync($sd); # it's automatically restored on exit
  3057. }
  3058. return;
  3059. }
  3060. #
  3061. # BEGIN - Load-time initialization.
  3062. #
  3063. BEGIN {
  3064. InitSD();
  3065. }
  3066. #
  3067. # END - Unload-time termination.
  3068. #
  3069. END {
  3070. local ($!, $?); # so following cleanup doesn't trash exit code
  3071. unlink $bin{sd2} if exists $bin{sd2}; # just in case
  3072. }
  3073. 1;