File Coverage

blib/lib/Monotone/AutomateStdio.pm

Criterion	Covered	Total	%
statement	219	1298	16.8
branch	0	600	0.0
condition	0	231	0.0
subroutine	73	171	42.6
pod	78	94	82.9
total	370	2394	15.4

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