File Coverage

blib/lib/Monotone/AutomateStdio.pm
Criterion Covered Total %
statement 231 1314 17.5
branch 0 606 0.0
condition 0 240 0.0
subroutine 77 176 43.7
pod 79 95 83.1
total 387 2431 15.9


line stmt bran cond sub pod time code
1             ##############################################################################
2             #
3             # File Name - AutomateStdio.pm
4             #
5             # Description - A class module that provides an interface to Monotone's
6             # automate stdio interface.
7             #
8             # Authors - A.E.Cooper. With contributions from T.Keller.
9             #
10             # Legal Stuff - Copyright (c) 2007 Anthony Edward Cooper
11             # .
12             #
13             # This library is free software; you can redistribute it
14             # and/or modify it under the terms of the GNU Lesser General
15             # Public License as published by the Free Software
16             # Foundation; either version 3 of the License, or (at your
17             # option) any later version.
18             #
19             # This library is distributed in the hope that it will be
20             # useful, but WITHOUT ANY WARRANTY; without even the implied
21             # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
22             # PURPOSE. See the GNU Lesser General Public License for
23             # more details.
24             #
25             # You should have received a copy of the GNU Lesser General
26             # Public License along with this library; if not, write to
27             # the Free Software Foundation, Inc., 59 Temple Place - Suite
28             # 330, Boston, MA 02111-1307 USA.
29             #
30             ##############################################################################
31             #
32             ##############################################################################
33             #
34             # Package - Monotone::AutomateStdio
35             #
36             # Description - See above.
37             #
38             ##############################################################################
39              
40              
41              
42             # ***** PACKAGE DECLARATION *****
43              
44             package Monotone::AutomateStdio;
45              
46             # ***** DIRECTIVES *****
47              
48             require 5.008005;
49              
50 1     1   14348 no locale;
  1         381  
  1         4  
51 1     1   23 use strict;
  1         1  
  1         15  
52 1     1   3 use warnings;
  1         3  
  1         19  
53              
54             # ***** REQUIRED PACKAGES *****
55              
56             # Standard Perl and CPAN modules.
57              
58 1     1   3 use Carp;
  1         1  
  1         56  
59 1     1   3 use Cwd qw(abs_path getcwd);
  1         20  
  1         39  
60 1     1   508 use Encode;
  1         7047  
  1         62  
61 1     1   5 use File::Basename;
  1         0  
  1         59  
62 1     1   3 use File::Spec;
  1         1  
  1         14  
63 1     1   480 use IO::File;
  1         6393  
  1         124  
64 1     1   5 use IO::Handle qw(autoflush);
  1         1  
  1         51  
65 1     1   409 use IO::Poll qw(POLLHUP POLLIN POLLPRI);
  1         570  
  1         50  
66 1     1   424 use IPC::Open3;
  1         2585  
  1         44  
67 1     1   416 use POSIX qw(:errno_h :limits_h);
  1         4230  
  1         3  
68 1     1   1693 use Socket;
  1         2443  
  1         440  
69 1     1   5 use Symbol qw(gensym);
  1         1  
  1         36  
70              
71             # ***** GLOBAL DATA DECLARATIONS *****
72              
73             # Constants used to represent the different types of capability Monotone may or
74             # may not provide depending upon its version.
75              
76 1     1   3 use constant MTN_CHECKOUT => 0;
  1         2  
  1         44  
77 1     1   3 use constant MTN_COMMON_KEY_HASH => 1;
  1         1  
  1         33  
78 1     1   3 use constant MTN_CONTENT_DIFF_EXTRA_OPTIONS => 2;
  1         1  
  1         31  
79 1     1   3 use constant MTN_DB_GET => 3;
  1         1  
  1         28  
80 1     1   3 use constant MTN_DROP_ATTRIBUTE => 4;
  1         1  
  1         28  
81 1     1   3 use constant MTN_DROP_DB_VARIABLES => 5;
  1         1  
  1         28  
82 1     1   2 use constant MTN_DROP_PUBLIC_KEY => 6;
  1         1  
  1         28  
83 1     1   3 use constant MTN_ERASE_DESCENDANTS => 7;
  1         0  
  1         27  
84 1     1   2 use constant MTN_FILE_MERGE => 8;
  1         1  
  1         26  
85 1     1   3 use constant MTN_GENERATE_KEY => 9;
  1         1  
  1         26  
86 1     1   3 use constant MTN_GET_ATTRIBUTES => 10;
  1         1  
  1         29  
87 1     1   2 use constant MTN_GET_ATTRIBUTES_TAKING_OPTIONS => 11;
  1         1  
  1         28  
88 1     1   3 use constant MTN_GET_CURRENT_REVISION => 12;
  1         1  
  1         27  
89 1     1   3 use constant MTN_GET_DB_VARIABLES => 13;
  1         1  
  1         27  
90 1     1   3 use constant MTN_GET_EXTENDED_MANIFEST_OF => 14;
  1         1  
  1         40  
91 1     1   3 use constant MTN_GET_FILE_SIZE => 15;
  1         1  
  1         27  
92 1     1   3 use constant MTN_GET_PUBLIC_KEY => 16;
  1         1  
  1         27  
93 1     1   3 use constant MTN_GET_WORKSPACE_ROOT => 17;
  1         1  
  1         28  
94 1     1   3 use constant MTN_HASHED_SIGNATURES => 18;
  1         1  
  1         26  
95 1     1   3 use constant MTN_IGNORING_OF_SUSPEND_CERTS => 19;
  1         7  
  1         29  
96 1     1   3 use constant MTN_INVENTORY_IN_IO_STANZA_FORMAT => 20;
  1         0  
  1         28  
97 1     1   2 use constant MTN_INVENTORY_TAKING_OPTIONS => 21;
  1         1  
  1         27  
98 1     1   3 use constant MTN_INVENTORY_WITH_BIRTH_ID => 22;
  1         1  
  1         26  
99 1     1   2 use constant MTN_K_SELECTOR => 23;
  1         1  
  1         34  
100 1     1   4 use constant MTN_LOG => 24;
  1         0  
  1         45  
101 1     1   5 use constant MTN_LUA => 25;
  1         2  
  1         54  
102 1     1   3 use constant MTN_M_SELECTOR => 26;
  1         1  
  1         34  
103 1     1   4 use constant MTN_P_SELECTOR => 27;
  1         0  
  1         33  
104 1     1   3 use constant MTN_PUT_PUBLIC_KEY => 28;
  1         0  
  1         35  
105 1     1   2 use constant MTN_READ_PACKETS => 29;
  1         1  
  1         34  
106 1     1   3 use constant MTN_REMOTE_CONNECTIONS => 30;
  1         1  
  1         30  
107 1     1   2 use constant MTN_SELECTOR_FUNCTIONS => 31;
  1         1  
  1         37  
108 1     1   3 use constant MTN_SELECTOR_MIN_FUNCTION => 32;
  1         1  
  1         36  
109 1     1   3 use constant MTN_SELECTOR_NOT_FUNCTION => 33;
  1         0  
  1         35  
110 1     1   3 use constant MTN_SELECTOR_OR_OPERATOR => 34;
  1         1  
  1         32  
111 1     1   3 use constant MTN_SET_ATTRIBUTE => 35;
  1         0  
  1         28  
112 1     1   3 use constant MTN_SET_DB_VARIABLE => 36;
  1         1  
  1         31  
113 1     1   3 use constant MTN_SHOW_CONFLICTS => 37;
  1         0  
  1         29  
114 1     1   2 use constant MTN_STREAM_IO => 38;
  1         1  
  1         31  
115 1     1   3 use constant MTN_SYNCHRONISATION => 39;
  1         1  
  1         30  
116 1     1   3 use constant MTN_SYNCHRONISATION_WITH_OUTPUT => 40;
  1         1  
  1         28  
117 1     1   3 use constant MTN_U_SELECTOR => 41;
  1         0  
  1         32  
118 1     1   3 use constant MTN_UPDATE => 42;
  1         1  
  1         35  
119 1     1   3 use constant MTN_W_SELECTOR => 43;
  1         0  
  1         30  
120              
121             # Constants used to represent the different error levels.
122              
123 1     1   2 use constant MTN_SEVERITY_ALL => 0x03;
  1         1  
  1         30  
124 1     1   3 use constant MTN_SEVERITY_ERROR => 0x01;
  1         1  
  1         27  
125 1     1   2 use constant MTN_SEVERITY_WARNING => 0x02;
  1         1  
  1         31  
126              
127             # Constants used to represent data streams from Monotone that can be tied into
128             # file handles by the caller.
129              
130 1     1   2 use constant MTN_P_STREAM => 0;
  1         1  
  1         31  
131 1     1   3 use constant MTN_T_STREAM => 1;
  1         1  
  1         39  
132              
133             # Constant used to represent the exception thrown when interrupting waitpid().
134              
135 1     1   3 use constant WAITPID_INTERRUPT => __PACKAGE__ . "::waitpid-interrupt";
  1         1  
  1         38  
136              
137             # Constant used to represent the in memory database name.
138              
139 1     1   3 use constant IN_MEMORY_DB_NAME => ":memory:";
  1         1  
  1         29  
140              
141             # Constants used to represent different value formats.
142              
143 1     1   2 use constant BARE_PHRASE => 0x001; # E.g. orphaned_directory.
  1         1  
  1         30  
144 1     1   4 use constant HEX_ID => 0x002; # E.g. [ab2 ... 1be].
  1         1  
  1         52  
145 1     1   5 use constant NON_UNIQUE => 0x004; # Key can occur more than once.
  1         1  
  1         43  
146 1     1   3 use constant NULL => 0x008; # Nothing, i.e. we just have the key.
  1         1  
  1         31  
147 1     1   3 use constant OPTIONAL_HEX_ID => 0x010; # As HEX_ID but also [].
  1         1  
  1         28  
148 1     1   2 use constant STRING => 0x020; # Quoted string, possibly escaped.
  1         1  
  1         31  
149 1     1   3 use constant STRING_AND_HEX_ID => 0x040; # E.g. "fileprop" [ab2 ... 1be].
  1         0  
  1         32  
150 1     1   3 use constant STRING_ENUM => 0x080; # E.g. "rename_source".
  1         1  
  1         29  
151 1     1   3 use constant STRING_KEY_VALUE => 0x100; # Quoted key and value (STRING).
  1         1  
  1         31  
152 1     1   3 use constant STRING_LIST => 0x200; # E.g. "..." "...", possibly escaped.
  1         1  
  1         1098  
153              
154             # Private structures for managing inside-out key caching style objects.
155              
156             my $class_name = __PACKAGE__;
157             my %class_records;
158              
159             # Pre-compiled regular expressions for: finding the end of a quoted string
160             # possibly containing escaped quotes (i.e. " preceeded by a non-backslash
161             # character or an even number of backslash characters), recognising data locked
162             # conditions and detecting the beginning of an I/O stanza.
163              
164             my $closing_quote_re = qr/((^.*[^\\])|^)(\\{2})*\"$/;
165             my $database_locked_re = qr/.*sqlite error: database is locked.*/;
166             my $io_stanza_re = qr/^ *([a-z_]+)(?:(?: \S)|(?: ?$))/;
167              
168             # A map for quickly detecting valid mtn subprocess options and the number of
169             # their arguments.
170              
171             my %valid_mtn_options = ("--allow-default-confdir" => 0,
172             "--allow-workspace" => 0,
173             "--builtin-rcfile" => 0,
174             "--clear-rcfiles" => 0,
175             "--confdir" => 1,
176             "--key" => 1,
177             "--keydir" => 1,
178             "--no-builtin-rcfile" => 0,
179             "--no-default-confdir" => 0,
180             "--no-standard-rcfiles" => 0,
181             "--no-workspace" => 0,
182             "--norc" => 0,
183             "--nostd" => 0,
184             "--rcfile" => 1,
185             "--root" => 1,
186             "--ssh-sign" => 1,
187             "--standard-rcfiles" => 0,
188             "--use-default-key" => 0);
189              
190             # A map for quickly detecting all non-argument options that can be used on any
191             # command.
192              
193             my %non_arg_options = ("clear-from" => 1,
194             "clear-to" => 1,
195             "corresponding-renames" => 1,
196             "dry-run" => 1,
197             "ignore-suspend-certs" => 1,
198             "ignored" => 1,
199             "merges" => 1,
200             "move-conflicting-paths" => 1,
201             "no-corresponding-renames" => 1,
202             "no-ignore-suspend-certs" => 1,
203             "no-ignored" => 1,
204             "no-merges" => 1,
205             "no-move-conflicting-paths" => 1,
206             "no-set-default" => 1,
207             "no-unchanged" => 1,
208             "no-unknown" => 1,
209             "reverse" => 1,
210             "set-default" => 1,
211             "unchanged" => 1,
212             "unknown" => 1,
213             "with-header" => 1,
214             "without-header" => 1);
215              
216             # Maps for quickly detecting valid keys and determining their value types.
217              
218             my %certs_keys = ("key" => HEX_ID | STRING,
219             "name" => STRING,
220             "signature" => STRING,
221             "trust" => STRING_ENUM,
222             "value" => STRING);
223             my %generate_key_keys = ("given_name" => STRING,
224             "hash" => HEX_ID,
225             "local_name" => STRING,
226             "name" => STRING,
227             "private_hash" => HEX_ID,
228             "private_location" => STRING_LIST,
229             "public_hash" => HEX_ID,
230             "public_location" => STRING_LIST);
231             my %get_attributes_keys = ("attr" => STRING_KEY_VALUE,
232             "format_version" => STRING_ENUM,
233             "state" => STRING_ENUM);
234             my %get_db_variables_keys = ("domain" => STRING,
235             "entry" => NON_UNIQUE | STRING_KEY_VALUE);
236             my %get_extended_manifest_of_keys = ("attr" => NON_UNIQUE
237             | STRING_KEY_VALUE,
238             "attr_mark" => NON_UNIQUE
239             | STRING_AND_HEX_ID,
240             "birth" => HEX_ID,
241             "content" => HEX_ID,
242             "content_mark" => HEX_ID,
243             "dir" => STRING,
244             "dormant_attr" => NON_UNIQUE | STRING,
245             "file" => STRING,
246             "path_mark" => HEX_ID,
247             "size" => STRING);
248             my %get_manifest_of_keys = ("attr" => NON_UNIQUE | STRING_KEY_VALUE,
249             "content" => HEX_ID,
250             "dir" => STRING,
251             "file" => STRING,
252             "format_version" => STRING_ENUM);
253             my %inventory_keys = ("birth" => HEX_ID,
254             "changes" => STRING_LIST,
255             "fs_type" => STRING_ENUM,
256             "new_path" => STRING,
257             "new_type" => STRING_ENUM,
258             "old_path" => STRING,
259             "old_type" => STRING_ENUM,
260             "path" => STRING,
261             "status" => STRING_LIST);
262             my %keys_keys = %generate_key_keys;
263             my %options_file_keys = ("branch" => STRING,
264             "database" => STRING,
265             "keydir" => STRING);
266             my %revision_details_keys = ("add_dir" => STRING,
267             "add_file" => STRING,
268             "attr" => STRING,
269             "clear" => STRING,
270             "content" => HEX_ID,
271             "delete" => STRING,
272             "format_version" => STRING_ENUM,
273             "from" => HEX_ID,
274             "new_manifest" => HEX_ID,
275             "old_revision" => OPTIONAL_HEX_ID,
276             "patch" => STRING,
277             "rename" => STRING,
278             "set" => STRING,
279             "to" => HEX_ID | STRING,
280             "value" => STRING);
281             my %show_conflicts_keys = ("ancestor" => OPTIONAL_HEX_ID,
282             "ancestor_file_id" => HEX_ID,
283             "ancestor_name" => STRING,
284             "attr_name" => STRING,
285             "conflict" => BARE_PHRASE,
286             "left" => HEX_ID,
287             "left_attr_state" => STRING,
288             "left_attr_value" => STRING,
289             "left_file_id" => HEX_ID,
290             "left_name" => STRING,
291             "left_type" => STRING,
292             "node_type" => STRING,
293             "resolved_internal" => NULL,
294             "right" => HEX_ID,
295             "right_attr_state" => STRING,
296             "right_attr_value" => STRING,
297             "right_file_id" => HEX_ID,
298             "right_name" => STRING,
299             "right_type" => STRING);
300             my %sync_keys = ("key" => HEX_ID,
301             "receive_cert" => STRING,
302             "receive_key" => HEX_ID,
303             "receive_revision" => HEX_ID,
304             "revision" => HEX_ID,
305             "send_cert" => STRING,
306             "send_key" => HEX_ID,
307             "send_revision" => HEX_ID,
308             "value" => STRING);
309             my %tags_keys = ("branches" => NULL | STRING_LIST,
310             "format_version" => STRING_ENUM,
311             "revision" => HEX_ID,
312             "signer" => HEX_ID | STRING,
313             "tag" => STRING);
314              
315             # Version of Monotone being used.
316              
317             my $mtn_version;
318              
319             # Flag for determining whether the mtn subprocess should be started in a
320             # workspace's root directory.
321              
322             my $cd_to_ws_root = 1;
323              
324             # Flag for detemining whether UTF-8 conversion should be done on the data sent
325             # to and from the mtn subprocess.
326              
327             my $convert_to_utf8 = 1;
328              
329             # Error, database locked and io wait callback routine references and associated
330             # client data.
331              
332             my $carper = sub { return; };
333             my $croaker = \&croak;
334             my $db_locked_handler = sub { return; };
335             my $io_wait_handler = sub { return; };
336             my ($db_locked_handler_data,
337             $error_handler,
338             $error_handler_data,
339             $io_wait_handler_data,
340             $io_wait_handler_timeout,
341             $warning_handler,
342             $warning_handler_data);
343              
344             # ***** FUNCTIONAL PROTOTYPES *****
345              
346             # Constructors and destructor.
347              
348             sub new_from_db($;$$);
349             sub new_from_service($$;$);
350             sub new_from_ws($;$$);
351             *new = *new_from_db;
352             sub DESTROY($);
353              
354             # Public methods.
355              
356             sub ancestors($$@);
357             sub ancestry_difference($$$;@);
358             sub branches($$);
359             sub cert($$$$);
360             sub certs($$$);
361             sub checkout($$$);
362             sub children($$$);
363             sub closedown($);
364             sub common_ancestors($$@);
365             sub content_diff($$;$$$@);
366             sub db_get($$$$);
367             sub db_locked_condition_detected($);
368             sub descendents($$@);
369             sub drop_attribute($$$);
370             sub drop_db_variables($$;$);
371             sub drop_public_key($$);
372             sub erase_ancestors($$;@);
373             sub erase_descendants($$;@);
374             sub file_merge($$$$$$);
375             sub generate_key($$$$);
376             sub get_attributes($$$;$);
377             sub get_base_revision_id($$);
378             sub get_content_changed($$$$);
379             sub get_corresponding_path($$$$$);
380             sub get_current_revision($$;$@);
381             sub get_current_revision_id($$);
382             sub get_db_name($);
383             sub get_db_variables($$;$);
384             sub get_error_message($);
385             sub get_extended_manifest_of($$$);
386             sub get_file($$$);
387             sub get_file_of($$$;$);
388             sub get_file_size($$$);
389             sub get_manifest_of($$;$);
390             sub get_option($$$);
391             sub get_pid($);
392             sub get_public_key($$$);
393             sub get_revision($$$);
394             sub get_service_name($);
395             sub get_workspace_root($$);
396             sub get_ws_path($);
397             sub graph($$);
398             sub heads($$;$);
399             sub identify($$$);
400             sub ignore_suspend_certs($$);
401             sub interface_version($$);
402             sub inventory($$;$@);
403             sub keys($$);
404             sub leaves($$);
405             sub log($$;$$);
406             sub lua($$$;@);
407             sub packet_for_fdata($$$);
408             sub packet_for_fdelta($$$$);
409             sub packet_for_rdata($$$);
410             sub packets_for_certs($$$);
411             sub parents($$$);
412             sub put_file($$$$);
413             sub put_public_key($$);
414             sub put_revision($$$);
415             sub read_packets($$);
416             sub register_db_locked_handler(;$$$);
417             sub register_error_handler($;$$$);
418             sub register_io_wait_handler(;$$$$);
419             sub register_stream_handle($$$);
420             sub roots($$);
421             sub select($$$);
422             sub set_attribute($$$$);
423             sub set_db_variable($$$$);
424             sub show_conflicts($$;$$$);
425             sub supports($$);
426             sub suppress_utf8_conversion($$);
427             sub switch_to_ws_root($$);
428             sub sync($$;$$);
429             sub tags($$;$);
430             sub toposort($$@);
431             sub update($;$);
432              
433             # Public aliased methods.
434              
435             *attributes = *get_attributes;
436             *db_set = *set_db_variable;
437             *genkey = *generate_key;
438             *pull = *sync;
439             *push = *sync;
440              
441             # Private methods and routines.
442              
443             sub create_object($);
444             sub error_handler_wrapper($);
445             sub expand_options($$);
446             sub get_quoted_value($$$$);
447             sub get_ws_details($$$);
448             sub mtn_command($$$$$;@);
449             sub mtn_command_with_options($$$$$$;@);
450             sub mtn_read_output_format_1($$);
451             sub mtn_read_output_format_2($$);
452             sub parse_kv_record($$$$;$);
453             sub parse_revision_data($$);
454             sub startup($);
455             sub unescape($);
456             sub validate_database($);
457             sub validate_mtn_options($);
458             sub warning_handler_wrapper($);
459              
460             # ***** PACKAGE INFORMATION *****
461              
462             # We are just a base class.
463              
464 1     1   4 use base qw(Exporter);
  1         1  
  1         12148  
465              
466             our %EXPORT_TAGS = (capabilities => [qw(MTN_CHECKOUT
467             MTN_COMMON_KEY_HASH
468             MTN_CONTENT_DIFF_EXTRA_OPTIONS
469             MTN_DB_GET
470             MTN_DROP_ATTRIBUTE
471             MTN_DROP_DB_VARIABLES
472             MTN_DROP_PUBLIC_KEY
473             MTN_ERASE_DESCENDANTS
474             MTN_FILE_MERGE
475             MTN_GENERATE_KEY
476             MTN_GET_ATTRIBUTES
477             MTN_GET_ATTRIBUTES_TAKING_OPTIONS
478             MTN_GET_CURRENT_REVISION
479             MTN_GET_DB_VARIABLES
480             MTN_GET_EXTENDED_MANIFEST_OF
481             MTN_GET_FILE_SIZE
482             MTN_GET_PUBLIC_KEY
483             MTN_GET_WORKSPACE_ROOT
484             MTN_HASHED_SIGNATURES
485             MTN_IGNORING_OF_SUSPEND_CERTS
486             MTN_INVENTORY_IN_IO_STANZA_FORMAT
487             MTN_INVENTORY_TAKING_OPTIONS
488             MTN_INVENTORY_WITH_BIRTH_ID
489             MTN_K_SELECTOR
490             MTN_LOG
491             MTN_LUA
492             MTN_M_SELECTOR
493             MTN_P_SELECTOR
494             MTN_PUT_PUBLIC_KEY
495             MTN_READ_PACKETS
496             MTN_REMOTE_CONNECTIONS
497             MTN_SELECTOR_FUNCTIONS
498             MTN_SELECTOR_MIN_FUNCTION
499             MTN_SELECTOR_NOT_FUNCTION
500             MTN_SELECTOR_OR_OPERATOR
501             MTN_SET_ATTRIBUTE
502             MTN_SET_DB_VARIABLE
503             MTN_SHOW_CONFLICTS
504             MTN_STREAM_IO
505             MTN_SYNCHRONISATION
506             MTN_SYNCHRONISATION_WITH_OUTPUT
507             MTN_U_SELECTOR
508             MTN_UPDATE
509             MTN_W_SELECTOR)],
510             severities => [qw(MTN_SEVERITY_ALL
511             MTN_SEVERITY_ERROR
512             MTN_SEVERITY_WARNING)],
513             streams => [qw(MTN_P_STREAM
514             MTN_T_STREAM)]);
515             our @EXPORT = qw();
516             Exporter::export_ok_tags(qw(capabilities severities streams));
517             our $VERSION = "1.10";
518             #
519             ##############################################################################
520             #
521             # Routine - new_from_db
522             #
523             # Description - Class constructor. Construct an object using the specified
524             # Monotone database.
525             #
526             # Data - $class : The name of the class that is to be created.
527             # $db_name : The full path of the Monotone database. If
528             # this is not provided then the database
529             # associated with the current workspace is
530             # used.
531             # $options : A reference to a list containing a list of
532             # options to use on the mtn subprocess.
533             # Return Value : A reference to the newly created object.
534             #
535             ##############################################################################
536              
537              
538              
539             sub new_from_db($;$$)
540             {
541              
542              
543 0     0 1   my $class = shift();
544 0 0         my $db_name = (ref($_[0]) eq "ARRAY") ? undef : shift();
545 0           my $options = shift();
546 0 0         $options = [] unless (defined($options));
547              
548 0           my ($db,
549             $this,
550             $self,
551             $ws_path);
552              
553             # Check all the arguments given to us.
554              
555 0           validate_mtn_options($options);
556 0 0         if (defined($db_name))
557             {
558 0           $db = $db_name;
559             }
560             else
561             {
562 0           get_ws_details(getcwd(), \$db, \$ws_path);
563             }
564 0           validate_database($db);
565              
566             # Actually construct the object.
567              
568 0           $self = create_object($class);
569 0           $this = $class_records{$self->{$class_name}};
570 0           $this->{db_name} = $db_name;
571 0           $this->{ws_path} = $ws_path;
572 0           $this->{mtn_options} = $options;
573              
574             # Startup the mtn subprocess (also determining the interface version).
575              
576 0           $self->startup();
577              
578 0           return $self;
579              
580             }
581             #
582             ##############################################################################
583             #
584             # Routine - new_from_service
585             #
586             # Description - Class constructor. Construct an object using the specified
587             # Monotone service.
588             #
589             # Data - $class : The name of the class that is to be created.
590             # $service : The name of the Monotone server to connect
591             # to, either in the form of a Monotone style
592             # URL or a host name optionally followed by a
593             # colon and the port number.
594             # $options : A reference to a list containing a list of
595             # options to use on the mtn subprocess.
596             # Return Value : A reference to the newly created object.
597             #
598             ##############################################################################
599              
600              
601              
602             sub new_from_service($$;$)
603             {
604              
605 0     0 1   my ($class, $service, $options) = @_;
606              
607 0           my ($self,
608             $server,
609             $this);
610              
611 0 0         $options = [] unless (defined($options));
612              
613             # Check all the arguments given to us.
614              
615 0           validate_mtn_options($options);
616              
617             # Check the service name, either a Monotone style URL or server name
618             # followed by an optional colon and port number.
619              
620 0 0         if ($service =~ m/\//)
621             {
622              
623             # A URL has been given so extract the host name.
624              
625 0 0         if ($service =~ m/^(?:mtn:\/\/)?([^\/]+)(?:\/.*)?$/)
626             {
627 0           $server = $1;
628             }
629             else
630             {
631 0           &$croaker("Invalid URL `" . $service . "'.");
632             }
633              
634             }
635             else
636             {
637              
638             # A hostname and optional port number has been given so extract the
639             # host name part.
640              
641 0 0         if ($service =~ m/^([^:]+):\d+$/)
642             {
643 0           $server = $1;
644             }
645             else
646             {
647 0           $server = $service;
648             }
649              
650             }
651              
652             # Check that the hostname is know to us.
653              
654 0 0         &$croaker("`" . $server . "' is not known to the system")
655             unless (defined(inet_aton($server)));
656              
657             # Actually construct the object.
658              
659 0           $self = create_object($class);
660 0           $this = $class_records{$self->{$class_name}};
661 0           $this->{db_name} = IN_MEMORY_DB_NAME;
662 0           $this->{network_service} = $service;
663 0           $this->{mtn_options} = $options;
664              
665             # Startup the mtn subprocess (also determining the interface version).
666              
667 0           $self->startup();
668              
669 0           return $self;
670              
671             }
672             #
673             ##############################################################################
674             #
675             # Routine - new_from_ws
676             #
677             # Description - Class constructor. Construct an object using the specified
678             # Monotone workspace.
679             #
680             # Data - $class : The name of the class that is to be created.
681             # $ws_path : The base directory of a Monotone workspace.
682             # If this is not provided then the current
683             # workspace is used.
684             # $options : A reference to a list containing a list of
685             # options to use on the mtn subprocess.
686             # Return Value : A reference to the newly created object.
687             #
688             ##############################################################################
689              
690              
691              
692             sub new_from_ws($;$$)
693             {
694              
695              
696 0     0 1   my $class = shift();
697 0 0         my $ws_path = (ref($_[0]) eq "ARRAY") ? undef : shift();
698 0           my $options = shift();
699 0 0         $options = [] unless (defined($options));
700              
701 0           my ($db_name,
702             $self,
703             $this);
704              
705             # Check all the arguments given to us.
706              
707 0           validate_mtn_options($options);
708 0 0         if (! defined($ws_path))
709             {
710 0           $ws_path = getcwd();
711             }
712 0           get_ws_details($ws_path, \$db_name, \$ws_path);
713 0           validate_database($db_name);
714              
715             # Actually construct the object.
716              
717 0           $self = create_object($class);
718 0           $this = $class_records{$self->{$class_name}};
719 0           $this->{ws_path} = $ws_path;
720 0           $this->{ws_constructed} = 1;
721 0           $this->{mtn_options} = $options;
722              
723             # Startup the mtn subprocess (also determining the interface version).
724              
725 0           $self->startup();
726              
727 0           return $self;
728              
729             }
730             #
731             ##############################################################################
732             #
733             # Routine - DESTROY
734             #
735             # Description - Class destructor.
736             #
737             # Data - $self : The object.
738             #
739             ##############################################################################
740              
741              
742              
743             sub DESTROY($)
744             {
745              
746 0     0     my $self = $_[0];
747              
748             # Make sure the destructor doesn't throw any exceptions and that any
749             # existing exception status is preserved, otherwise constructor
750             # exceptions could be lost. E.g. if the constructor throws an exception
751             # after blessing the object, Perl immediately calls the destructor,
752             # which calls code that could use eval thereby resetting $@. Why not
753             # simply call bless as the last statement in the constructor? Well
754             # firstly callbacks can be called in the constructor and they have the
755             # object passed to them as their first argument and so it needs to be
756             # blessed, secondly the mtn subprocess needs to be properly closed down
757             # if there is an exception, which it won't be unless the destructor is
758             # called.
759              
760 0           local $@;
761             eval
762 0           {
763             eval
764 0           {
765 0           $self->closedown();
766             };
767 0           delete($class_records{$self->{$class_name}});
768             };
769              
770             }
771             #
772             ##############################################################################
773             #
774             # Routine - ancestors
775             #
776             # Description - Get a list of ancestors for the specified revisions.
777             #
778             # Data - $self : The object.
779             # $list : A reference to a list that is to contain
780             # the revision ids.
781             # @revision_ids : The revision ids that are to have their
782             # ancestors returned.
783             # Return Value : True on success, otherwise false on
784             # failure.
785             #
786             ##############################################################################
787              
788              
789              
790             sub ancestors($$@)
791             {
792              
793 0     0 1   my ($self, $list, @revision_ids) = @_;
794              
795 0           return $self->mtn_command("ancestors", 0, 0, $list, @revision_ids);
796              
797             }
798             #
799             ##############################################################################
800             #
801             # Routine - ancestry_difference
802             #
803             # Description - Get a list of ancestors for the specified revision, that
804             # are not also ancestors for the specified old revisions.
805             #
806             # Data - $self : The object.
807             # $list : A reference to a list that is to
808             # contain the revision ids.
809             # $new_revision_id : The revision id that is to have its
810             # ancestors returned.
811             # @old_revision_ids : The revision ids that are to have their
812             # ancestors excluded from the above list.
813             # Return Value : True on success, otherwise false on
814             # failure.
815             #
816             ##############################################################################
817              
818              
819              
820             sub ancestry_difference($$$;@)
821             {
822              
823 0     0 1   my ($self, $list, $new_revision_id, @old_revision_ids) = @_;
824              
825 0           return $self->mtn_command("ancestry_difference",
826             0,
827             0,
828             $list,
829             $new_revision_id,
830             @old_revision_ids);
831              
832             }
833             #
834             ##############################################################################
835             #
836             # Routine - branches
837             #
838             # Description - Get a list of branches.
839             #
840             # Data - $self : The object.
841             # $list : A reference to a list that is to contain the
842             # branch names.
843             # Return Value : True on success, otherwise false on failure.
844             #
845             ##############################################################################
846              
847              
848              
849             sub branches($$)
850             {
851              
852 0     0 1   my ($self, $list) = @_;
853              
854 0           return $self->mtn_command("branches", 0, 1, $list);
855              
856             }
857             #
858             ##############################################################################
859             #
860             # Routine - cert
861             #
862             # Description - Add the specified cert to the specified revision.
863             #
864             # Data - $self : The object.
865             # $revision_id : The revision id to which the cert is to be
866             # applied.
867             # $name : The name of the cert to be applied.
868             # $value : The value of the cert.
869             # Return Value : True on success, otherwise false on failure.
870             #
871             ##############################################################################
872              
873              
874              
875             sub cert($$$$)
876             {
877              
878 0     0 1   my ($self, $revision_id, $name, $value) = @_;
879              
880 0           my $dummy;
881              
882 0           return $self->mtn_command("cert",
883             1,
884             1,
885             \$dummy,
886             $revision_id,
887             $name,
888             $value);
889              
890             }
891             #
892             ##############################################################################
893             #
894             # Routine - certs
895             #
896             # Description - Get all the certs for the specified revision.
897             #
898             # Data - $self : The object.
899             # $ref : A reference to a buffer or an array that is
900             # to contain the output from this command.
901             # $revision_id : The id of the revision that is to have its
902             # certs returned.
903             # Return Value : True on success, otherwise false on failure.
904             #
905             ##############################################################################
906              
907              
908              
909             sub certs($$$)
910             {
911              
912 0     0 1   my ($self, $ref, $revision_id) = @_;
913              
914             # Run the command and get the data, either as one lump or as a structured
915             # list.
916              
917 0 0         if (ref($ref) eq "SCALAR")
918             {
919 0           return $self->mtn_command("certs", 0, 1, $ref, $revision_id);
920             }
921             else
922             {
923              
924 0           my ($i,
925             @lines);
926              
927 0 0         if (! $self->mtn_command("certs", 0, 1, \@lines, $revision_id))
928             {
929 0           return;
930             }
931              
932             # Reformat the data into a structured array.
933              
934 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
935             {
936 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
937             {
938 0           my $kv_record;
939              
940             # Get the next key-value record.
941              
942 0           parse_kv_record(\@lines, \$i, \%certs_keys, \$kv_record);
943 0           -- $i;
944              
945             # Validate it in terms of expected fields and store.
946              
947 0           foreach my $key ("key", "name", "signature", "trust", "value")
948             {
949             &$croaker("Corrupt certs list, expected " . $key
950             . " field but did not find it")
951 0 0         unless (exists($kv_record->{$key}));
952             }
953 0           push(@$ref, $kv_record);
954             }
955             }
956              
957 0           return 1;
958              
959             }
960              
961             }
962             #
963             ##############################################################################
964             #
965             # Routine - checkout
966             #
967             # Description - Create a new workspace from the specified branch and or
968             # revision.
969             #
970             # Data - $self : The object.
971             # $options : A reference to a list containing the options
972             # to use.
973             # $ws_dir : The name of the directory that is to be
974             # created with a workspace inside of it.
975             # Return Value : True on success, otherwise false on failure.
976             #
977             ##############################################################################
978              
979              
980              
981             sub checkout($$$)
982             {
983              
984 0     0 1   my ($self, $options, $ws_dir) = @_;
985              
986 0           my ($dummy,
987             @opts);
988              
989             # Process any options.
990              
991 0           expand_options($options, \@opts);
992              
993             # Run the command.
994              
995 0           return $self->mtn_command_with_options("checkout",
996             0,
997             0,
998             \$dummy,
999             \@opts,
1000             $ws_dir);
1001              
1002             }
1003             #
1004             ##############################################################################
1005             #
1006             # Routine - children
1007             #
1008             # Description - Get a list of children for the specified revision.
1009             #
1010             # Data - $self : The object.
1011             # $list : A reference to a list that is to contain the
1012             # revision ids.
1013             # $revision_id : The revision id that is to have its children
1014             # returned.
1015             # Return Value : True on success, otherwise false on failure.
1016             #
1017             ##############################################################################
1018              
1019              
1020              
1021             sub children($$$)
1022             {
1023              
1024 0     0 1   my ($self, $list, @revision_ids) = @_;
1025              
1026 0           return $self->mtn_command("children", 0, 0, $list, @revision_ids);
1027              
1028             }
1029             #
1030             ##############################################################################
1031             #
1032             # Routine - common_ancestors
1033             #
1034             # Description - Get a list of revisions that are all ancestors of the
1035             # specified revision.
1036             #
1037             # Data - $self : The object.
1038             # $list : A reference to a list that is to contain
1039             # the revision ids.
1040             # @revision_ids : The revision ids that are to have their
1041             # common ancestors returned.
1042             # Return Value : True on success, otherwise false on
1043             # failure.
1044             #
1045             ##############################################################################
1046              
1047              
1048              
1049             sub common_ancestors($$@)
1050             {
1051              
1052 0     0 1   my ($self, $list, @revision_ids) = @_;
1053              
1054 0           return $self->mtn_command("common_ancestors", 0, 0, $list, @revision_ids);
1055              
1056             }
1057             #
1058             ##############################################################################
1059             #
1060             # Routine - content_diff
1061             #
1062             # Description - Get the difference between the two specified revisions,
1063             # optionally limiting the output by using the specified
1064             # options and file restrictions. If the second revision id is
1065             # undefined then the workspace's current revision is used. If
1066             # both revision ids are undefined then the workspace's
1067             # current and base revisions are used. If no file names are
1068             # listed then differences in all files are reported.
1069             #
1070             # Data - $self : The object.
1071             # $buffer : A reference to a buffer that is to contain
1072             # the output from this command.
1073             # $options : A reference to a list containing the
1074             # options to use.
1075             # $revision_id1 : The first revision id to compare against.
1076             # $revision_id2 : The second revision id to compare against.
1077             # @file_names : The list of file names that are to be
1078             # reported on.
1079             # Return Value : True on success, otherwise false on
1080             # failure.
1081             #
1082             ##############################################################################
1083              
1084              
1085              
1086             sub content_diff($$;$$$@)
1087             {
1088              
1089 0     0 1   my ($self, $buffer, $options, $revision_id1, $revision_id2, @file_names)
1090             = @_;
1091              
1092 0           my @opts;
1093              
1094             # Process any options.
1095              
1096 0           expand_options($options, \@opts);
1097 0 0         push(@opts, {key => "r", value => $revision_id1})
1098             if (defined($revision_id1));
1099 0 0         push(@opts, {key => "r", value => $revision_id2})
1100             if (defined($revision_id2));
1101              
1102 0           return $self->mtn_command_with_options("content_diff",
1103             1,
1104             1,
1105             $buffer,
1106             \@opts,
1107             @file_names);
1108              
1109             }
1110             #
1111             ##############################################################################
1112             #
1113             # Routine - db_get
1114             #
1115             # Description - Get the value of a database variable.
1116             #
1117             # Data - $self : The object.
1118             # $buffer : A reference to a buffer that is to contain
1119             # the output from this command.
1120             # $domain : The domain of the database variable.
1121             # $name : The name of the variable to fetch.
1122             # Return Value : True on success, otherwise false on failure.
1123             #
1124             ##############################################################################
1125              
1126              
1127              
1128             sub db_get($$$$)
1129             {
1130              
1131 0     0 1   my ($self, $buffer, $domain, $name) = @_;
1132              
1133 0           return $self->mtn_command("db_get", 1, 1, $buffer, $domain, $name);
1134              
1135             }
1136             #
1137             ##############################################################################
1138             #
1139             # Routine - descendents
1140             #
1141             # Description - Get a list of descendents for the specified revisions.
1142             #
1143             # Data - $self : The object.
1144             # $list : A reference to a list that is to contain
1145             # the revision ids.
1146             # @revision_ids : The revision ids that are to have their
1147             # descendents returned.
1148             # Return Value : True on success, otherwise false on
1149             # failure.
1150             #
1151             ##############################################################################
1152              
1153              
1154              
1155             sub descendents($$@)
1156             {
1157              
1158 0     0 1   my ($self, $list, @revision_ids) = @_;
1159              
1160 0           return $self->mtn_command("descendents", 0, 0, $list, @revision_ids);
1161              
1162             }
1163             #
1164             ##############################################################################
1165             #
1166             # Routine - drop_attribute
1167             #
1168             # Description - Drop attributes from the specified file or directory,
1169             # optionally limiting it to the specified attribute.
1170             #
1171             # Data - $self : The object.
1172             # $path : The name of the file or directory that is to
1173             # have an attribute dropped.
1174             # $key : The name of the attribute that as to be
1175             # dropped.
1176             # Return Value : True on success, otherwise false on failure.
1177             #
1178             ##############################################################################
1179              
1180              
1181              
1182             sub drop_attribute($$$)
1183             {
1184              
1185 0     0 1   my ($self, $path, $key) = @_;
1186              
1187 0           my $dummy;
1188              
1189 0           return $self->mtn_command("drop_attribute", 1, 0, \$dummy, $path, $key);
1190              
1191             }
1192             #
1193             ##############################################################################
1194             #
1195             # Routine - drop_db_variables
1196             #
1197             # Description - Drop variables from the specified domain, optionally
1198             # limiting it to the specified variable.
1199             #
1200             # Data - $self : The object.
1201             # $domain : The name of the domain that is to have one
1202             # or all of its variables dropped.
1203             # $name : The name of the variable that is to be
1204             # dropped.
1205             # Return Value : True on success, otherwise false on failure.
1206             #
1207             ##############################################################################
1208              
1209              
1210              
1211             sub drop_db_variables($$;$)
1212             {
1213              
1214 0     0 1   my ($self, $domain, $name) = @_;
1215              
1216 0           my $dummy;
1217              
1218 0           return $self->mtn_command("drop_db_variables",
1219             1,
1220             0,
1221             \$dummy,
1222             $domain,
1223             $name);
1224              
1225             }
1226             #
1227             ##############################################################################
1228             #
1229             # Routine - drop_public_key
1230             #
1231             # Description - Drop the public key from the database for the specified key
1232             # id.
1233             #
1234             # Data - $self : The object.
1235             # $key_id : The id of the key, either in the form of its
1236             # name or its hash.
1237             # Return Value : True on success, otherwise false on failure.
1238             #
1239             ##############################################################################
1240              
1241              
1242              
1243             sub drop_public_key($$)
1244             {
1245              
1246 0     0 1   my ($self, $key_id) = @_;
1247              
1248 0           my $dummy;
1249              
1250 0           return $self->mtn_command("drop_public_key", 1, 0, \$dummy, $key_id);
1251              
1252             }
1253             #
1254             ##############################################################################
1255             #
1256             # Routine - erase_ancestors
1257             #
1258             # Description - For a given list of revisions, weed out those that are
1259             # ancestors to other revisions specified within the list.
1260             #
1261             # Data - $self : The object.
1262             # $list : A reference to a list that is to contain
1263             # the revision ids.
1264             # @revision_ids : The revision ids that are to have their
1265             # ancestors removed from the list.
1266             # Return Value : True on success, otherwise false on
1267             # failure.
1268             #
1269             ##############################################################################
1270              
1271              
1272              
1273             sub erase_ancestors($$;@)
1274             {
1275              
1276 0     0 1   my ($self, $list, @revision_ids) = @_;
1277              
1278 0           return $self->mtn_command("erase_ancestors", 0, 0, $list, @revision_ids);
1279              
1280             }
1281             #
1282             ##############################################################################
1283             #
1284             # Routine - erase_descendants
1285             #
1286             # Description - For a given list of revisions, weed out those that are
1287             # descendants to other revisions specified within the list.
1288             #
1289             # Data - $self : The object.
1290             # $list : A reference to a list that is to contain
1291             # the revision ids.
1292             # @revision_ids : The revision ids that are to have their
1293             # descendents removed from the list.
1294             # Return Value : True on success, otherwise false on
1295             # failure.
1296             #
1297             ##############################################################################
1298              
1299              
1300              
1301             sub erase_descendants($$;@)
1302             {
1303              
1304 0     0 1   my ($self, $list, @revision_ids) = @_;
1305              
1306 0           return $self->mtn_command("erase_descendants", 0, 0, $list, @revision_ids);
1307              
1308             }
1309             #
1310             ##############################################################################
1311             #
1312             # Routine - file_merge
1313             #
1314             # Description - Get the result of merging two files, both of which are on
1315             # separate revisions.
1316             #
1317             # Data - $self : The object.
1318             # $buffer : A reference to a buffer that is to
1319             # contain the output from this command.
1320             # $left_revision_id : The left hand revision id.
1321             # $left_file_name : The name of the file on the left hand
1322             # revision.
1323             # $right_revision_id : The right hand revision id.
1324             # $right_file_name : The name of the file on the right hand
1325             # revision.
1326             # Return Value : True on success, otherwise false on
1327             # failure.
1328             #
1329             ##############################################################################
1330              
1331              
1332              
1333             sub file_merge($$$$$$)
1334             {
1335              
1336 0     0 1   my ($self,
1337             $buffer,
1338             $left_revision_id,
1339             $left_file_name,
1340             $right_revision_id,
1341             $right_file_name) = @_;
1342              
1343 0           return $self->mtn_command("file_merge",
1344             1,
1345             1,
1346             $buffer,
1347             $left_revision_id,
1348             $left_file_name,
1349             $right_revision_id,
1350             $right_file_name);
1351              
1352             }
1353             #
1354             ##############################################################################
1355             #
1356             # Routine - generate_key
1357             #
1358             # Description - Generate a new key for use within the database.
1359             #
1360             # Data - $self : The object.
1361             # $ref : A reference to a buffer or a hash that is to
1362             # contain the output from this command.
1363             # $key_id : The key id for the new key.
1364             # $pass_phrase : The pass phrase for the key.
1365             # Return Value : True on success, otherwise false on failure.
1366             #
1367             ##############################################################################
1368              
1369              
1370              
1371             sub generate_key($$$$)
1372             {
1373              
1374 0     0 1   my ($self, $ref, $key_id, $pass_phrase) = @_;
1375              
1376 0           my $cmd;
1377              
1378             # This command was renamed in version 0.99.1 (i/f version 13.x).
1379              
1380 0 0         if ($self->supports(MTN_GENERATE_KEY))
1381             {
1382 0           $cmd = "generate_key";
1383             }
1384             else
1385             {
1386 0           $cmd = "genkey";
1387             }
1388              
1389             # Run the command and get the data, either as one lump or as a structured
1390             # list.
1391              
1392 0 0         if (ref($ref) eq "SCALAR")
1393             {
1394 0           return $self->mtn_command($cmd, 1, 1, $ref, $key_id, $pass_phrase);
1395             }
1396             else
1397             {
1398              
1399 0           my ($i,
1400             $kv_record,
1401             @lines);
1402              
1403 0 0         if (! $self->mtn_command($cmd, 1, 1, \@lines, $key_id, $pass_phrase))
1404             {
1405 0           return;
1406             }
1407              
1408             # Reformat the data into a structured record.
1409              
1410             # Get the key-value record.
1411              
1412 0           $i = 0;
1413 0           parse_kv_record(\@lines, \$i, \%generate_key_keys, \$kv_record);
1414              
1415             # Copy across the fields.
1416              
1417 0           %$ref = ();
1418 0           foreach my $key (CORE::keys(%$kv_record))
1419             {
1420 0           $$ref{$key} = $kv_record->{$key};
1421             }
1422              
1423 0           return 1;
1424              
1425             }
1426              
1427             }
1428             #
1429             ##############################################################################
1430             #
1431             # Routine - get_attributes
1432             #
1433             # Description - Get the attributes of the specified file under the
1434             # specified revision. If the revision id is undefined then
1435             # the current workspace revision is used.
1436             #
1437             # Data - $self : The object.
1438             # $ref : A reference to a buffer or an array that is
1439             # to contain the output from this command.
1440             # $file_name : The name of the file that is to be reported
1441             # on.
1442             # $revision_id : The revision id upon which the file
1443             # attributes are to be based.
1444             # Return Value : True on success, otherwise false on failure.
1445             #
1446             ##############################################################################
1447              
1448              
1449              
1450             sub get_attributes($$$;$)
1451             {
1452              
1453 0     0 1   my ($self, $ref, $file_name, $revision_id) = @_;
1454              
1455 0           my ($cmd,
1456             @opts);
1457              
1458             # This command was renamed in version 0.36 (i/f version 5.x).
1459              
1460 0 0         if ($self->supports(MTN_GET_ATTRIBUTES))
1461             {
1462 0           $cmd = "get_attributes";
1463             }
1464             else
1465             {
1466 0           $cmd = "attributes";
1467             }
1468              
1469             # Deal with the optional revision id option.
1470              
1471 0 0         push(@opts, {key => "r", value => $revision_id})
1472             if (defined($revision_id));
1473              
1474             # Run the command and get the data, either as one lump or as a structured
1475             # list.
1476              
1477 0 0         if (ref($ref) eq "SCALAR")
1478             {
1479 0           return $self->mtn_command_with_options($cmd,
1480             1,
1481             1,
1482             $ref,
1483             \@opts,
1484             $file_name);
1485             }
1486             else
1487             {
1488              
1489 0           my ($i,
1490             @lines);
1491              
1492 0 0         if (! $self->mtn_command_with_options($cmd,
1493             1,
1494             1,
1495             \@lines,
1496             \@opts,
1497             $file_name))
1498             {
1499 0           return;
1500             }
1501              
1502             # Reformat the data into a structured array.
1503              
1504 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
1505             {
1506 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
1507             {
1508 0           my $kv_record;
1509              
1510             # Get the next key-value record.
1511              
1512 0           parse_kv_record(\@lines,
1513             \$i,
1514             \%get_attributes_keys,
1515             \$kv_record);
1516 0           -- $i;
1517              
1518             # Validate it in terms of expected fields and store.
1519              
1520 0 0         if (exists($kv_record->{attr}))
1521             {
1522             &$croaker("Corrupt attributes list, expected state field "
1523             . "but did not find it")
1524 0 0         unless (exists($kv_record->{state}));
1525             push(@$ref, {attribute => $kv_record->{attr}->[0],
1526             value => $kv_record->{attr}->[1],
1527 0           state => $kv_record->{state}});
1528             }
1529             }
1530             }
1531              
1532 0           return 1;
1533              
1534             }
1535              
1536             }
1537             #
1538             ##############################################################################
1539             #
1540             # Routine - get_base_revision_id
1541             #
1542             # Description - Get the id of the revision upon which the workspace is
1543             # based.
1544             #
1545             # Data - $self : The object.
1546             # $buffer : A reference to a buffer that is to contain
1547             # the output from this command.
1548             # Return Value : True on success, otherwise false on failure.
1549             #
1550             ##############################################################################
1551              
1552              
1553              
1554             sub get_base_revision_id($$)
1555             {
1556              
1557 0     0 1   my ($self, $buffer) = @_;
1558              
1559 0           my @list;
1560              
1561 0           $$buffer = "";
1562 0 0         if (! $self->mtn_command("get_base_revision_id", 0, 0, \@list))
1563             {
1564 0           return;
1565             }
1566 0           $$buffer = $list[0];
1567              
1568 0           return 1;
1569              
1570             }
1571             #
1572             ##############################################################################
1573             #
1574             # Routine - get_content_changed
1575             #
1576             # Description - Get a list of revisions in which the content was most
1577             # recently changed, relative to the specified revision.
1578             #
1579             # Data - $self : The object.
1580             # $list : A reference to a list that is to contain the
1581             # revision ids.
1582             # $revision_id : The id of the revision of the manifest that
1583             # is to be returned.
1584             # $file_name : The name of the file that is to be reported
1585             # on.
1586             # Return Value : True on success, otherwise false on failure.
1587             #
1588             ##############################################################################
1589              
1590              
1591              
1592             sub get_content_changed($$$$)
1593             {
1594              
1595 0     0 1   my ($self, $list, $revision_id, $file_name) = @_;
1596              
1597 0           my ($i,
1598             @lines);
1599              
1600             # Run the command and get the data.
1601              
1602 0 0         if (! $self->mtn_command("get_content_changed",
1603             1,
1604             0,
1605             \@lines,
1606             $revision_id,
1607             $file_name))
1608             {
1609 0           return;
1610             }
1611              
1612             # Reformat the data into a list.
1613              
1614 0           for ($i = 0, @$list = (); $i < scalar(@lines); ++ $i)
1615             {
1616 0 0         if ($lines[$i] =~ m/^ *content_mark \[([0-9a-f]+)\]$/)
1617             {
1618 0           push(@$list, $1);
1619             }
1620             }
1621              
1622 0           return 1;
1623              
1624             }
1625             #
1626             ##############################################################################
1627             #
1628             # Routine - get_corresponding_path
1629             #
1630             # Description - For the specified file name in the specified source
1631             # revision, return the corresponding file name for the
1632             # specified target revision.
1633             #
1634             # Data - $self : The object.
1635             # $buffer : A reference to a buffer that is to
1636             # contain the output from this command.
1637             # $source_revision_id : The source revision id.
1638             # $file_name : The name of the file that is to be
1639             # searched for.
1640             # $target_revision_id : The target revision id.
1641             # Return Value : True on success, otherwise false on
1642             # failure.
1643             #
1644             ##############################################################################
1645              
1646              
1647              
1648             sub get_corresponding_path($$$$$)
1649             {
1650              
1651 0     0 1   my ($self, $buffer, $source_revision_id, $file_name, $target_revision_id)
1652             = @_;
1653              
1654 0           my ($i,
1655             @lines);
1656              
1657             # Run the command and get the data.
1658              
1659 0 0         if (! $self->mtn_command("get_corresponding_path",
1660             1,
1661             1,
1662             \@lines,
1663             $source_revision_id,
1664             $file_name,
1665             $target_revision_id))
1666             {
1667 0           return;
1668             }
1669              
1670             # Extract the file name.
1671              
1672 0           for ($i = 0, $$buffer = ""; $i < scalar(@lines); ++ $i)
1673             {
1674 0 0         if ($lines[$i] =~ m/^ *file \"/)
1675             {
1676 0           get_quoted_value(\@lines, \$i, 0, $buffer);
1677 0           $$buffer = unescape($$buffer);
1678             }
1679             }
1680              
1681 0           return 1;
1682              
1683             }
1684             #
1685             ##############################################################################
1686             #
1687             # Routine - get_current_revision
1688             #
1689             # Description - Get the revision information for the current revision,
1690             # optionally limiting the output by using the specified
1691             # options and file restrictions.
1692             #
1693             # Data - $self : The object.
1694             # $ref : A reference to a buffer or an array that is
1695             # to contain the output from this command.
1696             # $options : A reference to a list containing the options
1697             # to use.
1698             # @paths : A list of files or directories that are to
1699             # be reported on instead of the entire
1700             # workspace.
1701             # Return Value : True on success, otherwise false on failure.
1702             #
1703             ##############################################################################
1704              
1705              
1706              
1707             sub get_current_revision($$;$@)
1708             {
1709              
1710 0     0 1   my ($self, $ref, $options, @paths) = @_;
1711              
1712 0           my @opts;
1713              
1714             # Process any options.
1715              
1716 0           expand_options($options, \@opts);
1717              
1718             # Run the command and get the data, either as one lump or as a structured
1719             # list.
1720              
1721 0 0         if (ref($ref) eq "SCALAR")
1722             {
1723 0           return $self->mtn_command_with_options("get_current_revision",
1724             1,
1725             1,
1726             $ref,
1727             \@opts,
1728             @paths);
1729             }
1730             else
1731             {
1732              
1733 0           my @lines;
1734              
1735 0 0         if (! $self->mtn_command_with_options("get_current_revision",
1736             1,
1737             1,
1738             \@lines,
1739             \@opts,
1740             @paths))
1741             {
1742 0           return;
1743             }
1744 0           parse_revision_data($ref, \@lines);
1745              
1746 0           return 1;
1747              
1748             }
1749              
1750             }
1751             #
1752             ##############################################################################
1753             #
1754             # Routine - get_current_revision_id
1755             #
1756             # Description - Get the id of the revision that would be created if an
1757             # unrestricted commit was done in the workspace.
1758             #
1759             # Data - $self : The object.
1760             # $buffer : A reference to a buffer that is to contain
1761             # the output from this command.
1762             # Return Value : True on success, otherwise false on failure.
1763             #
1764             ##############################################################################
1765              
1766              
1767              
1768             sub get_current_revision_id($$)
1769             {
1770              
1771 0     0 1   my ($self, $buffer) = @_;
1772              
1773 0           my @list;
1774              
1775 0           $$buffer = "";
1776 0 0         if (! $self->mtn_command("get_current_revision_id", 0, 0, \@list))
1777             {
1778 0           return;
1779             }
1780 0           $$buffer = $list[0];
1781              
1782 0           return 1;
1783              
1784             }
1785             #
1786             ##############################################################################
1787             #
1788             # Routine - get_db_variables
1789             #
1790             # Description - Get the variables stored in the database, optionally
1791             # limiting it to the specified domain.
1792             #
1793             # Data - $self : The object.
1794             # $ref : A reference to a buffer or an array that is
1795             # to contain the output from this command.
1796             # $domain : The name of the domain that is to have its
1797             # variables listed.
1798             # Return Value : True on success, otherwise false on failure.
1799             #
1800             ##############################################################################
1801              
1802              
1803              
1804             sub get_db_variables($$;$)
1805             {
1806              
1807 0     0 1   my ($self, $ref, $domain) = @_;
1808              
1809             # Run the command and get the data, either as one lump or as a structured
1810             # list.
1811              
1812 0 0         if (ref($ref) eq "SCALAR")
1813             {
1814 0           return $self->mtn_command("get_db_variables", 1, 1, $ref, $domain);
1815             }
1816             else
1817             {
1818              
1819 0           my ($i,
1820             @lines);
1821              
1822 0 0         if (! $self->mtn_command("get_db_variables", 1, 1, \@lines, $domain))
1823             {
1824 0           return;
1825             }
1826              
1827             # Reformat the data into a structured array.
1828              
1829 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
1830             {
1831 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
1832             {
1833 0           my $kv_record;
1834              
1835             # Get the next key-value record.
1836              
1837 0           parse_kv_record(\@lines,
1838             \$i,
1839             \%get_db_variables_keys,
1840             \$kv_record);
1841 0           -- $i;
1842              
1843             # Validate it in terms of expected fields and copy data across
1844             # to the correct fields.
1845              
1846 0 0 0       if (! exists($kv_record->{domain})
1847             || ! exists($kv_record->{entry}))
1848             {
1849 0           &$croaker("Corrupt database variables list, expected "
1850             . "domain and entry fields but did not find "
1851             . "them");
1852             }
1853 0           foreach my $entry (@{$kv_record->{entry}})
  0            
1854             {
1855             push(@$ref, {domain => $kv_record->{domain},
1856 0           name => $entry->[0],
1857             value => $entry->[1]});
1858             }
1859             }
1860             }
1861              
1862 0           return 1;
1863              
1864             }
1865              
1866             }
1867             #
1868             ##############################################################################
1869             #
1870             # Routine - get_extended_manifest_of
1871             #
1872             # Description - Get the extended manifest for the specified revision.
1873             #
1874             # Data - $self : The object.
1875             # $ref : A reference to a buffer or an array that is
1876             # to contain the output from this command.
1877             # $revision_id : The revision id which is to have its
1878             # extended manifest returned.
1879             # Return Value : True on success, otherwise false on failure.
1880             #
1881             ##############################################################################
1882              
1883              
1884              
1885             sub get_extended_manifest_of($$$)
1886             {
1887              
1888 0     0 1   my ($self, $ref, $revision_id) = @_;
1889              
1890             # Run the command and get the data, either as one lump or as a structured
1891             # list.
1892              
1893 0 0         if (ref($ref) eq "SCALAR")
1894             {
1895 0           return $self->mtn_command("get_extended_manifest_of",
1896             0,
1897             1,
1898             $ref,
1899             $revision_id);
1900             }
1901             else
1902             {
1903              
1904 0           my ($i,
1905             @lines);
1906              
1907 0 0         if (! $self->mtn_command("get_extended_manifest_of",
1908             0,
1909             1,
1910             \@lines,
1911             $revision_id))
1912             {
1913 0           return;
1914             }
1915              
1916             # Reformat the data into a structured array.
1917              
1918 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
1919             {
1920 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
1921             {
1922 0           my $kv_record;
1923              
1924             # Get the next key-value record.
1925              
1926 0           parse_kv_record(\@lines,
1927             \$i,
1928             \%get_extended_manifest_of_keys,
1929             \$kv_record);
1930 0           -- $i;
1931              
1932             # Validate it in terms of expected fields.
1933              
1934 0 0 0       if (! exists($kv_record->{dir})
1935             && ! exists($kv_record->{file}))
1936             {
1937 0           &$croaker("Corrupt extended manifest list, expected dir "
1938             . "or file field but did not find them");
1939             }
1940              
1941             # Set up the name and type fields.
1942              
1943 0 0         if (exists($kv_record->{file}))
    0          
1944             {
1945 0           $kv_record->{type} = "file";
1946 0           $kv_record->{name} = $kv_record->{file};
1947 0           delete($kv_record->{file});
1948             }
1949             elsif (exists($kv_record->{dir}))
1950             {
1951 0           $kv_record->{type} = "directory";
1952 0           $kv_record->{name} = $kv_record->{dir};
1953 0           delete($kv_record->{dir});
1954             }
1955              
1956             # Now reformat some fields to be more meaningful/consistent.
1957              
1958 0 0         if (exists($kv_record->{attr}))
1959             {
1960 0           my $value = [];
1961 0           foreach my $entry (@{$kv_record->{attr}})
  0            
1962             {
1963 0           push(@$value, {attribute => $entry->[0],
1964             value => $entry->[1]});
1965             }
1966 0           $kv_record->{attributes} = $value;
1967 0           delete($kv_record->{attr});
1968             }
1969 0 0         if (exists($kv_record->{attr_mark}))
1970             {
1971 0           my $value = [];
1972 0           foreach my $entry (@{$kv_record->{attr_mark}})
  0            
1973             {
1974 0           push(@$value, {attribute => $entry->[0],
1975             revision_id => $entry->[1]});
1976             }
1977 0           $kv_record->{attr_mark} = $value;
1978             }
1979 0 0         if (exists($kv_record->{content}))
1980             {
1981 0           $kv_record->{file_id} = $kv_record->{content};
1982 0           delete($kv_record->{content});
1983             }
1984              
1985             # Store the record.
1986              
1987 0           push(@$ref, $kv_record);
1988             }
1989             }
1990              
1991 0           return 1;
1992              
1993             }
1994              
1995             }
1996             #
1997             ##############################################################################
1998             #
1999             # Routine - get_file
2000             #
2001             # Description - Get the contents of the file referenced by the specified
2002             # file id.
2003             #
2004             # Data - $self : The object.
2005             # $buffer : A reference to a buffer that is to contain
2006             # the output from this command.
2007             # $file_id : The file id of the file that is to be
2008             # returned.
2009             # Return Value : True on success, otherwise false on failure.
2010             #
2011             ##############################################################################
2012              
2013              
2014              
2015             sub get_file($$$)
2016             {
2017              
2018 0     0 1   my ($self, $buffer, $file_id) = @_;
2019              
2020 0           return $self->mtn_command("get_file", 0, 0, $buffer, $file_id);
2021              
2022             }
2023             #
2024             ##############################################################################
2025             #
2026             # Routine - get_file_of
2027             #
2028             # Description - Get the contents of the specified file under the specified
2029             # revision. If the revision id is undefined then the current
2030             # workspace revision is used.
2031             #
2032             # Data - $self : The object.
2033             # $buffer : A reference to a buffer that is to contain
2034             # the output from this command.
2035             # $file_name : The name of the file to be fetched.
2036             # $revision_id : The revision id upon which the file contents
2037             # are to be based.
2038             # Return Value : True on success, otherwise false on failure.
2039             #
2040             ##############################################################################
2041              
2042              
2043              
2044             sub get_file_of($$$;$)
2045             {
2046              
2047 0     0 1   my ($self, $buffer, $file_name, $revision_id) = @_;
2048              
2049 0           my @opts;
2050              
2051 0 0         push(@opts, {key => "r", value => $revision_id})
2052             if (defined($revision_id));
2053              
2054 0           return $self->mtn_command_with_options("get_file_of",
2055             1,
2056             0,
2057             $buffer,
2058             \@opts,
2059             $file_name);
2060              
2061             }
2062             #
2063             ##############################################################################
2064             #
2065             # Routine - get_file_size
2066             #
2067             # Description - Get the size of the file referenced by the specified file
2068             # id.
2069             #
2070             # Data - $self : The object.
2071             # $buffer : A reference to a buffer that is to contain
2072             # the output from this command.
2073             # $file_id : The file id of the file that is to have its
2074             # size returned.
2075             # Return Value : True on success, otherwise false on failure.
2076             #
2077             ##############################################################################
2078              
2079              
2080              
2081             sub get_file_size($$$)
2082             {
2083              
2084 0     0 1   my ($self, $buffer, $file_id) = @_;
2085              
2086 0           my @list;
2087              
2088 0           $$buffer = "";
2089 0 0         if (! $self->mtn_command("get_file_size", 0, 0, \@list, $file_id))
2090             {
2091 0           return;
2092             }
2093 0           $$buffer = $list[0];
2094              
2095 0           return 1;
2096              
2097             }
2098             #
2099             ##############################################################################
2100             #
2101             # Routine - get_manifest_of
2102             #
2103             # Description - Get the manifest for the current or specified revision.
2104             #
2105             # Data - $self : The object.
2106             # $ref : A reference to a buffer or an array that is
2107             # to contain the output from this command.
2108             # $revision_id : The revision id which is to have its
2109             # manifest returned.
2110             # Return Value : True on success, otherwise false on failure.
2111             #
2112             ##############################################################################
2113              
2114              
2115              
2116             sub get_manifest_of($$;$)
2117             {
2118              
2119 0     0 1   my ($self, $ref, $revision_id) = @_;
2120              
2121             # Run the command and get the data, either as one lump or as a structured
2122             # list.
2123              
2124 0 0         if (ref($ref) eq "SCALAR")
2125             {
2126 0           return $self->mtn_command("get_manifest_of", 0, 1, $ref, $revision_id);
2127             }
2128             else
2129             {
2130              
2131 0           my ($i,
2132             @lines);
2133              
2134 0 0         if (! $self->mtn_command("get_manifest_of",
2135             0,
2136             1,
2137             \@lines,
2138             $revision_id))
2139             {
2140 0           return;
2141             }
2142              
2143             # Reformat the data into a structured array.
2144              
2145 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2146             {
2147 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
2148             {
2149 0           my $kv_record;
2150              
2151             # Get the next key-value record.
2152              
2153 0           parse_kv_record(\@lines,
2154             \$i,
2155             \%get_manifest_of_keys,
2156             \$kv_record);
2157 0           -- $i;
2158              
2159             # Validate it in terms of expected fields and copy data across
2160             # to the correct fields.
2161              
2162 0 0 0       if (exists($kv_record->{file}) || exists($kv_record->{dir}))
2163             {
2164 0           my ($attrs,
2165             $id,
2166             $name,
2167             $type);
2168              
2169 0 0         if (exists($kv_record->{file}))
    0          
2170             {
2171 0           $type = "file";
2172 0           $name = $kv_record->{file};
2173             &$croaker("Corrupt manifest, expected content field "
2174             . "but did not find it")
2175 0 0         unless (exists($kv_record->{content}));
2176 0           $id = $kv_record->{content};
2177             }
2178             elsif (exists($kv_record->{dir}))
2179             {
2180 0           $type = "directory";
2181 0           $name = $kv_record->{dir};
2182             }
2183 0           $attrs = [];
2184 0 0         if (exists($kv_record->{attr}))
2185             {
2186 0           foreach my $entry (@{$kv_record->{attr}})
  0            
2187             {
2188 0           push(@$attrs, {attribute => $entry->[0],
2189             value => $entry->[1]});
2190             }
2191             }
2192 0 0         if ($type eq "file")
2193             {
2194 0           push(@$ref, {type => $type,
2195             name => $name,
2196             file_id => $id,
2197             attributes => $attrs});
2198             }
2199             else
2200             {
2201 0           push(@$ref, {type => $type,
2202             name => $name,
2203             attributes => $attrs});
2204             }
2205             }
2206             }
2207             }
2208              
2209 0           return 1;
2210              
2211             }
2212              
2213             }
2214             #
2215             ##############################################################################
2216             #
2217             # Routine - get_option
2218             #
2219             # Description - Get the value of an option stored in a workspace's _MTN
2220             # directory.
2221             #
2222             # Data - $self : The object.
2223             # $buffer : A reference to a buffer that is to contain
2224             # the output from this command.
2225             # $option_name : The name of the option to be fetched.
2226             # Return Value : True on success, otherwise false on failure.
2227             #
2228             ##############################################################################
2229              
2230              
2231              
2232             sub get_option($$$)
2233             {
2234              
2235 0     0 1   my ($self, $buffer, $option_name) = @_;
2236              
2237 0 0         if (! $self->mtn_command("get_option", 1, 1, $buffer, $option_name))
2238             {
2239 0           return;
2240             }
2241 0           chomp($$buffer);
2242              
2243 0           return 1;
2244              
2245             }
2246             #
2247             ##############################################################################
2248             #
2249             # Routine - get_public_key
2250             #
2251             # Description - Get the public key for the specified key id.
2252             #
2253             # Data - $self : The object.
2254             # $buffer : A reference to a buffer that is to contain
2255             # the output from this command.
2256             # $key_id : The id of the key, either in the form of its
2257             # name or its hash.
2258             # Return Value : True on success, otherwise false on failure.
2259             #
2260             ##############################################################################
2261              
2262              
2263              
2264             sub get_public_key($$$)
2265             {
2266              
2267 0     0 1   my ($self, $buffer, $key_id) = @_;
2268              
2269 0           return $self->mtn_command("get_public_key", 1, 1, $buffer, $key_id);
2270              
2271             }
2272             #
2273             ##############################################################################
2274             #
2275             # Routine - get_revision
2276             #
2277             # Description - Get the revision information for the current or specified
2278             # revision.
2279             #
2280             # Data - $self : The object.
2281             # $ref : A reference to a buffer or an array that is
2282             # to contain the output from this command.
2283             # $revision_id : The revision id which is to have its data
2284             # returned.
2285             # Return Value : True on success, otherwise false on failure.
2286             #
2287             ##############################################################################
2288              
2289              
2290              
2291             sub get_revision($$$)
2292             {
2293              
2294 0     0 1   my ($self, $ref, $revision_id) = @_;
2295              
2296             # Run the command and get the data, either as one lump or as a structured
2297             # list.
2298              
2299 0 0         if (ref($ref) eq "SCALAR")
2300             {
2301 0           return $self->mtn_command("get_revision", 0, 1, $ref, $revision_id);
2302             }
2303             else
2304             {
2305              
2306 0           my @lines;
2307              
2308 0 0         if (! $self->mtn_command("get_revision", 0, 1, \@lines, $revision_id))
2309             {
2310 0           return;
2311             }
2312 0           parse_revision_data($ref, \@lines);
2313              
2314 0           return 1;
2315              
2316             }
2317              
2318             }
2319             #
2320             ##############################################################################
2321             #
2322             # Routine - get_workspace_root
2323             #
2324             # Description - Get the absolute path for the current workspace's root
2325             # directory.
2326             #
2327             # Data - $self : The object.
2328             # $buffer : A reference to a buffer that is to contain
2329             # the output from this command.
2330             # Return Value : True on success, otherwise false on failure.
2331             #
2332             ##############################################################################
2333              
2334              
2335              
2336             sub get_workspace_root($$)
2337             {
2338              
2339 0     0 1   my ($self, $buffer) = @_;
2340              
2341 0 0         if (! $self->mtn_command("get_workspace_root", 0, 1, $buffer))
2342             {
2343 0           return;
2344             }
2345 0           chomp($$buffer);
2346              
2347 0           return 1;
2348              
2349             }
2350             #
2351             ##############################################################################
2352             #
2353             # Routine - graph
2354             #
2355             # Description - Get a complete ancestry graph of the database.
2356             #
2357             # Data - $self : The object.
2358             # $ref : A reference to a buffer or an array that is
2359             # to contain the output from this command.
2360             # Return Value : True on success, otherwise false on failure.
2361             #
2362             ##############################################################################
2363              
2364              
2365              
2366             sub graph($$)
2367             {
2368              
2369 0     0 1   my ($self, $ref) = @_;
2370              
2371             # Run the command and get the data, either as one lump or as a structured
2372             # list.
2373              
2374 0 0         if (ref($ref) eq "SCALAR")
2375             {
2376 0           return $self->mtn_command("graph", 0, 0, $ref);
2377             }
2378             else
2379             {
2380              
2381 0           my ($i,
2382             @lines,
2383             @parent_ids);
2384              
2385 0 0         if (! $self->mtn_command("graph", 0, 0, \@lines))
2386             {
2387 0           return;
2388             }
2389 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2390             {
2391 0           @parent_ids = split(/ /, $lines[$i]);
2392 0           $$ref[$i] = {revision_id => shift(@parent_ids),
2393             parent_ids => [@parent_ids]};
2394             }
2395              
2396 0           return 1;
2397              
2398             }
2399              
2400             }
2401             #
2402             ##############################################################################
2403             #
2404             # Routine - heads
2405             #
2406             # Description - Get a list of revision ids that are heads on the specified
2407             # branch. If no branch is given then the workspace's branch
2408             # is used.
2409             #
2410             # Data - $self : The object.
2411             # $list : A reference to a list that is to contain the
2412             # revision ids.
2413             # $branch_name : The name of the branch that is to have its
2414             # heads returned.
2415             # Return Value : True on success, otherwise false on failure.
2416             #
2417             ##############################################################################
2418              
2419              
2420              
2421             sub heads($$;$)
2422             {
2423              
2424 0     0 1   my ($self, $list, $branch_name) = @_;
2425              
2426 0           return $self->mtn_command("heads", 1, 0, $list, $branch_name);
2427              
2428             }
2429             #
2430             ##############################################################################
2431             #
2432             # Routine - identify
2433             #
2434             # Description - Get the file id, i.e. hash, of the specified file.
2435             #
2436             # Data - $self : The object.
2437             # $buffer : A reference to a buffer that is to contain
2438             # the output from this command.
2439             # $file_name : The name of the file that is to have its id
2440             # returned.
2441             # Return Value : True on success, otherwise false on failure.
2442             #
2443             ##############################################################################
2444              
2445              
2446              
2447             sub identify($$$)
2448             {
2449              
2450 0     0 1   my ($self, $buffer, $file_name) = @_;
2451              
2452 0           my @list;
2453              
2454 0           $$buffer = "";
2455 0 0         if (! $self->mtn_command("identify", 1, 0, \@list, $file_name))
2456             {
2457 0           return;
2458             }
2459 0           $$buffer = $list[0];
2460              
2461 0           return 1;
2462              
2463             }
2464             #
2465             ##############################################################################
2466             #
2467             # Routine - interface_version
2468             #
2469             # Description - Get the version of the mtn automate interface.
2470             #
2471             # Data - $self : The object.
2472             # $buffer : A reference to a buffer that is to contain
2473             # the output from this command.
2474             # Return Value : True on success, otherwise false on failure.
2475             #
2476             ##############################################################################
2477              
2478              
2479              
2480             sub interface_version($$)
2481             {
2482              
2483 0     0 1   my ($self, $buffer) = @_;
2484              
2485 0           my @list;
2486              
2487 0           $$buffer = "";
2488 0 0         if (! $self->mtn_command("interface_version", 0, 0, \@list))
2489             {
2490 0           return;
2491             }
2492 0           $$buffer = $list[0];
2493              
2494 0           return 1;
2495              
2496             }
2497             #
2498             ##############################################################################
2499             #
2500             # Routine - inventory
2501             #
2502             # Description - Get the inventory for the current workspace, optionally
2503             # limiting the output by using the specified options and file
2504             # restrictions.
2505             #
2506             # Data - $self : The object.
2507             # $ref : A reference to a buffer or an array that is
2508             # to contain the output from this command.
2509             # $options : A reference to a list containing the options
2510             # to use.
2511             # @paths : A list of files or directories that are to
2512             # be reported on instead of the entire
2513             # workspace.
2514             # Return Value : True on success, otherwise false on failure.
2515             #
2516             ##############################################################################
2517              
2518              
2519              
2520             sub inventory($$;$@)
2521             {
2522              
2523 0     0 1   my ($self, $ref, $options, @paths) = @_;
2524              
2525 0           my @opts;
2526              
2527             # Process any options.
2528              
2529 0           expand_options($options, \@opts);
2530              
2531             # Run the command and get the data, either as one lump or as a structured
2532             # list.
2533              
2534 0 0         if (ref($ref) eq "SCALAR")
2535             {
2536 0           return $self->mtn_command_with_options("inventory",
2537             1,
2538             1,
2539             $ref,
2540             \@opts,
2541             @paths);
2542             }
2543             else
2544             {
2545              
2546 0           my @lines;
2547              
2548 0 0         if (! $self->mtn_command_with_options("inventory",
2549             1,
2550             1,
2551             \@lines,
2552             \@opts,
2553             @paths))
2554             {
2555 0           return;
2556             }
2557              
2558             # The output format of this command was switched over to a basic_io
2559             # stanza in 0.37 (i/f version 6.x).
2560              
2561 0 0         if ($self->supports(MTN_INVENTORY_IN_IO_STANZA_FORMAT))
2562             {
2563              
2564 0           my $i;
2565              
2566             # Reformat the data into a structured array.
2567              
2568 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2569             {
2570 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
2571             {
2572 0           my $kv_record;
2573              
2574             # Get the next key-value record and store it in the list.
2575              
2576 0           parse_kv_record(\@lines,
2577             \$i,
2578             \%inventory_keys,
2579             \$kv_record);
2580 0           -- $i;
2581 0           push(@$ref, $kv_record);
2582             }
2583             }
2584              
2585             }
2586             else
2587             {
2588              
2589 0           my $i;
2590              
2591             # Reformat the data into a structured array.
2592              
2593 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2594             {
2595 0 0         if ($lines[$i] =~ m/^([A-Z ]{3}) (\d+) (\d+) (.+)$/)
2596             {
2597 0           push(@$ref, {status => $1,
2598             crossref_one => $2,
2599             crossref_two => $3,
2600             name => $4});
2601             }
2602             }
2603              
2604             }
2605              
2606 0           return 1;
2607              
2608             }
2609              
2610             }
2611             #
2612             ##############################################################################
2613             #
2614             # Routine - keys
2615             #
2616             # Description - Get a list of all the keys known to mtn.
2617             #
2618             # Data - $self : The object.
2619             # $ref : A reference to a buffer or an array that is
2620             # to contain the output from this command.
2621             # Return Value : True on success, otherwise false on failure.
2622             #
2623             ##############################################################################
2624              
2625              
2626              
2627             sub keys($$)
2628             {
2629              
2630 0     0 1   my ($self, $ref) = @_;
2631              
2632             # Run the command and get the data, either as one lump or as a structured
2633             # list.
2634              
2635 0 0         if (ref($ref) eq "SCALAR")
2636             {
2637 0           return $self->mtn_command("keys", 0, 1, $ref);
2638             }
2639             else
2640             {
2641              
2642 0           my ($i,
2643             @lines,
2644             @valid_fields);
2645              
2646 0 0         if (! $self->mtn_command("keys", 0, 1, \@lines))
2647             {
2648 0           return;
2649             }
2650              
2651             # Build up a list of valid fields depending upon the version of
2652             # Monotone in use.
2653              
2654 0 0         push(@valid_fields, "given_name", "local_name")
2655             if ($self->supports(MTN_HASHED_SIGNATURES));
2656 0 0         if ($self->supports(MTN_COMMON_KEY_HASH))
2657             {
2658 0           push(@valid_fields, "hash");
2659             }
2660             else
2661             {
2662 0           push(@valid_fields, "public_hash");
2663             }
2664 0           push(@valid_fields, "public_location");
2665              
2666             # Reformat the data into a structured array.
2667              
2668 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2669             {
2670 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
2671             {
2672 0           my $kv_record;
2673              
2674             # Get the next key-value record.
2675              
2676 0           parse_kv_record(\@lines, \$i, \%keys_keys, \$kv_record);
2677 0           -- $i;
2678              
2679             # Validate it in terms of expected fields and store.
2680              
2681 0           foreach my $key (@valid_fields)
2682             {
2683             &$croaker("Corrupt keys list, expected " . $key
2684             . " field but did not find it")
2685 0 0         unless (exists($kv_record->{$key}));
2686             }
2687 0           push(@$ref, $kv_record);
2688             }
2689             }
2690              
2691 0           return 1;
2692              
2693             }
2694              
2695             }
2696             #
2697             ##############################################################################
2698             #
2699             # Routine - leaves
2700             #
2701             # Description - Get a list of leaf revisions.
2702             #
2703             # Data - $self : The object.
2704             # $list : A reference to a list that is to contain the
2705             # revision ids.
2706             # Return Value : True on success, otherwise false on failure.
2707             #
2708             ##############################################################################
2709              
2710              
2711              
2712             sub leaves($$)
2713             {
2714              
2715 0     0 1   my ($self, $list) = @_;
2716              
2717 0           return $self->mtn_command("leaves", 0, 0, $list);
2718              
2719             }
2720             #
2721             ##############################################################################
2722             #
2723             # Routine - log
2724             #
2725             # Description - Get a list of revision ids that form a log history for an
2726             # entire project, optionally limiting the output by using the
2727             # specified options and file name restrictions.
2728             #
2729             # Data - $self : The object.
2730             # $list : A reference to a list that is to contain the
2731             # branch names.
2732             # $options : A reference to a list containing the options
2733             # to use.
2734             # $file_name : The name of the file that is to be reported
2735             # on instead of the entire project.
2736             # Return Value : True on success, otherwise false on failure.
2737             #
2738             ##############################################################################
2739              
2740              
2741              
2742             sub log($$;$$)
2743             {
2744              
2745 0     0 1   my ($self, $list, $options, $file_name) = @_;
2746              
2747 0           my @opts;
2748              
2749             # Process any options.
2750              
2751 0           expand_options($options, \@opts);
2752              
2753             # Run the command and get the data.
2754              
2755 0           return $self->mtn_command_with_options("log",
2756             1,
2757             1,
2758             $list,
2759             \@opts,
2760             $file_name);
2761              
2762             }
2763             #
2764             ##############################################################################
2765             #
2766             # Routine - lua
2767             #
2768             # Description - Call the specified LUA function with any required
2769             # arguments.
2770             #
2771             # Data - $self : The object.
2772             # $buffer : A reference to a buffer that is to contain
2773             # the output from this command.
2774             # $lua_function : The name of the LUA function that is to be
2775             # called.
2776             # @arguments : A list of arguments that are to be passed
2777             # to the LUA function.
2778             # Return Value : True on success, otherwise false on
2779             # failure.
2780             #
2781             ##############################################################################
2782              
2783              
2784              
2785             sub lua($$$;@)
2786             {
2787              
2788 0     0 1   my ($self, $buffer, $lua_function, @arguments) = @_;
2789              
2790 0           return $self->mtn_command("lua", 1, 1, $buffer, $lua_function, @arguments);
2791              
2792             }
2793             #
2794             ##############################################################################
2795             #
2796             # Routine - packet_for_fdata
2797             #
2798             # Description - Get the contents of the file referenced by the specified
2799             # file id in packet format.
2800             #
2801             # Data - $self : The object.
2802             # $buffer : A reference to a buffer that is to contain
2803             # the output from this command.
2804             # $file_id : The file id of the file that is to be
2805             # returned.
2806             # Return Value : True on success, otherwise false on failure.
2807             #
2808             ##############################################################################
2809              
2810              
2811              
2812             sub packet_for_fdata($$$)
2813             {
2814              
2815 0     0 1   my ($self, $buffer, $file_id) = @_;
2816              
2817 0           return $self->mtn_command("packet_for_fdata", 0, 0, $buffer, $file_id);
2818              
2819             }
2820             #
2821             ##############################################################################
2822             #
2823             # Routine - packet_for_fdelta
2824             #
2825             # Description - Get the file delta between the two files referenced by the
2826             # specified file ids in packet format.
2827             #
2828             # Data - $self : The object.
2829             # $buffer : A reference to a buffer that is to contain
2830             # the output from this command.
2831             # $from_file_id : The file id of the file that is to be used
2832             # as the base in the delta operation.
2833             # $to_file_id : The file id of the file that is to be used
2834             # as the target in the delta operation.
2835             # Return Value : True on success, otherwise false on
2836             # failure.
2837             #
2838             ##############################################################################
2839              
2840              
2841              
2842             sub packet_for_fdelta($$$$)
2843             {
2844              
2845 0     0 1   my ($self, $buffer, $from_file_id, $to_file_id) = @_;
2846              
2847 0           return $self->mtn_command("packet_for_fdelta",
2848             0,
2849             0,
2850             $buffer,
2851             $from_file_id,
2852             $to_file_id);
2853              
2854             }
2855             #
2856             ##############################################################################
2857             #
2858             # Routine - packet_for_rdata
2859             #
2860             # Description - Get the contents of the revision referenced by the
2861             # specified revision id in packet format.
2862             #
2863             # Data - $self : The object.
2864             # $buffer : A reference to a buffer that is to contain
2865             # the output from this command.
2866             # $revision_id : The revision id of the revision that is to
2867             # be returned.
2868             # Return Value : True on success, otherwise false on failure.
2869             #
2870             ##############################################################################
2871              
2872              
2873              
2874             sub packet_for_rdata($$$)
2875             {
2876              
2877 0     0 1   my ($self, $buffer, $revision_id) = @_;
2878              
2879 0           return $self->mtn_command("packet_for_rdata", 0, 0, $buffer, $revision_id);
2880              
2881             }
2882             #
2883             ##############################################################################
2884             #
2885             # Routine - packets_for_certs
2886             #
2887             # Description - Get all the certs for the revision referenced by the
2888             # specified revision id in packet format.
2889             #
2890             # Data - $self : The object.
2891             # $buffer : A reference to a buffer that is to contain
2892             # the output from this command.
2893             # $revision_id : The revision id of the revision that is to
2894             # have its certs returned.
2895             # Return Value : True on success, otherwise false on failure.
2896             #
2897             ##############################################################################
2898              
2899              
2900              
2901             sub packets_for_certs($$$)
2902             {
2903              
2904 0     0 1   my ($self, $buffer, $revision_id) = @_;
2905              
2906 0           return $self->mtn_command("packets_for_certs",
2907             0,
2908             0,
2909             $buffer,
2910             $revision_id);
2911              
2912             }
2913             #
2914             ##############################################################################
2915             #
2916             # Routine - parents
2917             #
2918             # Description - Get a list of parents for the specified revision.
2919             #
2920             # Data - $self : The object.
2921             # $list : A reference to a list that is to contain the
2922             # revision ids.
2923             # $revision_id : The revision id that is to have its parents
2924             # returned.
2925             # Return Value : True on success, otherwise false on failure.
2926             #
2927             ##############################################################################
2928              
2929              
2930              
2931             sub parents($$$)
2932             {
2933              
2934 0     0 1   my ($self, $list, $revision_id) = @_;
2935              
2936 0           return $self->mtn_command("parents", 0, 0, $list, $revision_id);
2937              
2938             }
2939             #
2940             ##############################################################################
2941             #
2942             # Routine - put_file
2943             #
2944             # Description - Put the specified file contents into the database,
2945             # optionally basing it on the specified file id (this is used
2946             # for delta encoding).
2947             #
2948             # Data - $self : The object.
2949             # $buffer : A reference to a buffer that is to contain
2950             # the output from this command.
2951             # $base_file_id : The file id of the previous version of this
2952             # file or undef if this is a new file.
2953             # $contents : A reference to a buffer containing the
2954             # file's contents.
2955             # Return Value : True on success, otherwise false on
2956             # failure.
2957             #
2958             ##############################################################################
2959              
2960              
2961              
2962             sub put_file($$$$)
2963             {
2964              
2965 0     0 1   my ($self, $buffer, $base_file_id, $contents) = @_;
2966              
2967 0           my @list;
2968              
2969 0 0         if (defined($base_file_id))
2970             {
2971 0 0         if (! $self->mtn_command("put_file",
2972             0,
2973             0,
2974             \@list,
2975             $base_file_id,
2976             $contents))
2977             {
2978 0           return;
2979             }
2980             }
2981             else
2982             {
2983 0 0         if (! $self->mtn_command("put_file", 0, 0, \@list, $contents))
2984             {
2985 0           return;
2986             }
2987             }
2988 0           $$buffer = $list[0];
2989              
2990 0           return 1;
2991              
2992             }
2993             #
2994             ##############################################################################
2995             #
2996             # Routine - put_public_key
2997             #
2998             # Description - Put the specified public key data into the database.
2999             #
3000             # Data - $self : The object.
3001             # $public_key : The public key data that is to be stored in
3002             # the database.
3003             # Return Value : True on success, otherwise false on failure.
3004             #
3005             ##############################################################################
3006              
3007              
3008              
3009             sub put_public_key($$)
3010             {
3011              
3012 0     0 1   my ($self, $public_key) = @_;
3013              
3014 0           my $dummy;
3015              
3016 0           return $self->mtn_command("put_public_key", 1, 0, \$dummy, $public_key);
3017              
3018             }
3019             #
3020             ##############################################################################
3021             #
3022             # Routine - put_revision
3023             #
3024             # Description - Put the specified revision data into the database.
3025             #
3026             # Data - $self : The object.
3027             # $buffer : A reference to a buffer that is to contain
3028             # the output from this command.
3029             # $contents : A reference to a buffer containing the
3030             # revision's contents.
3031             # Return Value : True on success, otherwise false on failure.
3032             #
3033             ##############################################################################
3034              
3035              
3036              
3037             sub put_revision($$$)
3038             {
3039              
3040 0     0 1   my ($self, $buffer, $contents) = @_;
3041              
3042 0           my @list;
3043              
3044 0 0         if (! $self->mtn_command("put_revision", 1, 0, \@list, $contents))
3045             {
3046 0           return;
3047             }
3048 0           $$buffer = $list[0];
3049              
3050 0           return 1;
3051              
3052             }
3053             #
3054             ##############################################################################
3055             #
3056             # Routine - read_packets
3057             #
3058             # Description - Decode and store the specified packet data in the database.
3059             #
3060             # Data - $self : The object.
3061             # $packet_data : The packet data that is to be stored in the
3062             # database.
3063             # Return Value : True on success, otherwise false on failure.
3064             #
3065             ##############################################################################
3066              
3067              
3068              
3069             sub read_packets($$)
3070             {
3071              
3072 0     0 1   my ($self, $packet_data) = @_;
3073              
3074 0           my $dummy;
3075              
3076 0           return $self->mtn_command("read_packets", 0, 0, \$dummy, $packet_data);
3077              
3078             }
3079             #
3080             ##############################################################################
3081             #
3082             # Routine - roots
3083             #
3084             # Description - Get a list of root revisions, i.e. revisions with no
3085             # parents.
3086             #
3087             # Data - $self : The object.
3088             # $list : A reference to a list that is to contain the
3089             # revision ids.
3090             # Return Value : True on success, otherwise false on failure.
3091             #
3092             ##############################################################################
3093              
3094              
3095              
3096             sub roots($$)
3097             {
3098              
3099 0     0 1   my ($self, $list) = @_;
3100              
3101 0           return $self->mtn_command("roots", 0, 0, $list);
3102              
3103             }
3104             #
3105             ##############################################################################
3106             #
3107             # Routine - select
3108             #
3109             # Description - Get a list of revision ids that match the specified
3110             # selector.
3111             #
3112             # Data - $self : The object.
3113             # $list : A reference to a list that is to contain the
3114             # revision ids.
3115             # $selector : The selector that is to be used.
3116             # Return Value : True on success, otherwise false on failure.
3117             #
3118             ##############################################################################
3119              
3120              
3121              
3122             sub select($$$)
3123             {
3124              
3125 0     0 1   my ($self, $list, $selector) = @_;
3126              
3127 0           return $self->mtn_command("select", 1, 0, $list, $selector);
3128              
3129             }
3130             #
3131             ##############################################################################
3132             #
3133             # Routine - set_attribute
3134             #
3135             # Description - Set an attribute on the specified file or directory.
3136             #
3137             # Data - $self : The object.
3138             # $path : The name of the file or directory that is to
3139             # have an attribute set.
3140             # $key : The name of the attribute that as to be set.
3141             # $value : The value that the attribute is to be set
3142             # to.
3143             # Return Value : True on success, otherwise false on failure.
3144             #
3145             ##############################################################################
3146              
3147              
3148              
3149             sub set_attribute($$$$)
3150             {
3151              
3152 0     0 1   my ($self, $path, $key, $value) = @_;
3153              
3154 0           my $dummy;
3155              
3156 0           return $self->mtn_command("set_attribute",
3157             1,
3158             0,
3159             \$dummy,
3160             $path,
3161             $key,
3162             $value);
3163              
3164             }
3165             #
3166             ##############################################################################
3167             #
3168             # Routine - set_db_variable
3169             #
3170             # Description - Set the value of a database variable.
3171             #
3172             # Data - $self : The object.
3173             # $domain : The domain of the database variable.
3174             # $name : The name of the variable to set.
3175             # $value : The value to set the variable to.
3176             # Return Value : True on success, otherwise false on failure.
3177             #
3178             ##############################################################################
3179              
3180              
3181              
3182             sub set_db_variable($$$$)
3183             {
3184              
3185 0     0 1   my ($self, $domain, $name, $value) = @_;
3186              
3187 0           my ($cmd,
3188             $dummy);
3189              
3190             # This command was renamed in version 0.39 (i/f version 7.x).
3191              
3192 0 0         if ($self->supports(MTN_SET_DB_VARIABLE))
3193             {
3194 0           $cmd = "set_db_variable";
3195             }
3196             else
3197             {
3198 0           $cmd = "db_set";
3199             }
3200 0           return $self->mtn_command($cmd, 1, 0, \$dummy, $domain, $name, $value);
3201              
3202             }
3203             #
3204             ##############################################################################
3205             #
3206             # Routine - show_conflicts
3207             #
3208             # Description - Get a list of conflicts between the first two head
3209             # revisions on the current branch, optionally one can specify
3210             # both head revision ids and the name of the branch that they
3211             # reside on.
3212             #
3213             # Data - $self : The object.
3214             # $ref : A reference to a buffer or an array
3215             # that is to contain the output from
3216             # this command.
3217             # $branch : The name of the branch that the head
3218             # revisions are on.
3219             # $left_revision_id : The left hand head revision id.
3220             # $right_revision_id : The right hand head revision id.
3221             # Return Value : True on success, otherwise false on
3222             # failure.
3223             #
3224             ##############################################################################
3225              
3226              
3227              
3228             sub show_conflicts($$;$$$)
3229             {
3230              
3231 0     0 1   my ($self, $ref, $branch, $left_revision_id, $right_revision_id) = @_;
3232              
3233 0           my @opts;
3234 0           my $this = $class_records{$self->{$class_name}};
3235              
3236             # Validate the number of arguments and adjust them accordingly.
3237              
3238 0 0 0       if (scalar(@_) == 4)
    0          
3239             {
3240              
3241             # Assume just the revision ids were given, so adjust the arguments
3242             # accordingly.
3243              
3244 0           $right_revision_id = $left_revision_id;
3245 0           $left_revision_id = $branch;
3246 0           $branch = undef;
3247              
3248             }
3249             elsif (scalar(@_) < 2 || scalar(@_) > 5)
3250             {
3251              
3252             # Wrong number of arguments.
3253              
3254 0           &$croaker("Wrong number of arguments given");
3255              
3256             }
3257              
3258             # Process any options.
3259              
3260 0 0         @opts = ({key => "branch", value => $branch}) if (defined($branch));
3261              
3262             # Run the command and get the data, either as one lump or as a structured
3263             # list.
3264              
3265 0 0         if (ref($ref) eq "SCALAR")
3266             {
3267 0           return $self->mtn_command_with_options("show_conflicts",
3268             1,
3269             1,
3270             $ref,
3271             \@opts,
3272             $left_revision_id,
3273             $right_revision_id);
3274             }
3275             else
3276             {
3277              
3278 0           my ($i,
3279             @lines);
3280              
3281 0 0         if (! $self->mtn_command_with_options("show_conflicts",
3282             1,
3283             1,
3284             \@lines,
3285             \@opts,
3286             $left_revision_id,
3287             $right_revision_id))
3288             {
3289 0           return;
3290             }
3291              
3292             # Reformat the data into a structured array.
3293              
3294 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
3295             {
3296 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
3297             {
3298 0           my $kv_record;
3299              
3300             # Get the next key-value record.
3301              
3302 0           parse_kv_record(\@lines,
3303             \$i,
3304             \%show_conflicts_keys,
3305             \$kv_record);
3306 0           -- $i;
3307              
3308             # Validate it in terms of expected fields and store.
3309              
3310 0 0         if (exists($kv_record->{left}))
3311             {
3312 0           foreach my $key ("ancestor", "right")
3313             {
3314             &$croaker("Corrupt show_conflicts list, expected "
3315             . $key . " field but did not find it")
3316 0 0         unless (exists($kv_record->{$key}));
3317             }
3318             }
3319 0           push(@$ref, $kv_record);
3320             }
3321             }
3322              
3323 0           return 1;
3324              
3325             }
3326              
3327             }
3328             #
3329             ##############################################################################
3330             #
3331             # Routine - sync
3332             #
3333             # Description - Synchronises database changes between the local database
3334             # and the specified remote server. This member function also
3335             # provides the implementation to the pull and push methods.
3336             #
3337             # Data - $self : The object.
3338             # $ref : A reference to a buffer or an array that is
3339             # to contain the output from this command.
3340             # $options : A reference to a list containing the options
3341             # to use.
3342             # $uri : The URI that is to be synchronised with.
3343             # Return Value : True on success, otherwise false on failure.
3344             #
3345             ##############################################################################
3346              
3347              
3348              
3349             sub sync($$;$$)
3350             {
3351              
3352 0     0 1   my ($self, $ref, $options, $uri) = @_;
3353              
3354 0           my ($cmd,
3355             @opts);
3356              
3357             # Find out how we were called (and hence the command that is to be run).
3358             # Remember that the routine name will be fully qualified.
3359              
3360 0           $cmd = (caller(0))[3];
3361 0 0         $cmd = $1 if ($cmd =~ m/^.+\:\:([^:]+)$/);
3362              
3363             # Process any options.
3364              
3365 0           expand_options($options, \@opts);
3366              
3367             # Run the command and get the data, either as one lump or as a structured
3368             # list.
3369              
3370 0 0         if (ref($ref) eq "SCALAR")
3371             {
3372 0           return $self->mtn_command_with_options($cmd,
3373             1,
3374             1,
3375             $ref,
3376             \@opts,
3377             $uri);
3378             }
3379             else
3380             {
3381              
3382 0           my ($i,
3383             @lines);
3384              
3385 0 0         if (! $self->mtn_command_with_options($cmd,
3386             1,
3387             1,
3388             \@lines,
3389             \@opts,
3390             $uri))
3391             {
3392 0           return;
3393             }
3394              
3395             # Reformat the data into a structured array.
3396              
3397 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
3398             {
3399 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
3400             {
3401 0           my $kv_record;
3402              
3403             # Get the next key-value record and store it in the list.
3404              
3405 0           parse_kv_record(\@lines,
3406             \$i,
3407             \%sync_keys,
3408             \$kv_record);
3409 0           -- $i;
3410 0           push(@$ref, $kv_record);
3411             }
3412             }
3413              
3414 0           return 1;
3415              
3416             }
3417              
3418             }
3419             #
3420             ##############################################################################
3421             #
3422             # Routine - tags
3423             #
3424             # Description - Get all the tags attached to revisions on branches that
3425             # match the specified branch pattern. If no pattern is given
3426             # then all branches are searched.
3427             #
3428             # Data - $self : The object.
3429             # $ref : A reference to a buffer or an array that
3430             # is to contain the output from this
3431             # command.
3432             # $branch_pattern : The branch name pattern that the search
3433             # is to be limited to.
3434             # Return Value : True on success, otherwise false on
3435             # failure.
3436             #
3437             ##############################################################################
3438              
3439              
3440              
3441             sub tags($$;$)
3442             {
3443              
3444 0     0 1   my ($self, $ref, $branch_pattern) = @_;
3445              
3446             # Run the command and get the data, either as one lump or as a structured
3447             # list.
3448              
3449 0 0         if (ref($ref) eq "SCALAR")
3450             {
3451 0           return $self->mtn_command("tags", 1, 1, $ref, $branch_pattern);
3452             }
3453             else
3454             {
3455              
3456 0           my ($i,
3457             @lines);
3458              
3459 0 0         if (! $self->mtn_command("tags", 1, 1, \@lines, $branch_pattern))
3460             {
3461 0           return;
3462             }
3463              
3464             # Reformat the data into a structured array.
3465              
3466 0           for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
3467             {
3468 0 0         if ($lines[$i] =~ m/$io_stanza_re/)
3469             {
3470 0           my $kv_record;
3471              
3472             # Get the next key-value record.
3473              
3474 0           parse_kv_record(\@lines, \$i, \%tags_keys, \$kv_record);
3475 0           -- $i;
3476              
3477             # Validate it in terms of expected fields and store.
3478              
3479 0 0         if (exists($kv_record->{tag}))
3480             {
3481 0           foreach my $key ("revision", "signer")
3482             {
3483             &$croaker("Corrupt tags list, expected " . $key
3484             . " field but did not find it")
3485 0 0         unless (exists($kv_record->{$key}));
3486             }
3487             $kv_record->{branches} = []
3488             unless (exists($kv_record->{branches})
3489 0 0 0       && defined($kv_record->{branches}));
3490 0           $kv_record->{revision_id} = $kv_record->{revision};
3491 0           delete($kv_record->{revision});
3492 0           push(@$ref, $kv_record);
3493             }
3494             }
3495             }
3496              
3497 0           return 1;
3498              
3499             }
3500              
3501             }
3502             #
3503             ##############################################################################
3504             #
3505             # Routine - toposort
3506             #
3507             # Description - Sort the specified revision ids such that the ancestors
3508             # come out first.
3509             #
3510             # Data - $self : The object.
3511             # $list : A reference to a list that is to contain
3512             # the revision ids.
3513             # @revision_ids : The revision ids that are to be sorted with
3514             # the ancestors coming first.
3515             # Return Value : True on success, otherwise false on
3516             # failure.
3517             #
3518             ##############################################################################
3519              
3520              
3521              
3522             sub toposort($$@)
3523             {
3524              
3525 0     0 1   my ($self, $list, @revision_ids) = @_;
3526              
3527 0           return $self->mtn_command("toposort", 0, 0, $list, @revision_ids);
3528              
3529             }
3530             #
3531             ##############################################################################
3532             #
3533             # Routine - update
3534             #
3535             # Description - Updates the current workspace to the specified revision and
3536             # possible branch. If no options are specified then the
3537             # workspace is updated to the head revision of the current
3538             # branch.
3539             #
3540             # Data - $self : The object.
3541             # $options : A reference to a list containing the options
3542             # to use.
3543             # Return Value : True on success, otherwise false on failure.
3544             #
3545             ##############################################################################
3546              
3547              
3548              
3549             sub update($;$)
3550             {
3551              
3552 0     0 1   my ($self, $options) = @_;
3553              
3554 0           my ($dummy,
3555             @opts);
3556              
3557             # Process any options.
3558              
3559 0           expand_options($options, \@opts);
3560              
3561             # Run the command.
3562              
3563 0           return $self->mtn_command_with_options("update", 1, 1, \$dummy, \@opts);
3564              
3565             }
3566             #
3567             ##############################################################################
3568             #
3569             # Routine - closedown
3570             #
3571             # Description - If started then stop the mtn subprocess.
3572             #
3573             # Data - $self : The object.
3574             #
3575             ##############################################################################
3576              
3577              
3578              
3579             sub closedown($)
3580             {
3581              
3582 0     0 1   my $self = $_[0];
3583              
3584 0           my $this = $class_records{$self->{$class_name}};
3585              
3586 0 0         if ($this->{mtn_pid} != 0)
3587             {
3588              
3589             # Close off all file descriptors to the mtn subprocess. This should be
3590             # enough to cause it to exit gracefully.
3591              
3592 0           $this->{mtn_in}->close();
3593 0           $this->{mtn_out}->close();
3594 0           $this->{mtn_err}->close();
3595              
3596             # Reap the mtn subprocess and deal with any errors.
3597              
3598 0           for (my $i = 0; $i < 4; ++ $i)
3599             {
3600              
3601 0           my $wait_status = 0;
3602              
3603             # Wait for the mtn subprocess to exit (preserving the current state
3604             # of $@ so that any exception that has already occurred is not
3605             # lost, also ignore any errors resulting from waitpid()
3606             # interruption).
3607              
3608             {
3609 0           local $@;
  0            
3610             eval
3611 0           {
3612 0     0     local $SIG{ALRM} = sub { die(WAITPID_INTERRUPT); };
  0            
3613 0           alarm(5);
3614 0           $wait_status = waitpid($this->{mtn_pid}, 0);
3615 0           alarm(0);
3616             };
3617 0 0 0       $wait_status = 0
      0        
3618             if ($@ eq WAITPID_INTERRUPT && $wait_status < 0
3619             && $! == EINTR);
3620             }
3621              
3622             # The mtn subprocess has terminated.
3623              
3624 0 0 0       if ($wait_status == $this->{mtn_pid})
    0 0        
    0          
    0          
3625             {
3626 0           last;
3627             }
3628              
3629             # The mtn subprocess is still there so try and kill it unless it's
3630             # time to just give up.
3631              
3632             elsif ($i < 3 && $wait_status == 0)
3633             {
3634 0 0         if ($i == 0)
    0          
3635             {
3636 0           kill("INT", $this->{mtn_pid});
3637             }
3638             elsif ($i == 1)
3639             {
3640 0           kill("TERM", $this->{mtn_pid});
3641             }
3642             else
3643             {
3644 0           kill("KILL", $this->{mtn_pid});
3645             }
3646             }
3647              
3648             # Stop if we don't have any relevant children to wait for anymore.
3649              
3650             elsif ($wait_status < 0 && $! == ECHILD)
3651             {
3652 0           last;
3653             }
3654              
3655             # Either there is some other error with waitpid() or a child
3656             # process has been reaped that we aren't interested in (in which
3657             # case just ignore it).
3658              
3659             elsif ($wait_status < 0)
3660             {
3661 0           my $err_msg = $!;
3662 0           kill("KILL", $this->{mtn_pid});
3663 0           &$croaker("waitpid failed: " . $err_msg);
3664             }
3665              
3666             }
3667              
3668 0           $this->{poll_out} = undef;
3669 0           $this->{poll_err} = undef;
3670 0           $this->{mtn_pid} = 0;
3671              
3672             }
3673              
3674 0           return;
3675              
3676             }
3677             #
3678             ##############################################################################
3679             #
3680             # Routine - db_locked_condition_detected
3681             #
3682             # Description - Check to see if the Monotone database was locked the last
3683             # time a command was issued.
3684             #
3685             # Data - $self : The object.
3686             # Return Value : True if the database was locked the last
3687             # time a command was issues, otherwise false.
3688             #
3689             ##############################################################################
3690              
3691              
3692              
3693             sub db_locked_condition_detected($)
3694             {
3695              
3696 0     0 1   my $self = $_[0];
3697              
3698 0           my $this = $class_records{$self->{$class_name}};
3699              
3700 0           return $this->{db_is_locked};
3701              
3702             }
3703             #
3704             ##############################################################################
3705             #
3706             # Routine - get_db_name
3707             #
3708             # Description - Return the file name of the Monotone database as given to
3709             # the constructor.
3710             #
3711             # Data - $self : The object.
3712             # Return Value : The file name of the database as given to
3713             # the constructor or undef if no database was
3714             # specified.
3715             #
3716             ##############################################################################
3717              
3718              
3719              
3720             sub get_db_name($)
3721             {
3722              
3723 0     0 1   my $self = $_[0];
3724              
3725 0           my $this = $class_records{$self->{$class_name}};
3726              
3727 0 0 0       if (defined($this->{db_name}) && $this->{db_name} eq IN_MEMORY_DB_NAME)
3728             {
3729 0           return undef;
3730             }
3731             else
3732             {
3733 0           return $this->{db_name};
3734             }
3735              
3736             }
3737             #
3738             ##############################################################################
3739             #
3740             # Routine - get_error_message
3741             #
3742             # Description - Return the message for the last error reported by this
3743             # class.
3744             #
3745             # Data - $self : The object.
3746             # Return Value : The message for the last error detected, or
3747             # an empty string if nothing has gone wrong
3748             # yet.
3749             #
3750             ##############################################################################
3751              
3752              
3753              
3754             sub get_error_message($)
3755             {
3756              
3757 0     0 1   my $self = $_[0];
3758              
3759 0           my $this = $class_records{$self->{$class_name}};
3760              
3761 0           return $this->{error_msg};
3762              
3763             }
3764             #
3765             ##############################################################################
3766             #
3767             # Routine - get_pid
3768             #
3769             # Description - Return the process id of the mtn automate stdio process.
3770             #
3771             # Data - $self : The object.
3772             # Return Value : The process id of the mtn automate stdio
3773             # process, or zero if no process is thought to
3774             # be running.
3775             #
3776             ##############################################################################
3777              
3778              
3779              
3780             sub get_pid($)
3781             {
3782              
3783 0     0 1   my $self = $_[0];
3784              
3785 0           my $this = $class_records{$self->{$class_name}};
3786              
3787 0           return $this->{mtn_pid};
3788              
3789             }
3790             #
3791             ##############################################################################
3792             #
3793             # Routine - get_service_name
3794             #
3795             # Description - Return the service name of the Monotone server as given to
3796             # the constructor.
3797             #
3798             # Data - $self : The object.
3799             # Return Value : The service name of the Monotone server as
3800             # given to the constructor or undef if no
3801             # service was specified.
3802             #
3803             ##############################################################################
3804              
3805              
3806              
3807             sub get_service_name($)
3808             {
3809              
3810 0     0 1   my $self = $_[0];
3811              
3812 0           my $this = $class_records{$self->{$class_name}};
3813              
3814 0           return $this->{network_service};
3815              
3816             }
3817             #
3818             ##############################################################################
3819             #
3820             # Routine - get_ws_path
3821             #
3822             # Description - Return the the workspace's base directory as either given
3823             # to the constructor or deduced from the current workspace.
3824             # If neither condition holds true then undef is returned.
3825             # Please note that the workspace's base directory may differ
3826             # from that given to the constructor if the specified
3827             # workspace path is actually a subdirectory within that
3828             # workspace.
3829             #
3830             # Data - $self : The object.
3831             # Return Value : The workspace's base directory or undef if
3832             # no workspace was specified and there is no
3833             # current workspace.
3834             #
3835             ##############################################################################
3836              
3837              
3838              
3839             sub get_ws_path($)
3840             {
3841              
3842 0     0 1   my $self = $_[0];
3843              
3844 0           my $this = $class_records{$self->{$class_name}};
3845              
3846 0           return $this->{ws_path};
3847              
3848             }
3849             #
3850             ##############################################################################
3851             #
3852             # Routine - ignore_suspend_certs
3853             #
3854             # Description - Determine whether revisions with the suspend cert are to be
3855             # ignored or not. If the head revisions on a branch are all
3856             # suspended then that branch is also ignored.
3857             #
3858             # Data - $self : The object.
3859             # $ignore : True if suspend certs are to be ignored
3860             # (i.e. all revisions are `visible'),
3861             # otherwise false if suspend certs are to be
3862             # honoured.
3863             # Return Value : True on success, otherwise false on failure.
3864             #
3865             ##############################################################################
3866              
3867              
3868              
3869             sub ignore_suspend_certs($$)
3870             {
3871              
3872 0     0 1   my ($self, $ignore) = @_;
3873              
3874 0           my $this = $class_records{$self->{$class_name}};
3875              
3876             # This only works from version 0.37 (i/f version 6.x).
3877              
3878 0 0 0       if ($this->{honour_suspend_certs} && $ignore)
    0 0        
3879             {
3880 0 0         if ($self->supports(MTN_IGNORING_OF_SUSPEND_CERTS))
3881             {
3882 0           $this->{honour_suspend_certs} = undef;
3883 0           $self->closedown();
3884 0           $self->startup();
3885             }
3886             else
3887             {
3888 0           $this->{error_msg} = "Ignoring suspend certs is unsupported in "
3889             . "this version of Monotone";
3890 0           &$carper($this->{error_msg});
3891 0           return;
3892             }
3893             }
3894             elsif (! ($this->{honour_suspend_certs} || $ignore))
3895             {
3896 0           $this->{honour_suspend_certs} = 1;
3897 0           $self->closedown();
3898 0           $self->startup();
3899             }
3900              
3901 0           return 1;
3902              
3903             }
3904             #
3905             ##############################################################################
3906             #
3907             # Routine - register_db_locked_handler
3908             #
3909             # Description - Register the specified routine as a database locked handler
3910             # for this class. This is both a class as well as an object
3911             # method. When used as a class method, the specified database
3912             # locked handler is used as the default handler for all those
3913             # objects that do not specify their own handlers.
3914             #
3915             # Data - $self : Either the object, the package name or not
3916             # present depending upon how this method is
3917             # called.
3918             # $handler : A reference to the database locked handler
3919             # routine. If this is not provided then the
3920             # existing database locked handler routine is
3921             # unregistered and database locking clashes
3922             # are handled in the default way.
3923             # $client_data : The client data that is to be passed to the
3924             # registered database locked handler when it
3925             # is called.
3926             #
3927             ##############################################################################
3928              
3929              
3930              
3931             sub register_db_locked_handler(;$$$)
3932             {
3933              
3934 0     0 1   my ($self,
3935             $this);
3936 0 0         if ($_[0]->isa(__PACKAGE__))
3937             {
3938 0 0         if (ref($_[0]) ne "")
3939             {
3940 0           $self = shift();
3941 0           $this = $class_records{$self->{$class_name}};
3942             }
3943             else
3944             {
3945 0           shift();
3946             }
3947             }
3948 0           my ($handler, $client_data) = @_;
3949              
3950 0 0         if (defined($self))
3951             {
3952 0 0         if (defined($handler))
3953             {
3954 0           $this->{db_locked_handler} = $handler;
3955 0           $this->{db_locked_handler_data} = $client_data;
3956             }
3957             else
3958             {
3959             $this->{db_locked_handler} = $this->{db_locked_handler_data} =
3960 0           undef;
3961             }
3962             }
3963             else
3964             {
3965 0 0         if (defined($handler))
3966             {
3967 0           $db_locked_handler = $handler;
3968 0           $db_locked_handler_data = $client_data;
3969             }
3970             else
3971             {
3972 0           $db_locked_handler = $db_locked_handler_data = undef;
3973             }
3974             }
3975              
3976 0           return;
3977              
3978             }
3979             #
3980             ##############################################################################
3981             #
3982             # Routine - register_error_handler
3983             #
3984             # Description - Register the specified routine as an error handler for
3985             # class. This is a class method rather than an object one as
3986             # errors can be raised when calling the constructor.
3987             #
3988             # Data - $self : The object. This may not be present
3989             # depending upon how this method is called and
3990             # is ignored if it is present anyway.
3991             # $severity : The level of error that the handler is being
3992             # registered for.
3993             # $handler : A reference to the error handler routine. If
3994             # this is not provided then the existing error
3995             # handler routine is unregistered and errors
3996             # are handled in the default way.
3997             # $client_data : The client data that is to be passed to the
3998             # registered error handler when it is called.
3999             #
4000             ##############################################################################
4001              
4002              
4003              
4004             sub register_error_handler($;$$$)
4005             {
4006              
4007 0 0   0 1   shift() if ($_[0]->isa(__PACKAGE__));
4008 0           my ($severity, $handler, $client_data) = @_;
4009              
4010 0 0         if ($severity == MTN_SEVERITY_ERROR)
    0          
    0          
4011             {
4012 0 0         if (defined($handler))
4013             {
4014 0           $error_handler = $handler;
4015 0           $error_handler_data = $client_data;
4016 0           $croaker = \&error_handler_wrapper;
4017             }
4018             else
4019             {
4020 0           $croaker = \&croak;
4021 0           $error_handler = $error_handler_data = undef;
4022             }
4023             }
4024             elsif ($severity == MTN_SEVERITY_WARNING)
4025             {
4026 0 0         if (defined($handler))
4027             {
4028 0           $warning_handler = $handler;
4029 0           $warning_handler_data = $client_data;
4030 0           $carper = \&warning_handler_wrapper;
4031             }
4032             else
4033             {
4034 0     0     $carper = sub { return; };
  0            
4035 0           $warning_handler = $warning_handler_data = undef;
4036             }
4037             }
4038             elsif ($severity == MTN_SEVERITY_ALL)
4039             {
4040 0 0         if (defined($handler))
4041             {
4042 0           $error_handler = $warning_handler = $handler;
4043 0           $error_handler_data = $warning_handler_data = $client_data;
4044 0           $carper = \&warning_handler_wrapper;
4045 0           $croaker = \&error_handler_wrapper;
4046             }
4047             else
4048             {
4049 0           $warning_handler = $warning_handler_data = undef;
4050 0           $error_handler_data = $warning_handler_data = undef;
4051 0     0     $carper = sub { return; };
  0            
4052 0           $croaker = \&croak;
4053             }
4054             }
4055             else
4056             {
4057 0           &$croaker("Unknown error handler severity");
4058             }
4059              
4060 0           return;
4061              
4062             }
4063             #
4064             ##############################################################################
4065             #
4066             # Routine - register_io_wait_handler
4067             #
4068             # Description - Register the specified routine as an I/O wait handler for
4069             # this class. This is both a class as well as an object
4070             # method. When used as a class method, the specified I/O wait
4071             # handler is used as the default handler for all those
4072             # objects that do not specify their own handlers.
4073             #
4074             # Data - $self : Either the object, the package name or not
4075             # present depending upon how this method is
4076             # called.
4077             # $handler : A reference to the I/O wait handler routine.
4078             # If this is not provided then the existing
4079             # I/O wait handler routine is unregistered.
4080             # $timeout : The timeout, in seconds, that this class
4081             # should wait for input before calling the I/O
4082             # wait handler.
4083             # $client_data : The client data that is to be passed to the
4084             # registered I/O wait handler when it is
4085             # called.
4086             #
4087             ##############################################################################
4088              
4089              
4090              
4091             sub register_io_wait_handler(;$$$$)
4092             {
4093              
4094 0     0 1   my ($self,
4095             $this);
4096 0 0         if ($_[0]->isa(__PACKAGE__))
4097             {
4098 0 0         if (ref($_[0]) ne "")
4099             {
4100 0           $self = shift();
4101 0           $this = $class_records{$self->{$class_name}};
4102             }
4103             else
4104             {
4105 0           shift();
4106             }
4107             }
4108 0           my ($handler, $timeout, $client_data) = @_;
4109              
4110 0 0         if (defined($timeout))
4111             {
4112 0 0 0       if ($timeout !~ m/^\d*\.{0,1}\d+$/ || $timeout < 0 || $timeout > 20)
      0        
4113             {
4114 0           my $msg =
4115             "I/O wait handler timeout invalid or out of range, resetting";
4116 0 0         $this->{error_msg} = $msg if (defined($this));
4117 0           &$carper($msg);
4118 0           $timeout = 1;
4119             }
4120             }
4121             else
4122             {
4123 0           $timeout = 1;
4124             }
4125              
4126 0 0         if (defined($self))
4127             {
4128 0 0         if (defined($handler))
4129             {
4130 0           $this->{io_wait_handler} = $handler;
4131 0           $this->{io_wait_handler_data} = $client_data;
4132 0           $this->{io_wait_handler_timeout} = $timeout;
4133             }
4134             else
4135             {
4136 0           $this->{io_wait_handler} = $this->{io_wait_handler_data} = undef;
4137             }
4138             }
4139             else
4140             {
4141 0 0         if (defined($handler))
4142             {
4143 0           $io_wait_handler = $handler;
4144 0           $io_wait_handler_data = $client_data;
4145 0           $io_wait_handler_timeout = $timeout;
4146             }
4147             else
4148             {
4149 0           $io_wait_handler = $io_wait_handler_data = undef;
4150             }
4151             }
4152              
4153 0           return;
4154              
4155             }
4156             #
4157             ##############################################################################
4158             #
4159             # Routine - register_stream_handle
4160             #
4161             # Description - Register the specified file handle to receive data from the
4162             # specified mtn automate stdio output stream.
4163             #
4164             # Data - $self : The object.
4165             # $stream : The mtn output stream from which data is to be
4166             # read and then written to the specified file
4167             # handle.
4168             # $handle : The file handle that is to receive the data from
4169             # the specified output stream. If this is not
4170             # provided then any existing file handle for that
4171             # stream is unregistered.
4172             #
4173             ##############################################################################
4174              
4175              
4176              
4177             sub register_stream_handle($$$)
4178             {
4179              
4180 0     0 1   my ($self, $stream, $handle) = @_;
4181              
4182 0           my $this = $class_records{$self->{$class_name}};
4183              
4184 0 0 0       if (defined($handle) && ref($handle) !~ m/^IO::[^:]+/
      0        
      0        
4185             && ref($handle) ne "GLOB" && ref(\$handle) ne "GLOB")
4186             {
4187 0           &$croaker("Handle must be either undef or a valid handle");
4188             }
4189 0           autoflush($stream, 1);
4190 0 0         if ($stream == MTN_P_STREAM)
    0          
4191             {
4192 0           $this->{p_stream_handle} = $handle;
4193             }
4194             elsif ($stream == MTN_T_STREAM)
4195             {
4196 0           $this->{t_stream_handle} = $handle;
4197             }
4198             else
4199             {
4200 0           &$croaker("Unknown stream specified");
4201             }
4202              
4203 0           return;
4204              
4205             }
4206             #
4207             ##############################################################################
4208             #
4209             # Routine - supports
4210             #
4211             # Description - Determine whether a certain feature is available with the
4212             # version of Monotone that is currently being used.
4213             #
4214             # Data - $self : The object.
4215             # $feature : A constant specifying the feature that is
4216             # to be checked for.
4217             # Return Value : True if the feature is supported, otherwise
4218             # false if it is not.
4219             #
4220             ##############################################################################
4221              
4222              
4223              
4224             sub supports($$)
4225             {
4226              
4227 0     0 1   my ($self, $feature) = @_;
4228              
4229 0           my $this = $class_records{$self->{$class_name}};
4230              
4231 0 0 0       if ($feature == MTN_DROP_ATTRIBUTE
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
4232             || $feature == MTN_GET_ATTRIBUTES
4233             || $feature == MTN_SET_ATTRIBUTE)
4234             {
4235              
4236             # These are only available from version 0.36 (i/f version 5.x).
4237              
4238 0 0         return 1 if ($this->{mtn_aif_version} >= 5);
4239              
4240             }
4241             elsif ($feature == MTN_IGNORING_OF_SUSPEND_CERTS
4242             || $feature == MTN_INVENTORY_IN_IO_STANZA_FORMAT
4243             || $feature == MTN_P_SELECTOR)
4244             {
4245              
4246             # These are only available from version 0.37 (i/f version 6.x).
4247              
4248 0 0         return 1 if ($this->{mtn_aif_version} >= 6);
4249              
4250             }
4251             elsif ($feature == MTN_DROP_DB_VARIABLES
4252             || $feature == MTN_GET_CURRENT_REVISION
4253             || $feature == MTN_GET_DB_VARIABLES
4254             || $feature == MTN_INVENTORY_TAKING_OPTIONS
4255             || $feature == MTN_SET_DB_VARIABLE)
4256             {
4257              
4258             # These are only available from version 0.39 (i/f version 7.x).
4259              
4260 0 0         return 1 if ($this->{mtn_aif_version} >= 7);
4261              
4262             }
4263             elsif ($feature == MTN_DB_GET)
4264             {
4265              
4266             # This is only available prior version 0.39 (i/f version 7.x).
4267              
4268 0 0         return 1 if ($this->{mtn_aif_version} < 7);
4269              
4270             }
4271             elsif ($feature == MTN_GET_WORKSPACE_ROOT
4272             || $feature == MTN_INVENTORY_WITH_BIRTH_ID
4273             || $feature == MTN_SHOW_CONFLICTS)
4274             {
4275              
4276             # These are only available from version 0.41 (i/f version 8.x).
4277              
4278 0 0         return 1 if ($this->{mtn_aif_version} >= 8);
4279              
4280             }
4281             elsif ($feature == MTN_CONTENT_DIFF_EXTRA_OPTIONS
4282             || $feature == MTN_FILE_MERGE
4283             || $feature == MTN_LUA
4284             || $feature == MTN_READ_PACKETS)
4285             {
4286              
4287             # These are only available from version 0.42 (i/f version 9.x).
4288              
4289 0 0         return 1 if ($this->{mtn_aif_version} >= 9);
4290              
4291             }
4292             elsif ($feature == MTN_M_SELECTOR || $feature == MTN_U_SELECTOR)
4293             {
4294              
4295             # These are only available from version 0.43 (i/f version 9.x).
4296              
4297             return 1 if ($this->{mtn_aif_version} >= 10
4298 0 0 0       || (int($this->{mtn_aif_version}) == 9
      0        
4299             && $mtn_version == 0.43));
4300              
4301             }
4302             elsif ($feature == MTN_COMMON_KEY_HASH || $feature == MTN_W_SELECTOR)
4303             {
4304              
4305             # These are only available from version 0.44 (i/f version 10.x).
4306              
4307 0 0         return 1 if ($this->{mtn_aif_version} >= 10);
4308              
4309             }
4310             elsif ($feature == MTN_HASHED_SIGNATURES)
4311             {
4312              
4313             # This is only available from version 0.45 (i/f version 11.x).
4314              
4315 0 0         return 1 if ($this->{mtn_aif_version} >= 11);
4316              
4317             }
4318             elsif ($feature == MTN_REMOTE_CONNECTIONS
4319             || $feature == MTN_STREAM_IO
4320             || $feature == MTN_SYNCHRONISATION)
4321             {
4322              
4323             # These are only available from version 0.46 (i/f version 12.x).
4324              
4325 0 0         return 1 if ($this->{mtn_aif_version} >= 12);
4326              
4327             }
4328             elsif ($feature == MTN_UPDATE)
4329             {
4330              
4331             # This is only available from version 0.48 (i/f version 12.1).
4332              
4333 0 0         return 1 if ($this->{mtn_aif_version} >= 12.1);
4334              
4335             }
4336             elsif ($feature == MTN_LOG)
4337             {
4338              
4339             # This is only available from version 0.99 (i/f version 12.2).
4340              
4341 0 0         return 1 if ($this->{mtn_aif_version} >= 12.2);
4342              
4343             }
4344             elsif ($feature == MTN_CHECKOUT
4345             || $feature == MTN_DROP_PUBLIC_KEY
4346             || $feature == MTN_GENERATE_KEY
4347             || $feature == MTN_GET_EXTENDED_MANIFEST_OF
4348             || $feature == MTN_GET_FILE_SIZE
4349             || $feature == MTN_GET_PUBLIC_KEY
4350             || $feature == MTN_K_SELECTOR
4351             || $feature == MTN_PUT_PUBLIC_KEY
4352             || $feature == MTN_SELECTOR_FUNCTIONS
4353             || $feature == MTN_SELECTOR_OR_OPERATOR
4354             || $feature == MTN_SYNCHRONISATION_WITH_OUTPUT)
4355             {
4356              
4357             # These are only available from version 0.99.1 (i/f version 13.x).
4358              
4359 0 0         return 1 if ($this->{mtn_aif_version} >= 13);
4360              
4361             }
4362             elsif ($feature == MTN_ERASE_DESCENDANTS
4363             || $feature == MTN_GET_ATTRIBUTES_TAKING_OPTIONS
4364             || $feature == MTN_SELECTOR_MIN_FUNCTION
4365             || $feature == MTN_SELECTOR_NOT_FUNCTION)
4366             {
4367              
4368             # These are only available from version 1.10 (i/f version 13.1).
4369              
4370 0 0         return 1 if ($this->{mtn_aif_version} >= 13.1);
4371              
4372             }
4373             else
4374             {
4375 0           &$croaker("Unknown feature requested");
4376             }
4377              
4378 0           return;
4379              
4380             }
4381             #
4382             ##############################################################################
4383             #
4384             # Routine - suppress_utf8_conversion
4385             #
4386             # Description - Controls whether UTF-8 conversion should be done on the
4387             # data sent to and from the mtn subprocess by this class.
4388             # This is both a class as well as an object method. When used
4389             # as a class method, the specified setting is used as the
4390             # default for all those objects that do not specify their own
4391             # setting. The default setting is to perform UTF-8
4392             # conversion.
4393             #
4394             # Data - $self : Either the object, the package name or not
4395             # present depending upon how this method is
4396             # called.
4397             # $suppress : True if UTF-8 conversion is not to be done,
4398             # otherwise false if it is.
4399             #
4400             ##############################################################################
4401              
4402              
4403              
4404             sub suppress_utf8_conversion($$)
4405             {
4406              
4407 0     0 1   my ($self,
4408             $this);
4409 0 0         if ($_[0]->isa(__PACKAGE__))
4410             {
4411 0 0         if (ref($_[0]) ne "")
4412             {
4413 0           $self = shift();
4414 0           $this = $class_records{$self->{$class_name}};
4415             }
4416             else
4417             {
4418 0           shift();
4419             }
4420             }
4421 0           my $suppress = $_[0];
4422              
4423 0 0         if (defined($self))
4424             {
4425 0 0         $this->{convert_to_utf8} = $suppress ? undef : 1;
4426             }
4427             else
4428             {
4429 0 0         $convert_to_utf8 = $suppress ? undef : 1;
4430             }
4431              
4432 0           return;
4433              
4434             }
4435             #
4436             ##############################################################################
4437             #
4438             # Routine - switch_to_ws_root
4439             #
4440             # Description - Control whether this class automatically switches to a
4441             # workspace's root directory before running the mtn
4442             # subprocess. The default action is to do so as this is
4443             # generally safer.
4444             #
4445             # Data - $self : The object.
4446             # $switch : True if the mtn subprocess should be started
4447             # in a workspace's root directory, otherwise
4448             # false if it should be started in the current
4449             # working directory.
4450             # Return Value : True on success, otherwise false on failure.
4451             #
4452             ##############################################################################
4453              
4454              
4455              
4456             sub switch_to_ws_root($$)
4457             {
4458              
4459 0     0 1   my ($self,
4460             $this);
4461 0 0         if ($_[0]->isa(__PACKAGE__))
4462             {
4463 0 0         if (ref($_[0]) ne "")
4464             {
4465 0           $self = shift();
4466 0           $this = $class_records{$self->{$class_name}};
4467             }
4468             else
4469             {
4470 0           shift();
4471             }
4472             }
4473 0           my $switch = $_[0];
4474              
4475 0 0         if (defined($self))
4476             {
4477 0 0         if (! $this->{ws_constructed})
4478             {
4479 0 0 0       if ($this->{cd_to_ws_root} && ! $switch)
    0 0        
4480             {
4481 0           $this->{cd_to_ws_root} = undef;
4482 0           $self->closedown();
4483 0           $self->startup();
4484             }
4485             elsif (! $this->{cd_to_ws_root} && $switch)
4486             {
4487 0           $this->{cd_to_ws_root} = 1;
4488 0           $self->closedown();
4489 0           $self->startup();
4490             }
4491             }
4492             else
4493             {
4494             $this->{error_msg} =
4495 0           "Cannot call Monotone::AutomateStdio->switch_to_ws_root() on "
4496             . "objects constructed with new_from_ws()";
4497 0           &$carper($this->{error_msg});
4498 0           return;
4499             }
4500             }
4501             else
4502             {
4503 0 0         $cd_to_ws_root = $switch ? 1 : undef;
4504             }
4505              
4506 0           return 1;
4507              
4508             }
4509             #
4510             ##############################################################################
4511             #
4512             # Routine - parse_revision_data
4513             #
4514             # Description - Parse the specified revision data into a list of records.
4515             #
4516             # Data - $list : A reference to a list that is to contain the
4517             # records.
4518             # $data : A reference to a list containing the revision data,
4519             # line by line.
4520             #
4521             ##############################################################################
4522              
4523              
4524              
4525             sub parse_revision_data($$)
4526             {
4527              
4528 0     0 0   my ($list, $data) = @_;
4529              
4530 0           my $i;
4531              
4532             # Reformat the data into a structured array.
4533              
4534 0           for ($i = 0, @$list = (); $i < scalar(@$data); ++ $i)
4535             {
4536 0 0         if ($$data[$i] =~ m/$io_stanza_re/)
4537             {
4538 0           my $kv_record;
4539              
4540             # Get the next key-value record.
4541              
4542 0           parse_kv_record($data, \$i, \%revision_details_keys, \$kv_record);
4543 0           -- $i;
4544              
4545             # Validate it in terms of expected fields and copy data across to
4546             # the correct revision fields.
4547              
4548 0 0         if (exists($kv_record->{add_dir}))
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4549             {
4550             push(@$list, {type => "add_dir",
4551 0           name => $kv_record->{add_dir}});
4552             }
4553             elsif (exists($kv_record->{add_file}))
4554             {
4555             &$croaker("Corrupt revision, expected content field but "
4556             . "did not find it")
4557 0 0         unless (exists($kv_record->{content}));
4558             push(@$list, {type => "add_file",
4559             name => $kv_record->{add_file},
4560 0           file_id => $kv_record->{content}});
4561             }
4562             elsif (exists($kv_record->{clear}))
4563             {
4564             &$croaker("Corrupt revision, expected attr field but did not "
4565             . "find it")
4566 0 0         unless (exists($kv_record->{attr}));
4567             push(@$list, {type => "clear",
4568             name => $kv_record->{clear},
4569 0           attribute => $kv_record->{attr}});
4570             }
4571             elsif (exists($kv_record->{delete}))
4572             {
4573             push(@$list, {type => "delete",
4574 0           name => $kv_record->{delete}});
4575             }
4576             elsif (exists($kv_record->{new_manifest}))
4577             {
4578             push(@$list, {type => "new_manifest",
4579 0           manifest_id => $kv_record->{new_manifest}});
4580             }
4581             elsif (exists($kv_record->{old_revision}))
4582             {
4583             push(@$list, {type => "old_revision",
4584 0           revision_id => $kv_record->{old_revision}});
4585             }
4586             elsif (exists($kv_record->{patch}))
4587             {
4588             &$croaker("Corrupt revision, expected from field but did not "
4589             . "find it")
4590 0 0         unless (exists($kv_record->{from}));
4591             &$croaker("Corrupt revision, expected to field but did not "
4592             . "find it")
4593 0 0         unless (exists($kv_record->{to}));
4594             push(@$list, {type => "patch",
4595             name => $kv_record->{patch},
4596             from_file_id => $kv_record->{from},
4597 0           to_file_id => $kv_record->{to}});
4598             }
4599             elsif (exists($kv_record->{rename}))
4600             {
4601             &$croaker("Corrupt revision, expected to field but did not "
4602             . "find it")
4603 0 0         unless (exists($kv_record->{to}));
4604             push(@$list, {type => "rename",
4605             from_name => $kv_record->{rename},
4606 0           to_name => $kv_record->{to}});
4607             }
4608             elsif (exists($kv_record->{set}))
4609             {
4610             &$croaker("Corrupt revision, expected attr field but did not "
4611             . "find it")
4612 0 0         unless (exists($kv_record->{attr}));
4613             &$croaker("Corrupt revision, expected value field but did not "
4614             . "find it")
4615 0 0         unless (exists($kv_record->{value}));
4616             push(@$list, {type => "set",
4617             name => $kv_record->{set},
4618             attribute => $kv_record->{attr},
4619 0           value => $kv_record->{value}});
4620             }
4621             }
4622             }
4623              
4624             }
4625             #
4626             ##############################################################################
4627             #
4628             # Routine - parse_kv_record
4629             #
4630             # Description - Parse the specified data for a key-value style record, with
4631             # each record being separated by a white space line,
4632             # returning the extracted record.
4633             #
4634             # Data - $list : A reference to the list that contains the
4635             # data.
4636             # $index : A reference to a variable containing the
4637             # index of the first line of the record in
4638             # the array. It is updated with the index of
4639             # the first line after the record.
4640             # $key_type_map : A reference to the key type map, this is a
4641             # map indexed by key name and has an
4642             # enumeration as its value that describes the
4643             # type of value that is to be read in.
4644             # $record : A reference to a variable that is to be
4645             # updated with the reference to the newly
4646             # created record.
4647             # $no_errors : True if this routine should not report
4648             # errors relating to unknown fields,
4649             # otherwise undef if these errors are to be
4650             # reported. This is optional.
4651             #
4652             ##############################################################################
4653              
4654              
4655              
4656             sub parse_kv_record($$$$;$)
4657             {
4658              
4659 0     0 0   my ($list, $index, $key_type_map, $record, $no_errors) = @_;
4660              
4661 0           my ($i,
4662             $key,
4663             $type,
4664             $value);
4665              
4666             # Process a line at a time whilst we are looking at an IO stanza record.
4667              
4668 0   0       for ($i = $$index, $$record = {};
4669             $i < scalar(@$list) && $$list[$i] =~ m/$io_stanza_re/;
4670             ++ $i)
4671             {
4672              
4673             # Look up the key with respect to its formatting.
4674              
4675 0           $key = $1;
4676 0 0         if (exists($$key_type_map{$key}))
4677             {
4678 0           $type = $$key_type_map{$key};
4679 0           $value = undef;
4680              
4681             # Extract the key's value.
4682              
4683 0 0 0       if ($type & BARE_PHRASE && $$list[$i] =~ m/^ *[a-z_]+ ([a-z_]+)$/)
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
4684             {
4685 0           $value = $1;
4686             }
4687             elsif ($type & HEX_ID
4688             && $$list[$i] =~ m/^ *[a-z_]+ \[([0-9a-f]+)\]$/)
4689             {
4690 0           $value = $1;
4691             }
4692             elsif ($type & OPTIONAL_HEX_ID
4693             && $$list[$i] =~ m/^ *[a-z_]+ \[([0-9a-f]*)\]$/)
4694             {
4695 0           $value = $1;
4696             }
4697             elsif ($type & STRING && $$list[$i] =~ m/^ *[a-z_]+ \"/)
4698             {
4699 0           get_quoted_value($list, \$i, 0, \$value);
4700 0           $value = unescape($value);
4701             }
4702             elsif ($type & STRING_AND_HEX_ID
4703             && $$list[$i] =~ m/^ *[a-z_]+ \"(.*)\" \[([0-9a-f]+)\]$/)
4704             {
4705 0           $value = [unescape($1), $2];
4706             }
4707             elsif ($type & STRING_ENUM
4708             && $$list[$i] =~ m/^ *[a-z_]+ \"([^\"]+)\"$/)
4709             {
4710 0           $value = $1;
4711             }
4712             elsif ($type & STRING_KEY_VALUE
4713             && $$list[$i] =~ m/^ *[a-z_]+ \"([^\"]+)\" (\".*)$/)
4714             {
4715 0           my $string;
4716 0           $value = [$1];
4717 0           get_quoted_value($list, \$i, $-[2], \$string);
4718 0           push(@$value, unescape($string));
4719             }
4720             elsif ($type & STRING_LIST
4721             && $$list[$i] =~ m/^ *[a-z_]+ \"(.+)\"$/)
4722             {
4723 0           $value = [];
4724 0           foreach my $string (split(/\" \"/, $1))
4725             {
4726 0           push(@$value, unescape($string));
4727             }
4728             }
4729             elsif ($type & NULL && $$list[$i] =~ m/^ *[a-z_]+ ?$/)
4730             {
4731             }
4732             else
4733             {
4734 0           &$croaker("Unsupported key type or corrupt field value "
4735             . "detected");
4736             }
4737              
4738             # Store the value in the record. If its non-unique then store the
4739             # values in a list, otherwise just store it normally.
4740              
4741 0 0         if ($type & NON_UNIQUE)
4742             {
4743 0 0         if (exists($$record->{$key}))
4744             {
4745 0           push(@{$$record->{$key}}, $value);
  0            
4746             }
4747             else
4748             {
4749 0           $$record->{$key} = [$value];
4750             }
4751             }
4752             else
4753             {
4754 0           $$record->{$key} = $value;
4755             }
4756             }
4757             else
4758             {
4759 0 0         &$croaker("Unrecognised field " . $key . " found")
4760             unless ($no_errors);
4761             }
4762              
4763             }
4764 0           $$index = $i;
4765              
4766             }
4767             #
4768             ##############################################################################
4769             #
4770             # Routine - mtn_command
4771             #
4772             # Description - Handle mtn commands that take no options and zero or more
4773             # arguments. Depending upon what type of reference is passed,
4774             # data is either returned in one large lump (scalar
4775             # reference), or an array of lines (array reference).
4776             #
4777             # Data - $self : The object.
4778             # $cmd : The mtn automate command that is to be run.
4779             # $out_as_utf8 : True if any data output to mtn should be
4780             # converted into raw UTF-8, otherwise false if
4781             # the data should be treated as binary. If
4782             # UTF-8 conversion has been disabled by a call
4783             # to the suppress_utf8_conversion() method
4784             # then this argument is ignored.
4785             # $in_as_utf8 : True if any data input from mtn should be
4786             # converted into Perl's internal UTF-8 string
4787             # format, otherwise false if the data should
4788             # be treated as binary. If UTF-8 conversion
4789             # has been disabled by a call to the
4790             # suppress_utf8_conversion() method then this
4791             # argument is ignored.
4792             # $ref : A reference to a buffer or an array that is
4793             # to contain the output from this command.
4794             # @parameters : A list of parameters to be applied to the
4795             # command.
4796             # Return Value : True on success, otherwise false on failure.
4797             #
4798             ##############################################################################
4799              
4800              
4801              
4802             sub mtn_command($$$$$;@)
4803             {
4804              
4805 0     0 0   my ($self, $cmd, $out_as_utf8, $in_as_utf8, $ref, @parameters) = @_;
4806              
4807 0           return $self->mtn_command_with_options($cmd,
4808             $out_as_utf8,
4809             $in_as_utf8,
4810             $ref,
4811             [],
4812             @parameters);
4813              
4814             }
4815             #
4816             ##############################################################################
4817             #
4818             # Routine - mtn_command_with_options
4819             #
4820             # Description - Handle mtn commands that take options and zero or more
4821             # arguments. Depending upon what type of reference is passed,
4822             # data is either returned in one large lump (scalar
4823             # reference), or an array of lines (array reference).
4824             #
4825             # Data - $self : The object.
4826             # $cmd : The mtn automate command that is to be run.
4827             # $out_as_utf8 : True if any data output to mtn should be
4828             # converted into raw UTF-8, otherwise false if
4829             # the data should be treated as binary. If
4830             # UTF-8 conversion has been disabled by a call
4831             # to the suppress_utf8_conversion() method
4832             # then this argument is ignored.
4833             # $in_as_utf8 : True if any data input from mtn should be
4834             # converted into Perl's internal UTF-8 string
4835             # format, otherwise false if the data should
4836             # be treated as binary. If UTF-8 conversion
4837             # has been disabled by a call to the
4838             # suppress_utf8_conversion() method then this
4839             # argument is ignored.
4840             # $ref : A reference to a buffer or an array that is
4841             # to contain the output from this command.
4842             # $options : A reference to a list containing key/value
4843             # anonymous hashes.
4844             # @parameters : A list of parameters to be applied to the
4845             # command.
4846             # Return Value : True on success, otherwise false on failure.
4847             #
4848             ##############################################################################
4849              
4850              
4851              
4852             sub mtn_command_with_options($$$$$$;@)
4853             {
4854              
4855 0     0 0   my ($self, $cmd, $out_as_utf8, $in_as_utf8, $ref, $options, @parameters)
4856             = @_;
4857              
4858 0           my ($buffer,
4859             $buffer_ref,
4860             $db_locked_exception,
4861             $handler,
4862             $handler_data,
4863             $opt,
4864             $param,
4865             $read_ok,
4866             $retry);
4867 0           my $this = $class_records{$self->{$class_name}};
4868              
4869             # Work out whether UTF-8 conversion is to be done at all.
4870              
4871 0 0         $out_as_utf8 = $in_as_utf8 = undef unless ($this->{convert_to_utf8});
4872              
4873             # Work out what database locked handler is to be used.
4874              
4875 0 0         if (defined($this->{db_locked_handler}))
4876             {
4877 0           $handler = $this->{db_locked_handler};
4878 0           $handler_data = $this->{db_locked_handler_data};
4879             }
4880             else
4881             {
4882 0           $handler = $db_locked_handler;
4883 0           $handler_data = $db_locked_handler_data;
4884             }
4885              
4886             # If the output is to be returned as an array of lines as against one lump
4887             # then we need to read the output into a temporary buffer before breaking
4888             # it up into lines.
4889              
4890 0 0         if (ref($ref) eq "SCALAR")
    0          
4891             {
4892 0           $buffer_ref = $ref;
4893             }
4894             elsif (ref($ref) eq "ARRAY")
4895             {
4896 0           $buffer_ref = \$buffer;
4897             }
4898             else
4899             {
4900 0           &$croaker("Expected a reference to a scalar or an array");
4901             }
4902              
4903             # Send the command, reading its output, repeating if necessary if retries
4904             # should be attempted when the database is locked.
4905              
4906             do
4907 0           {
4908              
4909             # Startup the subordinate mtn process if it hasn't already been
4910             # started.
4911              
4912 0 0         $self->startup() if ($this->{mtn_pid} == 0);
4913              
4914             # Send the command.
4915              
4916 0 0         if (scalar(@$options) > 0)
4917             {
4918 0           $this->{mtn_in}->print("o");
4919 0           foreach $opt (@$options)
4920             {
4921 0           my ($key,
4922             $key_ref,
4923             $value,
4924             $value_ref);
4925 0 0         if ($out_as_utf8)
4926             {
4927 0           $key = encode_utf8($opt->{key});
4928 0           $value = encode_utf8($opt->{value});
4929 0           $key_ref = \$key;
4930 0           $value_ref = \$value;
4931             }
4932             else
4933             {
4934 0           $key_ref = \$opt->{key};
4935 0           $value_ref = \$opt->{value};
4936             }
4937 0           $this->{mtn_in}->printf("%d:%s%d:%s",
4938             length($$key_ref),
4939             $$key_ref,
4940             length($$value_ref),
4941             $$value_ref);
4942             }
4943 0           $this->{mtn_in}->print("e ");
4944             }
4945 0           $this->{mtn_in}->printf("l%d:%s", length($cmd), $cmd);
4946 0           foreach $param (@parameters)
4947             {
4948              
4949             # Cater for passing by reference (useful when sending large lumps
4950             # of data as in put_file). Also defend against undef being passed
4951             # as the only parameter (which can happen when a mandatory argument
4952             # is not passed by the caller).
4953              
4954 0 0         if (defined $param)
4955             {
4956 0           my ($data,
4957             $param_ref);
4958 0 0         if (ref($param) ne "")
4959             {
4960 0 0         if ($out_as_utf8)
4961             {
4962 0           $data = encode_utf8($$param);
4963 0           $param_ref = \$data;
4964             }
4965             else
4966             {
4967 0           $param_ref = $param;
4968             }
4969             }
4970             else
4971             {
4972 0 0         if ($out_as_utf8)
4973             {
4974 0           $data = encode_utf8($param);
4975 0           $param_ref = \$data;
4976             }
4977             else
4978             {
4979 0           $param_ref = \$param;
4980             }
4981             }
4982 0           $this->{mtn_in}->printf("%d:%s",
4983             length($$param_ref),
4984             $$param_ref);
4985             }
4986              
4987             }
4988 0           $this->{mtn_in}->print("e\n");
4989 0           $this->{mtn_in}->flush();
4990              
4991             # Attempt to read the output of the command, rethrowing any exception
4992             # that does not relate to locked databases.
4993              
4994 0           $db_locked_exception = $read_ok = $retry = undef;
4995             eval
4996 0           {
4997 0           $read_ok = $self->mtn_read_output($buffer_ref);
4998             };
4999 0 0         if ($@)
5000             {
5001 0 0         if ($@ =~ m/$database_locked_re/)
5002             {
5003              
5004             # We need to properly closedown the mtn subprocess at this
5005             # point because we are quietly handling the exception that
5006             # caused it to exit but the calling application may reap the
5007             # process and compare the reaped PID with the return value from
5008             # the get_pid() method. At least by calling closedown() here
5009             # get_pid() will return 0 and the caller can then distinguish
5010             # between a handled exit and one that should be dealt with.
5011              
5012 0           $self->closedown();
5013 0           $db_locked_exception = 1;
5014              
5015             }
5016             else
5017             {
5018 0           &$croaker($@);
5019             }
5020             }
5021              
5022             # If the data was read in ok then carry out any necessary character set
5023             # conversions. Otherwise deal with locked database exceptions and any
5024             # warning messages that appeared in the output.
5025              
5026 0 0 0       if ($read_ok && $in_as_utf8)
    0          
5027             {
5028 0           local $@;
5029             eval
5030 0           {
5031 0           $$buffer_ref = decode_utf8($$buffer_ref, Encode::FB_CROAK);
5032             };
5033             }
5034             elsif (! $read_ok)
5035             {
5036              
5037             # See if we are to retry on database locked conditions.
5038              
5039 0 0 0       if ($db_locked_exception
5040             || $this->{error_msg} =~ m/$database_locked_re/)
5041             {
5042 0           $this->{db_is_locked} = 1;
5043 0           $retry = &$handler($self, $handler_data);
5044             }
5045              
5046             # If we are to retry then close down the subordinate mtn process,
5047             # otherwise report the error to the caller.
5048              
5049 0 0         if ($retry)
5050             {
5051 0           $self->closedown();
5052             }
5053             else
5054             {
5055 0           &$carper($this->{error_msg});
5056 0           return;
5057             }
5058              
5059             }
5060              
5061             }
5062             while ($retry);
5063              
5064             # Split the output up into lines if that is what is required.
5065              
5066 0 0         @$ref = split(/\n/, $$buffer_ref) if (ref($ref) eq "ARRAY");
5067              
5068             # Empty out any data on mtn's STDERR file descriptor. This should always be
5069             # empty unless it exits in error, which is picked up elsewhere. However if
5070             # a misbehaving mtn subprocess is outputting text on STDERR but not exiting
5071             # then there is a possibility that the STDERR pipe will fill up causing mtn
5072             # to block. Remember that anything wrong with a command that does not cause
5073             # mtn to exit should be reported in the error stream on STDOUT, so we can
5074             # just discard any STDERR data read here.
5075              
5076 0           while ($this->{poll_err}->poll(0) > 0)
5077             {
5078 0           my $dummy;
5079 0 0         if (! $this->{mtn_err}->sysread($dummy, 1024))
5080             {
5081 0           last;
5082             }
5083             }
5084              
5085 0           return 1;
5086              
5087             }
5088             #
5089             ##############################################################################
5090             #
5091             # Routine - mtn_read_output_format_1
5092             #
5093             # Description - Reads the output from mtn as format 1, removing chunk
5094             # headers.
5095             #
5096             # Data - $self : The object.
5097             # $buffer : A reference to the buffer that is to contain
5098             # the data.
5099             # Return Value : True on success, otherwise false on failure.
5100             #
5101             ##############################################################################
5102              
5103              
5104              
5105             sub mtn_read_output_format_1($$)
5106             {
5107              
5108 0     0 0   my ($self, $buffer) = @_;
5109              
5110 0           my ($bytes_read,
5111             $char,
5112             $chunk_start,
5113             $cmd_nr,
5114             $colons,
5115             $err_code,
5116             $err_occurred,
5117             $handler,
5118             $handler_data,
5119             $handler_timeout,
5120             $header,
5121             $i,
5122             $last,
5123             $offset,
5124             $size);
5125 0           my $this = $class_records{$self->{$class_name}};
5126              
5127             # Work out what I/O wait handler is to be used.
5128              
5129 0 0         if (defined($this->{io_wait_handler}))
5130             {
5131 0           $handler = $this->{io_wait_handler};
5132 0           $handler_data = $this->{io_wait_handler_data};
5133 0           $handler_timeout = $this->{io_wait_handler_timeout};
5134             }
5135             else
5136             {
5137 0           $handler = $io_wait_handler;
5138 0           $handler_data = $io_wait_handler_data;
5139 0           $handler_timeout = $io_wait_handler_timeout;
5140             }
5141              
5142             # Read in the data.
5143              
5144 0           $$buffer = "";
5145 0           $chunk_start = 1;
5146 0           $last = "m";
5147 0           $offset = 0;
5148             do
5149 0   0       {
5150              
5151             # Wait here for some data, calling the I/O wait handler every second
5152             # whilst we wait.
5153              
5154 0           while ($this->{poll_out}->poll($handler_timeout) == 0)
5155             {
5156 0           &$handler($self, $handler_data);
5157             }
5158              
5159             # If necessary, read in and process the chunk header, then we know how
5160             # much to read in.
5161              
5162 0 0         if ($chunk_start)
5163             {
5164              
5165             # Read header, one byte at a time until we have what we need or
5166             # there is an error.
5167              
5168 0   0       for ($header = "", $colons = $i = 0;
5169             $colons < 4 && $this->{mtn_out}->sysread($header, 1, $i);
5170             ++ $i)
5171             {
5172 0           $char = substr($header, $i, 1);
5173 0 0         if ($char eq ":")
    0          
    0          
5174             {
5175 0           ++ $colons;
5176             }
5177             elsif ($colons == 2)
5178             {
5179 0 0 0       if ($char ne "m" && $char ne "l")
5180             {
5181             croak("Corrupt/missing mtn chunk header, mtn gave:\n"
5182 0           . join("", $this->{mtn_err}->getlines()));
5183             }
5184             }
5185             elsif ($char =~ m/\D$/)
5186             {
5187             croak("Corrupt/missing mtn chunk header, mtn gave:\n"
5188 0           . join("", $this->{mtn_err}->getlines()));
5189             }
5190             }
5191              
5192             # Break out the header into its separate fields.
5193              
5194 0 0         if ($header =~ m/^(\d+):(\d+):([lm]):(\d+):$/)
5195             {
5196 0           ($cmd_nr, $err_code, $last, $size) = ($1, $2, $3, $4);
5197 0 0         if ($cmd_nr != $this->{cmd_cnt})
5198             {
5199 0           croak("Mtn command count is out of sequence");
5200             }
5201 0 0         if ($err_code != 0)
5202             {
5203 0           $err_occurred = 1;
5204             }
5205             }
5206             else
5207             {
5208             croak("Corrupt/missing mtn chunk header, mtn gave:\n"
5209 0           . join("", $this->{mtn_err}->getlines()));
5210             }
5211              
5212 0           $chunk_start = undef;
5213              
5214             }
5215              
5216             # Read in what we require.
5217              
5218 0 0         if ($size > 0)
5219             {
5220 0 0         if (! defined($bytes_read = $this->{mtn_out}->sysread($$buffer,
    0          
5221             $size,
5222             $offset)))
5223             {
5224 0           croak("sysread failed: " . $!);
5225             }
5226             elsif ($bytes_read == 0)
5227             {
5228 0           croak("Short data read");
5229             }
5230 0           $size -= $bytes_read;
5231 0           $offset += $bytes_read;
5232             }
5233 0 0 0       if ($size == 0 && $last eq "m")
5234             {
5235 0           $chunk_start = 1;
5236             }
5237              
5238             }
5239             while ($size > 0 || $last eq "m");
5240              
5241 0           ++ $this->{cmd_cnt};
5242              
5243             # Deal with errors (message is in $$buffer).
5244              
5245 0 0         if ($err_occurred)
5246             {
5247 0           $this->{error_msg} = $$buffer;
5248 0           $$buffer = "";
5249 0           return;
5250             }
5251              
5252 0           return 1;
5253              
5254             }
5255             #
5256             ##############################################################################
5257             #
5258             # Routine - mtn_read_output_format_2
5259             #
5260             # Description - Reads the output from mtn as format 2, removing chunk
5261             # headers.
5262             #
5263             # Data - $self : The object.
5264             # $buffer : A reference to the buffer that is to contain
5265             # the data.
5266             # Return Value : True on success, otherwise false on failure.
5267             #
5268             ##############################################################################
5269              
5270              
5271              
5272             sub mtn_read_output_format_2($$)
5273             {
5274              
5275 0     0 0   my ($self, $buffer) = @_;
5276              
5277 0           my ($bytes_read,
5278             $buffer_ref,
5279             $char,
5280             $chunk_start,
5281             $cmd_nr,
5282             $colons,
5283             $err_code,
5284             $err_occurred,
5285             $handler,
5286             $handler_data,
5287             $handler_timeout,
5288             $header,
5289             $i,
5290             $offset_ref,
5291             $size,
5292             $stream);
5293 0           my $this = $class_records{$self->{$class_name}};
5294             my %details = (e => {buffer_ref => undef,
5295             offset => 0},
5296             l => {buffer_ref => undef,
5297             offset => 0},
5298             m => {buffer_ref => undef,
5299             offset => 0},
5300             p => {buffer_ref => undef,
5301             offset => 0,
5302             handle => $this->{p_stream_handle},
5303             used => undef},
5304             t => {buffer_ref => undef,
5305             offset => 0,
5306             handle => $this->{t_stream_handle},
5307 0           used => undef},
5308             w => {buffer_ref => undef,
5309             offset => 0});
5310              
5311             # Create the buffers.
5312              
5313 0           foreach my $key (CORE::keys(%details))
5314             {
5315 0 0         if ($key eq "m")
5316             {
5317 0           $details{$key}->{buffer_ref} = $buffer;
5318             }
5319             else
5320             {
5321 0           my $ref_buf = "";
5322 0           $details{$key}->{buffer_ref} = \$ref_buf;
5323             }
5324             }
5325              
5326             # Work out what I/O wait handler is to be used.
5327              
5328 0 0         if (defined($this->{io_wait_handler}))
5329             {
5330 0           $handler = $this->{io_wait_handler};
5331 0           $handler_data = $this->{io_wait_handler_data};
5332 0           $handler_timeout = $this->{io_wait_handler_timeout};
5333             }
5334             else
5335             {
5336 0           $handler = $io_wait_handler;
5337 0           $handler_data = $io_wait_handler_data;
5338 0           $handler_timeout = $io_wait_handler_timeout;
5339             }
5340              
5341             # Read in the data.
5342              
5343 0           $$buffer = "";
5344 0           $chunk_start = 1;
5345 0           $buffer_ref = $details{m}->{buffer_ref};
5346 0           $offset_ref = \$details{m}->{offset};
5347             do
5348 0   0       {
5349              
5350             # Wait here for some data, calling the I/O wait handler every second
5351             # whilst we wait.
5352              
5353 0           while ($this->{poll_out}->poll($handler_timeout) == 0)
5354             {
5355 0           &$handler($self, $handler_data);
5356             }
5357              
5358             # If necessary, read in and process the chunk header, then we know how
5359             # much to read in.
5360              
5361 0 0         if ($chunk_start)
5362             {
5363              
5364             # Read header, one byte at a time until we have what we need or
5365             # there is an error.
5366              
5367 0   0       for ($header = "", $colons = $i = 0;
5368             $colons < 3 && $this->{mtn_out}->sysread($header, 1, $i);
5369             ++ $i)
5370             {
5371 0           $char = substr($header, $i, 1);
5372 0 0         if ($char eq ":")
    0          
    0          
5373             {
5374 0           ++ $colons;
5375             }
5376             elsif ($colons == 1)
5377             {
5378 0 0         if ($char !~ m/^[elmptw]$/)
5379             {
5380             croak("Corrupt/missing mtn chunk header, mtn gave:\n"
5381 0           . join("", $this->{mtn_err}->getlines()));
5382             }
5383             }
5384             elsif ($char =~ m/\D$/)
5385             {
5386             croak("Corrupt/missing mtn chunk header, mtn gave:\n"
5387 0           . join("", $this->{mtn_err}->getlines()));
5388             }
5389             }
5390              
5391             # Break out the header into its separate fields.
5392              
5393 0 0         if ($header =~ m/^(\d+):([elmptw]):(\d+):$/)
5394             {
5395 0           ($cmd_nr, $stream, $size) = ($1, $2, $3);
5396 0 0         if ($cmd_nr != $this->{cmd_cnt})
5397             {
5398 0           croak("Mtn command count is out of sequence");
5399             }
5400             }
5401             else
5402             {
5403             croak("Corrupt/missing mtn chunk header, mtn gave:\n"
5404 0           . join("", $this->{mtn_err}->getlines()));
5405             }
5406              
5407             # Set up the current buffer and offset details.
5408              
5409 0           $buffer_ref = $details{$stream}->{buffer_ref};
5410 0           $offset_ref = \$details{$stream}->{offset};
5411              
5412 0           $chunk_start = undef;
5413              
5414             }
5415              
5416             # Read in what we require.
5417              
5418 0 0         if ($stream ne "l")
    0          
5419             {
5420              
5421             # Process non-last messages.
5422              
5423 0 0         if ($size > 0)
5424             {
5425              
5426             # Process the current data chunk.
5427              
5428 0 0         if (! defined($bytes_read =
    0          
5429             $this->{mtn_out}->sysread($$buffer_ref,
5430             $size,
5431             $$offset_ref)))
5432             {
5433 0           croak("sysread failed: " . $!);
5434             }
5435             elsif ($bytes_read == 0)
5436             {
5437 0           croak("Short data read");
5438             }
5439 0           $size -= $bytes_read;
5440 0           $$offset_ref += $bytes_read;
5441              
5442             }
5443 0 0         if ($size <= 0)
5444             {
5445              
5446             # We have finished processing the current data chunk so if it
5447             # belongs to a stream that is to be redirected to a file handle
5448             # then send the data down it.
5449              
5450 0 0 0       if ($stream =~ m/^[pt]$/
5451             && defined($details{$stream}->{handle}))
5452             {
5453              
5454             # Send the headers as well so as to help the reader.
5455              
5456 0 0         if (! $details{$stream}->{handle}->print($header
5457             . $$buffer_ref))
5458             {
5459 0           croak("print failed: " . $!);
5460             }
5461 0           $details{$stream}->{used} = 1;
5462 0           $$buffer_ref = "";
5463 0           $$offset_ref = 0;
5464              
5465             }
5466              
5467 0           $chunk_start = 1;
5468              
5469             }
5470              
5471             }
5472             elsif ($size == 1)
5473             {
5474              
5475 0           my $last_msg;
5476              
5477             # Process the last message.
5478              
5479 0 0         if (! $this->{mtn_out}->sysread($err_code, 1))
5480             {
5481 0           croak("sysread failed: " . $!);
5482             }
5483 0           $size = 0;
5484 0 0         if ($err_code != 0)
5485             {
5486 0           $err_occurred = 1;
5487             }
5488              
5489             # Send the terminating last message down any stream file handle
5490             # that had data sent down it.
5491              
5492 0           $last_msg = $header . $err_code;
5493 0           foreach my $ostream ("p", "t")
5494             {
5495 0 0         if ($details{$ostream}->{used})
5496             {
5497 0 0         if (! $details{$ostream}->{handle}->print($last_msg))
5498             {
5499 0           croak("print failed: " . $!);
5500             }
5501             }
5502             }
5503              
5504             }
5505             else
5506             {
5507 0           croak("Invalid message state");
5508             }
5509              
5510             }
5511             while ($size > 0 || $stream ne "l");
5512              
5513 0           ++ $this->{cmd_cnt};
5514              
5515             # Record any error or warning messages.
5516              
5517 0 0         if (${$details{e}->{buffer_ref}} ne "")
  0 0          
5518             {
5519 0           $this->{error_msg} = ${$details{e}->{buffer_ref}};
  0            
5520             }
5521 0           elsif (${$details{w}->{buffer_ref}} ne "")
5522             {
5523 0           $this->{error_msg} = ${$details{w}->{buffer_ref}};
  0            
5524             }
5525              
5526             # If something has gone wrong then deal with it.
5527              
5528 0 0         if ($err_occurred)
5529             {
5530 0           $$buffer = "";
5531 0           return;
5532             }
5533              
5534 0           return 1;
5535              
5536             }
5537             #
5538             ##############################################################################
5539             #
5540             # Routine - startup
5541             #
5542             # Description - If necessary start up the mtn subprocess.
5543             #
5544             # Data - $self : The object.
5545             #
5546             ##############################################################################
5547              
5548              
5549              
5550             sub startup($)
5551             {
5552              
5553 0     0 0   my $self = $_[0];
5554              
5555 0           my $this = $class_records{$self->{$class_name}};
5556              
5557 0 0         if ($this->{mtn_pid} == 0)
5558             {
5559              
5560 0           my (@args,
5561             $cwd,
5562             $file,
5563             $exception,
5564             $header_err,
5565             $line,
5566             $my_pid,
5567             $startup,
5568             $version);
5569              
5570             # Deep recursion guard.
5571              
5572 0           $startup = $this->{startup};
5573 0           local $this->{startup};
5574 0           $this->{startup} = 1;
5575              
5576             # Switch to the default locale. We only want to parse the output from
5577             # Monotone in one language!
5578              
5579 0           local $ENV{LC_ALL} = "C";
5580 0           local $ENV{LANG} = "C";
5581              
5582             # Don't allow SIGPIPE signals to terminate the calling program (any
5583             # related errors are dealt with anyway).
5584              
5585 0           $SIG{PIPE} = "IGNORE";
5586              
5587 0           $this->{db_is_locked} = undef;
5588 0           $this->{mtn_err} = gensym();
5589              
5590             # If we have a disk based database name then convert it to an absolute
5591             # path so that any subsequent chdir(2) call does not prevent opening
5592             # the correct database.
5593              
5594             $this->{db_name} = File::Spec->rel2abs($this->{db_name})
5595             if (defined($this->{db_name})
5596 0 0 0       && ! defined($this->{network_service}));
5597              
5598             # Build up a list of command line arguments to pass to the mtn
5599             # subprocess.
5600              
5601 0           @args = ("mtn");
5602 0 0         push(@args, "--db=" . $this->{db_name}) if (defined($this->{db_name}));
5603 0 0         push(@args, "--quiet") if (defined($this->{network_service}));
5604             push(@args, "--ignore-suspend-certs")
5605 0 0         if (! $this->{honour_suspend_certs});
5606 0           push(@args, @{$this->{mtn_options}});
  0            
5607 0 0         if (defined($this->{network_service}))
5608             {
5609 0           push(@args, "automate", "remote_stdio", $this->{network_service});
5610             }
5611             else
5612             {
5613 0           push(@args, "automate", "stdio");
5614             }
5615              
5616             # Actually start the mtn subprocess. If a database name has been
5617             # provided then run the mtn subprocess in the system's root directory
5618             # so as to avoid any database/workspace clash. Likewise if a workspace
5619             # has been provided then run the mtn subprocess in the base directory
5620             # of that workspace (although in this case the caller can override this
5621             # feature if it wishes to do so).
5622              
5623 0           $cwd = getcwd();
5624 0           $my_pid = $$;
5625             eval
5626 0           {
5627 0 0 0       if (defined($this->{db_name}) || defined($this->{network_service}))
    0 0        
5628             {
5629 0 0         die("chdir failed: " . $!)
5630             unless (chdir(File::Spec->rootdir()));
5631             }
5632             elsif ($this->{cd_to_ws_root} && defined($this->{ws_path}))
5633             {
5634 0 0         die("chdir failed: " . $!) unless (chdir($this->{ws_path}));
5635             }
5636             $this->{mtn_pid} = open3($this->{mtn_in},
5637             $this->{mtn_out},
5638             $this->{mtn_err},
5639 0           @args);
5640             };
5641 0           $exception = $@;
5642 0           chdir($cwd);
5643              
5644             # Check for errors (remember that open3() errors can happen in both the
5645             # parent and child processes).
5646              
5647 0 0         if ($exception)
5648             {
5649 0 0         if ($$ != $my_pid)
5650             {
5651              
5652             # In the child process so all we can do is complain and exit.
5653              
5654 0           STDERR->print("open3 failed: " . $exception . "\n");
5655 0           exit(1);
5656              
5657             }
5658             else
5659             {
5660              
5661             # In the parent process so deal with the error in the usual
5662             # way.
5663              
5664 0           &$croaker($exception);
5665              
5666             }
5667             }
5668              
5669             # Ok so reset the command count and setup polling.
5670              
5671 0           $this->{cmd_cnt} = 0;
5672 0           $this->{poll_out} = IO::Poll->new();
5673 0           $this->{poll_out}->mask($this->{mtn_out}, POLLIN | POLLPRI | POLLHUP);
5674 0           $this->{poll_err} = IO::Poll->new();
5675 0           $this->{poll_err}->mask($this->{mtn_err}, POLLIN | POLLPRI | POLLHUP);
5676              
5677             # If necessary get the version of the actual application.
5678              
5679 0 0         if (! defined($mtn_version))
5680             {
5681 0 0         &$croaker("Could not run command `mtn --version'")
5682             unless (defined($file = IO::File->new("mtn --version |")));
5683 0           while (defined($line = $file->getline()))
5684             {
5685 0 0         if ($line =~ m/^monotone (\d+\.\d+)(dev)? ./)
    0          
5686             {
5687 0           $mtn_version = $1;
5688             }
5689             elsif ($line =~ m/^monotone (\d+\.\d+)([\d.]+)(dev)? ./)
5690             {
5691 0           my ($first_part, $second_part) = ($1, $2);
5692 0           $second_part =~ s/\.//g;
5693 0           $mtn_version = $first_part . $second_part;
5694             }
5695             }
5696 0           $file->close();
5697 0 0         &$croaker("Could not determine the version of Monotone being used")
5698             unless (defined($mtn_version));
5699             }
5700              
5701             # If the version is higher than 0.45 then we need to skip the header
5702             # which is terminated by two blank lines (put any errors into
5703             # $header_err as we need to defer any error reporting until later).
5704              
5705 0 0         if ($mtn_version > 0.45)
5706             {
5707              
5708 0           my ($char,
5709             $last_char);
5710              
5711             # If we are connecting to a network service then make sure that it
5712             # has sent us something before doing a blocking read.
5713              
5714 0 0         if (defined($this->{network_service}))
5715             {
5716 0           my $poll_result;
5717 0   0       for (my $i = 0;
5718             $i < 10
5719             && ($poll_result =
5720             $this->{poll_out}->poll($io_wait_handler_timeout))
5721             == 0;
5722             ++ $i)
5723             {
5724 0           &$io_wait_handler($self, $io_wait_handler_data);
5725             }
5726 0 0         if ($poll_result == 0)
5727             {
5728 0           $self->closedown();
5729             &$croaker("Cannot connect to service `" .
5730 0           $this->{network_service} . "'");
5731             }
5732             }
5733              
5734             # Skip the header.
5735              
5736 0           $char = $last_char = "";
5737 0   0       while ($char ne "\n" || $last_char ne "\n")
5738             {
5739 0           $last_char = $char;
5740 0 0         if (! $this->{mtn_out}->sysread($char, 1))
5741             {
5742 0           $header_err = "Cannot get format header";
5743 0           last;
5744             }
5745             }
5746              
5747             }
5748              
5749             # Set up the correct input handler depending upon the version of mtn.
5750              
5751 0 0         if ($mtn_version > 0.45)
5752             {
5753 0           *mtn_read_output = *mtn_read_output_format_2;
5754             }
5755             else
5756             {
5757 0           *mtn_read_output = *mtn_read_output_format_1;
5758             }
5759              
5760             # Get the interface version (remember also that if something failed
5761             # above then this method will throw an exception giving the cause). If
5762             # the database is locked then this startup method will be called again
5763             # by the method call below, so use the $startup boolean to stop
5764             # unnecessary recursion.
5765              
5766 0 0         if (! $startup)
5767             {
5768 0 0 0       if ($self->interface_version(\$version)
5769             && $version =~ m/^(\d+\.\d+)$/)
5770             {
5771 0           $this->{mtn_aif_version} = $1;
5772              
5773             # We seem to be ok now despite any earlier failures so reset
5774             # $header_err.
5775              
5776 0           $header_err = undef;
5777             }
5778             else
5779             {
5780 0 0         if ($this->{db_is_locked})
5781             {
5782 0           &$croaker("Database is locked and there is either no "
5783             . "registered retry handler or the handler "
5784             . "returned false");
5785             }
5786             else
5787             {
5788 0           &$croaker("Cannot get automate stdio interface version "
5789             . "number");
5790             }
5791             }
5792             }
5793              
5794             # This should never happen as getting the interface version would have
5795             # reported the real issue, but handle any header read issues just in
5796             # case.
5797              
5798 0 0 0       &$croaker($header_err) if (! $startup && defined($header_err));
5799              
5800             }
5801              
5802             }
5803             #
5804             ##############################################################################
5805             #
5806             # Routine - get_ws_details
5807             #
5808             # Description - Checks to see if the specified workspace is valid and, if
5809             # it is, extracts the workspace root directory and the full
5810             # path name of the associated database.
5811             #
5812             # Data - $ws_path : The path to the workspace or a subdirectory of
5813             # it.
5814             # $db_name : A reference to a buffer that is to contain the
5815             # name of the database relating to the specified
5816             # workspace.
5817             # $ws_base : A reference to a buffer that is to contain the
5818             # path of the workspace's base directory.
5819             #
5820             ##############################################################################
5821              
5822              
5823              
5824             sub get_ws_details($$$)
5825             {
5826              
5827 0     0 0   my ($ws_path, $db_name, $ws_base) = @_;
5828              
5829 0           my ($i,
5830             @lines,
5831             $options_fh,
5832             $options_file,
5833             $path,
5834             $record);
5835              
5836             # Find the workspace's base directory.
5837              
5838 0 0         &$croaker("`" . $ws_path . "' is not a directory") unless (-d $ws_path);
5839 0           $path = abs_path($ws_path);
5840 0           while (! -d File::Spec->catfile($path, "_MTN"))
5841             {
5842 0 0         &$croaker("Invalid workspace `" . $ws_path
5843             . "', no _MTN directory found")
5844             if ($path eq File::Spec->rootdir());
5845 0           $path = dirname($path);
5846             }
5847              
5848             # Get the name of the related database out of the _MTN/options file.
5849              
5850 0           $options_file = File::Spec->catfile($path, "_MTN", "options");
5851 0 0         &$croaker("Could not open `" . $options_file . "' for reading")
5852             unless (defined($options_fh = IO::File->new($options_file, "r")));
5853 0           @lines = $options_fh->getlines();
5854 0           $options_fh->close();
5855 0           chomp(@lines);
5856 0           $i = 0;
5857 0           parse_kv_record(\@lines, \$i, \%options_file_keys, \$record, 1);
5858              
5859             # Return what we have found.
5860              
5861 0           $$db_name = $record->{database};
5862 0           $$ws_base = $path;
5863              
5864             }
5865             #
5866             ##############################################################################
5867             #
5868             # Routine - validate_database
5869             #
5870             # Description - Checks to see if the specified file is a Monotone SQLite
5871             # database. Please note that this does not verify that the
5872             # schema of the database is compatible with the version of
5873             # Monotone being used.
5874             #
5875             # Data - $db_name : The file name of the database to check.
5876             #
5877             ##############################################################################
5878              
5879              
5880              
5881             sub validate_database($)
5882             {
5883              
5884 0     0 0   my $db_name = $_[0];
5885              
5886 0           my ($buffer,
5887             $db);
5888              
5889             # Open the database.
5890              
5891 0 0         &$croaker("`" . $db_name . "' is not a file") unless (-f $db_name);
5892 0 0         &$croaker("Could not open `" . $db_name . "' for reading")
5893             unless (defined($db = IO::File->new($db_name, "r")));
5894 0 0         &$croaker("binmode failed: " . $!) unless (binmode($db));
5895              
5896             # Check that it is an SQLite version 3.x database.
5897              
5898 0 0 0       &$croaker("File `" . $db_name . "' is not a SQLite 3 database")
5899             if ($db->sysread($buffer, 15) != 15 || $buffer ne "SQLite format 3");
5900              
5901             # Check that it is a Monotone database.
5902              
5903 0 0 0       &$croaker("Database `" . $db_name . "' is not a monotone repository or an "
      0        
5904             . "older unsupported version")
5905             if (! $db->sysseek(60, 0)
5906             || $db->sysread($buffer, 4) != 4
5907             || $buffer ne "_MTN");
5908              
5909 0           $db->close();
5910              
5911             }
5912             #
5913             ##############################################################################
5914             #
5915             # Routine - validate_mtn_options
5916             #
5917             # Description - Checks to see if the specified list of mtn command line
5918             # options are valid.
5919             #
5920             # Data - $options : A reference to a list containing a list of
5921             # options to use on the mtn subprocess.
5922             #
5923             ##############################################################################
5924              
5925              
5926              
5927             sub validate_mtn_options($)
5928             {
5929              
5930 0     0 0   my $options = $_[0];
5931              
5932             # Parse the options (don't allow indiscriminate passing of command line
5933             # options to the subprocess!).
5934              
5935 0           for (my $i = 0; $i < scalar(@$options); ++ $i)
5936             {
5937 0 0         if (! exists($valid_mtn_options{$$options[$i]}))
5938             {
5939 0           &$croaker("Unrecognised option `" . $$options[$i]
5940             . "'passed to constructor");
5941             }
5942             else
5943             {
5944 0           $i += $valid_mtn_options{$$options[$i]};
5945             }
5946             }
5947              
5948             }
5949             #
5950             ##############################################################################
5951             #
5952             # Routine - create_object
5953             #
5954             # Description - Actually creates a Monotone::AutomateStdio object.
5955             #
5956             # Data - $class : The name of the class that the new object
5957             # should be blessed as.
5958             # Return Value : A new Monotone::AutomateStdio object.
5959             #
5960             ##############################################################################
5961              
5962              
5963              
5964             sub create_object($)
5965             {
5966              
5967 0     0 0   my $class = $_[0];
5968              
5969 0           my ($counter,
5970             $id,
5971             $self,
5972             $this);
5973              
5974             # Create the object's data record.
5975              
5976 0           $this = {db_name => undef,
5977             ws_path => undef,
5978             network_service => undef,
5979             ws_constructed => undef,
5980             cd_to_ws_root => $cd_to_ws_root,
5981             convert_to_utf8 => $convert_to_utf8,
5982             startup => undef,
5983             mtn_options => undef,
5984             mtn_pid => 0,
5985             mtn_in => undef,
5986             mtn_out => undef,
5987             mtn_err => undef,
5988             poll_out => undef,
5989             poll_err => undef,
5990             error_msg => "",
5991             honour_suspend_certs => 1,
5992             mtn_aif_version => undef,
5993             cmd_cnt => 0,
5994             p_stream_handle => undef,
5995             t_stream_handle => undef,
5996             db_is_locked => undef,
5997             db_locked_handler => undef,
5998             db_locked_handler_data => undef,
5999             io_wait_handler => undef,
6000             io_wait_handler_data => undef,
6001             io_wait_handler_timeout => 1};
6002              
6003             # Create a unique key (using rand() and duplication detection) and the
6004             # actual object, then store this unique key in the object in a field named
6005             # after this class.
6006              
6007 0           $counter = 0;
6008             do
6009             {
6010 0           $id = int(rand(INT_MAX));
6011 0 0         &$croaker("Exhausted unique object keys")
6012             if ((++ $counter) == INT_MAX);
6013             }
6014 0           while (exists($class_records{$id}));
6015 0           $self = bless({}, $class);
6016 0           $self->{$class_name} = $id;
6017              
6018             # Now file the object's record in the records store, filed under the
6019             # object's unique key.
6020              
6021 0           $class_records{$id} = $this;
6022              
6023 0           return $self;
6024              
6025             }
6026             #
6027             ##############################################################################
6028             #
6029             # Routine - expand_options
6030             #
6031             # Description - Expands the specified list of options so that they all have
6032             # values.
6033             #
6034             # Data - $options : A reference to a list containing the
6035             # options to use.
6036             # $expanded_options : A reference to a list that is to
6037             # contain the list of expanded options in
6038             # the form of key-value records.
6039             #
6040             ##############################################################################
6041              
6042              
6043              
6044             sub expand_options($$)
6045             {
6046              
6047 0     0 0   my ($options, $expanded_options) = @_;
6048              
6049             # Process any options.
6050              
6051 0           @$expanded_options = ();
6052 0 0         if (defined($options))
6053             {
6054 0           for (my $i = 0; $i < scalar(@$options); ++ $i)
6055             {
6056 0 0         if (exists($non_arg_options{$$options[$i]}))
6057             {
6058 0           push(@$expanded_options, {key => $$options[$i], value => ""});
6059             }
6060             else
6061             {
6062 0           push(@$expanded_options,
6063             {key => $$options[$i], value => $$options[++ $i]});
6064             }
6065             }
6066             }
6067              
6068             }
6069             #
6070             ##############################################################################
6071             #
6072             # Routine - get_quoted_value
6073             #
6074             # Description - Get the contents of a quoted value that may span several
6075             # lines and contain escaped quotes.
6076             #
6077             # Data - $list : A reference to the list that contains the quoted
6078             # string.
6079             # $index : A reference to a variable containing the index of
6080             # the line in the array containing the opening
6081             # quote (assumed to be the first quote
6082             # encountered). It is updated with the index of the
6083             # line containing the closing quote at the end of
6084             # the line.
6085             # $offset : The offset within the first line, specified by
6086             # $index, where this routine should start searching
6087             # for the opening quote.
6088             # $buffer : A reference to a buffer that is to contain the
6089             # contents of the quoted string.
6090             #
6091             ##############################################################################
6092              
6093              
6094              
6095             sub get_quoted_value($$$$)
6096             {
6097              
6098 0     0 0   my ($list, $index, $offset, $buffer) = @_;
6099              
6100             # Deal with multiple lines.
6101              
6102 0           $$buffer =
6103             substr($$list[$$index], index($$list[$$index], "\"", $offset) + 1);
6104 0 0         if ($$buffer !~ m/$closing_quote_re/)
6105             {
6106             do
6107 0           {
6108 0           $$buffer .= "\n" . $$list[++ $$index];
6109             }
6110             while ($$list[$$index] !~ m/$closing_quote_re/);
6111             }
6112 0           substr($$buffer, -1, 1, "");
6113              
6114             }
6115             #
6116             ##############################################################################
6117             #
6118             # Routine - unescape
6119             #
6120             # Description - Process mtn escape characters to get back the original
6121             # data.
6122             #
6123             # Data - $data : The escaped data.
6124             # Return Value : The unescaped data.
6125             #
6126             ##############################################################################
6127              
6128              
6129              
6130             sub unescape($)
6131             {
6132              
6133 0     0 0   my $data = $_[0];
6134              
6135 0 0         return undef unless (defined($data));
6136              
6137 0           $data =~ s/\\\\/\\/g;
6138 0           $data =~ s/\\\"/\"/g;
6139              
6140 0           return $data;
6141              
6142             }
6143             #
6144             ##############################################################################
6145             #
6146             # Routine - error_handler_wrapper
6147             #
6148             # Description - Error handler routine that wraps the user's error handler.
6149             # Essentially this routine simply prepends the severity
6150             # parameter and appends the client data parameter.
6151             #
6152             # Data - $message : The error message.
6153             #
6154             ##############################################################################
6155              
6156              
6157              
6158             sub error_handler_wrapper($)
6159             {
6160              
6161 0     0 0   my $message = $_[0];
6162              
6163 0           &$error_handler(MTN_SEVERITY_ERROR, $message, $error_handler_data);
6164 0           croak(__PACKAGE__ . ": Fatal error");
6165              
6166             }
6167             #
6168             ##############################################################################
6169             #
6170             # Routine - warning_handler_wrapper
6171             #
6172             # Description - Warning handler routine that wraps the user's warning
6173             # handler. Essentially this routine simply prepends the
6174             # severity parameter and appends the client data parameter.
6175             #
6176             # Data - $message : The error message.
6177             #
6178             ##############################################################################
6179              
6180              
6181              
6182             sub warning_handler_wrapper($)
6183             {
6184              
6185 0     0 0   my $message = $_[0];
6186              
6187 0           &$warning_handler(MTN_SEVERITY_WARNING, $message, $warning_handler_data);
6188              
6189             }
6190              
6191             1;