monotone

monotone Mtn Source Tree

Root/lib/Monotone/AutomateStdio.pm

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# <aecooper@coosoft.plus.com>.
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
44package Monotone::AutomateStdio;
45
46# ***** DIRECTIVES *****
47
48require 5.008005;
49
50no locale;
51use strict;
52use warnings;
53
54# ***** REQUIRED PACKAGES *****
55
56# Standard Perl and CPAN modules.
57
58use Carp;
59use Cwd qw(abs_path getcwd);
60use Encode;
61use File::Basename;
62use File::Spec;
63use IO::File;
64use IO::Handle qw(autoflush);
65use IO::Poll qw(POLLHUP POLLIN POLLPRI);
66use IPC::Open3;
67use POSIX qw(:errno_h :limits_h);
68use Socket;
69use Symbol qw(gensym);
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
76use constant MTN_COMMON_KEY_HASH => 0;
77use constant MTN_CONTENT_DIFF_EXTRA_OPTIONS => 1;
78use constant MTN_DB_GET => 2;
79use constant MTN_DROP_ATTRIBUTE => 3;
80use constant MTN_DROP_DB_VARIABLES => 4;
81use constant MTN_FILE_MERGE => 5;
82use constant MTN_GET_ATTRIBUTES => 6;
83use constant MTN_GET_CURRENT_REVISION => 7;
84use constant MTN_GET_DB_VARIABLES => 8;
85use constant MTN_GET_WORKSPACE_ROOT => 9;
86use constant MTN_HASHED_SIGNATURES => 10;
87use constant MTN_IGNORING_OF_SUSPEND_CERTS => 11;
88use constant MTN_INVENTORY_IN_IO_STANZA_FORMAT => 12;
89use constant MTN_INVENTORY_TAKING_OPTIONS => 13;
90use constant MTN_INVENTORY_WITH_BIRTH_ID => 14;
91use constant MTN_LUA => 15;
92use constant MTN_M_SELECTOR => 16;
93use constant MTN_P_SELECTOR => 17;
94use constant MTN_READ_PACKETS => 18;
95use constant MTN_REMOTE_CONNECTIONS => 19;
96use constant MTN_SET_ATTRIBUTE => 20;
97use constant MTN_SET_DB_VARIABLE => 21;
98use constant MTN_SHOW_CONFLICTS => 22;
99use constant MTN_STREAM_IO => 23;
100use constant MTN_SYNCHRONISATION => 24;
101use constant MTN_U_SELECTOR => 25;
102use constant MTN_UPDATE => 26;
103use constant MTN_W_SELECTOR => 27;
104
105# Constants used to represent the different error levels.
106
107use constant MTN_SEVERITY_ALL => 0x03;
108use constant MTN_SEVERITY_ERROR => 0x01;
109use constant MTN_SEVERITY_WARNING => 0x02;
110
111# Constants used to represent data streams from Monotone that can be tied into
112# file handles by the caller.
113
114use constant MTN_P_STREAM => 0;
115use constant MTN_T_STREAM => 1;
116
117# Constant used to represent the exception thrown when interrupting waitpid().
118
119use constant WAITPID_INTERRUPT => __PACKAGE__ . "::waitpid-interrupt";
120
121# Constant used to represent the in memory database name.
122
123use constant IN_MEMORY_DB_NAME => ":memory:";
124
125# Constants used to represent different value formats.
126
127use constant BARE_PHRASE => 0x01; # E.g. orphaned_directory.
128use constant HEX_ID => 0x02; # E.g. [ab2 ... 1be].
129use constant NULL => 0x04; # Nothing, i.e. we just have the key.
130use constant OPTIONAL_HEX_ID => 0x08; # As HEX_ID but also [].
131use constant STRING => 0x10; # Any quoted string, possibly escaped.
132use constant STRING_ENUM => 0x20; # E.g. "rename_source".
133use constant STRING_LIST => 0x40; # E.g. "..." "...", possibly escaped.
134
135# Private structures for managing inside-out key caching style objects.
136
137my $class_name = __PACKAGE__;
138my %class_records;
139
140# Pre-compiled regular expressions for: finding the end of a quoted string
141# possibly containing escaped quotes (i.e. " preceeded by a non-backslash
142# character or an even number of backslash characters), recognising data locked
143# conditions and detecting the beginning of an I/O stanza.
144
145my $closing_quote_re = qr/((^.*[^\\])|^)(\\{2})*\"$/;
146my $database_locked_re = qr/.*sqlite error: database is locked.*/;
147my $io_stanza_re = qr/^ *([a-z_]+)(?:(?: \S)|(?: ?$))/;
148
149# A map for quickly detecting valid mtn subprocess options and the number of
150# their arguments.
151
152my %valid_mtn_options = ("--confdir" => 1,
153 "--key" => 1,
154 "--keydir" => 1,
155 "--no-default-confdir" => 0,
156 "--no-workspace" => 0,
157 "--norc" => 0,
158 "--nostd" => 0,
159 "--rcfile" => 1,
160 "--root" => 1,
161 "--ssh-sign" => 1);
162
163# Maps for quickly detecting valid keys and determining their value types.
164
165my %certs_keys = ("key" => HEX_ID | STRING,
166 "name" => STRING,
167 "signature" => STRING,
168 "trust" => STRING_ENUM,
169 "value" => STRING);
170my %genkey_keys = ("given_name" => STRING,
171 "hash" => HEX_ID,
172 "local_name" => STRING,
173 "name" => STRING,
174 "public_hash" => HEX_ID,
175 "private_hash" => HEX_ID,
176 "public_location" => STRING_LIST,
177 "private_location" => STRING_LIST);
178my %get_attributes_keys = ("attr" => STRING_LIST,
179 "format_version" => STRING_ENUM,
180 "state" => STRING_ENUM);
181my %get_db_variables_keys = ("domain" => STRING,
182 "entry" => STRING_LIST);
183my %inventory_keys = ("birth" => HEX_ID,
184 "changes" => STRING_LIST,
185 "fs_type" => STRING_ENUM,
186 "new_path" => STRING,
187 "new_type" => STRING_ENUM,
188 "old_path" => STRING,
189 "old_type" => STRING_ENUM,
190 "path" => STRING,
191 "status" => STRING_LIST);
192my %keys_keys = %genkey_keys;
193my %options_file_keys = ("branch" => STRING,
194 "database" => STRING,
195 "keydir" => STRING);
196my %revision_details_keys = ("add_dir" => STRING,
197 "add_file" => STRING,
198 "attr" => STRING,
199 "clear" => STRING,
200 "content" => HEX_ID,
201 "delete" => STRING,
202 "format_version" => STRING_ENUM,
203 "from" => HEX_ID,
204 "new_manifest" => HEX_ID,
205 "old_revision" => OPTIONAL_HEX_ID,
206 "patch" => STRING,
207 "rename" => STRING,
208 "set" => STRING,
209 "to" => HEX_ID | STRING,
210 "value" => STRING);
211my %show_conflicts_keys = ("ancestor" => OPTIONAL_HEX_ID,
212 "ancestor_file_id" => HEX_ID,
213 "ancestor_name" => STRING,
214 "attr_name" => STRING,
215 "conflict" => BARE_PHRASE,
216 "left" => HEX_ID,
217 "left_attr_state" => STRING,
218 "left_attr_value" => STRING,
219 "left_file_id" => HEX_ID,
220 "left_name" => STRING,
221 "left_type" => STRING,
222 "node_type" => STRING,
223 "resolved_internal" => NULL,
224 "right" => HEX_ID,
225 "right_attr_state" => STRING,
226 "right_attr_value" => STRING,
227 "right_file_id" => HEX_ID,
228 "right_name" => STRING,
229 "right_type" => STRING);
230my %tags_keys = ("branches" => NULL | STRING_LIST,
231 "format_version" => STRING_ENUM,
232 "revision" => HEX_ID,
233 "signer" => HEX_ID | STRING,
234 "tag" => STRING);
235
236# Version of Monotone being used.
237
238my $mtn_version;
239
240# Flag for determining whether the mtn subprocess should be started in a
241# workspace's root directory.
242
243my $cd_to_ws_root = 1;
244
245# Flag for detemining whether UTF-8 conversion should be done on the data sent
246# to and from the mtn subprocess.
247
248my $convert_to_utf8 = 1;
249
250# Error, database locked and io wait callback routine references and associated
251# client data.
252
253my $carper = sub { return; };
254my $croaker = \&croak;
255my $db_locked_handler = sub { return; };
256my $io_wait_handler = sub { return; };
257my($db_locked_handler_data,
258 $error_handler,
259 $error_handler_data,
260 $io_wait_handler_data,
261 $io_wait_handler_timeout,
262 $warning_handler,
263 $warning_handler_data);
264
265# ***** FUNCTIONAL PROTOTYPES *****
266
267# Constructors and destructor.
268
269sub new_from_db($;$$);
270sub new_from_service($$;$);
271sub new_from_ws($;$$);
272*new = *new_from_db;
273sub DESTROY($);
274
275# Public methods.
276
277sub ancestors($$@);
278sub ancestry_difference($$$;@);
279sub branches($$);
280sub cert($$$$);
281sub certs($$$);
282sub children($$$);
283sub closedown($);
284sub common_ancestors($$@);
285sub content_diff($$;$$$@);
286sub db_get($$$$);
287sub db_locked_condition_detected($);
288sub descendents($$@);
289sub drop_attribute($$$);
290sub drop_db_variables($$;$);
291sub erase_ancestors($$;@);
292sub file_merge($$$$$$);
293sub genkey($$$$);
294sub get_attributes($$$);
295sub get_base_revision_id($$);
296sub get_content_changed($$$$);
297sub get_corresponding_path($$$$$);
298sub get_current_revision($$;$@);
299sub get_current_revision_id($$);
300sub get_db_name($);
301sub get_db_variables($$;$);
302sub get_error_message($);
303sub get_file($$$);
304sub get_file_of($$$;$);
305sub get_manifest_of($$;$);
306sub get_option($$$);
307sub get_pid($);
308sub get_revision($$$);
309sub get_service_name($);
310sub get_workspace_root($$);
311sub get_ws_path($);
312sub graph($$);
313sub heads($$;$);
314sub identify($$$);
315sub ignore_suspend_certs($$);
316sub interface_version($$);
317sub inventory($$;$@);
318sub keys($$);
319sub leaves($$);
320sub lua($$$;@);
321sub packet_for_fdata($$$);
322sub packet_for_fdelta($$$$);
323sub packet_for_rdata($$$);
324sub packets_for_certs($$$);
325sub parents($$$);
326sub put_file($$$$);
327sub put_revision($$$);
328sub read_packets($$);
329sub register_db_locked_handler(;$$$);
330sub register_error_handler($;$$$);
331sub register_io_wait_handler(;$$$$);
332sub register_stream_handle($$$);
333sub roots($$);
334sub select($$$);
335sub set_attribute($$$$);
336sub set_db_variable($$$$);
337sub show_conflicts($$;$$$);
338sub supports($$);
339sub suppress_utf8_conversion($$);
340sub switch_to_ws_root($$);
341sub sync($;$$@);
342sub tags($$;$);
343sub toposort($$@);
344sub update($;$);
345
346# Public aliased methods.
347
348*attributes = *get_attributes;
349*db_set = *set_db_variable;
350*pull = *sync;
351*push = *sync;
352
353# Private methods and routines.
354
355sub create_object($);
356sub error_handler_wrapper($);
357sub get_quoted_value($$$);
358sub get_ws_details($$$);
359sub mtn_command($$$$$;@);
360sub mtn_command_with_options($$$$$$;@);
361sub mtn_read_output_format_1($$);
362sub mtn_read_output_format_2($$);
363sub parse_kv_record($$$$;$);
364sub parse_revision_data($$);
365sub startup($);
366sub unescape($);
367sub validate_database($);
368sub validate_mtn_options($);
369sub warning_handler_wrapper($);
370
371# ***** PACKAGE INFORMATION *****
372
373# We are just a base class.
374
375use base qw(Exporter);
376
377our %EXPORT_TAGS = (capabilities => [qw(MTN_COMMON_KEY_HASH
378MTN_CONTENT_DIFF_EXTRA_OPTIONS
379MTN_DB_GET
380MTN_DROP_ATTRIBUTE
381MTN_DROP_DB_VARIABLES
382MTN_FILE_MERGE
383MTN_GET_ATTRIBUTES
384MTN_GET_CURRENT_REVISION
385MTN_GET_DB_VARIABLES
386MTN_GET_WORKSPACE_ROOT
387MTN_HASHED_SIGNATURES
388MTN_IGNORING_OF_SUSPEND_CERTS
389MTN_INVENTORY_IN_IO_STANZA_FORMAT
390MTN_INVENTORY_TAKING_OPTIONS
391MTN_INVENTORY_WITH_BIRTH_ID
392MTN_LUA
393MTN_M_SELECTOR
394MTN_P_SELECTOR
395MTN_READ_PACKETS
396MTN_REMOTE_CONNECTIONS
397MTN_SET_ATTRIBUTE
398MTN_SET_DB_VARIABLE
399MTN_SHOW_CONFLICTS
400MTN_STREAM_IO
401MTN_SYNCHRONISATION
402MTN_U_SELECTOR
403MTN_UPDATE
404MTN_W_SELECTOR)],
405 severities => [qw(MTN_SEVERITY_ALL
406MTN_SEVERITY_ERROR
407MTN_SEVERITY_WARNING)],
408 streams => [qw(MTN_P_STREAM
409MTN_T_STREAM)]);
410our @EXPORT = qw();
411Exporter::export_ok_tags(qw(capabilities severities streams));
412our $VERSION = 0.09;
413#
414##############################################################################
415#
416# Routine - new_from_db
417#
418# Description - Class constructor. Construct an object using the specified
419# Monotone database.
420#
421# Data - $class : Either the name of the class that is to be
422# created or an object of that class.
423# $db_name : The full path of the Monotone database. If
424# this is not provided then the database
425# associated with the current workspace is
426# used.
427# $options : A reference to a list containing a list of
428# options to use on the mtn subprocess.
429# Return Value : A reference to the newly created object.
430#
431##############################################################################
432
433
434
435sub new_from_db($;$$)
436{
437
438
439 my $class = (ref($_[0]) ne "") ? ref($_[0]) : $_[0];
440 shift();
441 my $db_name = (ref($_[0]) eq "ARRAY") ? undef : shift();
442 my $options = shift();
443 $options = [] unless (defined($options));
444
445 my($db,
446 $this,
447 $self,
448 $ws_path);
449
450 # Check all the arguments given to us.
451
452 validate_mtn_options($options);
453 if (defined($db_name))
454 {
455$db = $db_name;
456 }
457 else
458 {
459get_ws_details(getcwd(), \$db, \$ws_path);
460 }
461 validate_database($db);
462
463 # Actually construct the object.
464
465 $self = create_object($class);
466 $this = $class_records{$self->{$class_name}};
467 $this->{db_name} = $db_name;
468 $this->{ws_path} = $ws_path;
469 $this->{mtn_options} = $options;
470
471 # Startup the mtn subprocess (also determining the interface version).
472
473 $self->startup();
474
475 return $self;
476
477}
478#
479##############################################################################
480#
481# Routine - new_from_service
482#
483# Description - Class constructor. Construct an object using the specified
484# Monotone service.
485#
486# Data - $class : Either the name of the class that is to be
487# created or an object of that class.
488# $service : The name of the Monotone server to connect
489# to, optionally followed by a colon and the
490# port number.
491# $options : A reference to a list containing a list of
492# options to use on the mtn subprocess.
493# Return Value : A reference to the newly created object.
494#
495##############################################################################
496
497
498
499sub new_from_service($$;$)
500{
501
502
503 my $class = (ref($_[0]) ne "") ? ref($_[0]) : $_[0];
504 shift();
505 my($service, $options) = @_;
506 $options = [] unless (defined($options));
507
508 my($self,
509 $server,
510 $this);
511
512 # Check all the arguments given to us.
513
514 validate_mtn_options($options);
515
516 # Check that the server is know to us.
517
518 if ($service =~ m/^([^:]+):\d+$/)
519 {
520$server = $1;
521 }
522 else
523 {
524$server = $service;
525 }
526 &$croaker("`" . $server . "' is not known to the system")
527unless (defined(inet_aton($server)));
528
529 # Actually construct the object.
530
531 $self = create_object($class);
532 $this = $class_records{$self->{$class_name}};
533 $this->{db_name} = IN_MEMORY_DB_NAME;
534 $this->{network_service} = $service;
535 $this->{mtn_options} = $options;
536
537 # Startup the mtn subprocess (also determining the interface version).
538
539 $self->startup();
540
541 return $self;
542
543}
544#
545##############################################################################
546#
547# Routine - new_from_ws
548#
549# Description - Class constructor. Construct an object using the specified
550# Monotone workspace.
551#
552# Data - $class : Either the name of the class that is to be
553# created or an object of that class.
554# $ws_path : The base directory of a Monotone workspace.
555# If this is not provided then the current
556# workspace is used.
557# $options : A reference to a list containing a list of
558# options to use on the mtn subprocess.
559# Return Value : A reference to the newly created object.
560#
561##############################################################################
562
563
564
565sub new_from_ws($;$$)
566{
567
568
569 my $class = (ref($_[0]) ne "") ? ref($_[0]) : $_[0];
570 shift();
571 my $ws_path = (ref($_[0]) eq "ARRAY") ? undef : shift();
572 my $options = shift();
573 $options = [] unless (defined($options));
574
575 my($db_name,
576 $self,
577 $this);
578
579 # Check all the arguments given to us.
580
581 validate_mtn_options($options);
582 if (! defined($ws_path))
583 {
584$ws_path = getcwd();
585 }
586 get_ws_details($ws_path, \$db_name, \$ws_path);
587 validate_database($db_name);
588
589 # Actually construct the object.
590
591 $self = create_object($class);
592 $this = $class_records{$self->{$class_name}};
593 $this->{ws_path} = $ws_path;
594 $this->{ws_constructed} = 1;
595 $this->{mtn_options} = $options;
596
597 # Startup the mtn subprocess (also determining the interface version).
598
599 $self->startup();
600
601 return $self;
602
603}
604#
605##############################################################################
606#
607# Routine - DESTROY
608#
609# Description - Class destructor.
610#
611# Data - $self : The object.
612#
613##############################################################################
614
615
616
617sub DESTROY($)
618{
619
620 my $self = $_[0];
621
622 # Make sure the destructor doesn't throw any exceptions and that any
623 # existing exception status is preserved, otherwise constructor
624 # exceptions could be lost. E.g. if the constructor throws an exception
625 # after blessing the object, Perl immediately calls the destructor,
626 # which calls code that could use eval thereby resetting $@. Why not
627 # simply call bless as the last statement in the constructor? Well
628 # firstly callbacks can be called in the constructor and they have the
629 # object passed to them as their first argument and so it needs to be
630 # blessed, secondly the mtn subprocess needs to be properly closed down
631 # if there is an exception, which it won't be unless the destructor is
632 # called.
633
634 local $@;
635 eval
636 {
637eval
638{
639 $self->closedown();
640};
641delete($class_records{$self->{$class_name}});
642 };
643
644}
645#
646##############################################################################
647#
648# Routine - ancestors
649#
650# Description - Get a list of ancestors for the specified revisions.
651#
652# Data - $self : The object.
653# $list : A reference to a list that is to contain
654# the revision ids.
655# @revision_ids : The revision ids that are to have their
656# ancestors returned.
657# Return Value : True on success, otherwise false on
658# failure.
659#
660##############################################################################
661
662
663
664sub ancestors($$@)
665{
666
667 my($self, $list, @revision_ids) = @_;
668
669 return $self->mtn_command("ancestors", 0, 0, $list, @revision_ids);
670
671}
672#
673##############################################################################
674#
675# Routine - ancestry_difference
676#
677# Description - Get a list of ancestors for the specified revision, that
678# are not also ancestors for the specified old revisions.
679#
680# Data - $self : The object.
681# $list : A reference to a list that is to
682# contain the revision ids.
683# $new_revision_id : The revision id that is to have its
684# ancestors returned.
685# @old_revision_ids : The revision ids that are to have their
686# ancestors excluded from the above list.
687# Return Value : True on success, otherwise false on
688# failure.
689#
690##############################################################################
691
692
693
694sub ancestry_difference($$$;@)
695{
696
697 my($self, $list, $new_revision_id, @old_revision_ids) = @_;
698
699 return $self->mtn_command("ancestry_difference",
700 0,
701 0,
702 $list,
703 $new_revision_id,
704 @old_revision_ids);
705
706}
707#
708##############################################################################
709#
710# Routine - branches
711#
712# Description - Get a list of branches.
713#
714# Data - $self : The object.
715# $list : A reference to a list that is to contain the
716# branch names.
717# Return Value : True on success, otherwise false on failure.
718#
719##############################################################################
720
721
722
723sub branches($$)
724{
725
726 my($self, $list) = @_;
727
728 return $self->mtn_command("branches", 0, 1, $list);
729
730}
731#
732##############################################################################
733#
734# Routine - cert
735#
736# Description - Add the specified cert to the specified revision.
737#
738# Data - $self : The object.
739# $revision_id : The revision id to which the cert is to be
740# applied.
741# $name : The name of the cert to be applied.
742# $value : The value of the cert.
743# Return Value : True on success, otherwise false on failure.
744#
745##############################################################################
746
747
748
749sub cert($$$$)
750{
751
752 my($self, $revision_id, $name, $value) = @_;
753
754 my $dummy;
755
756 return $self->mtn_command("cert",
757 1,
758 1,
759 \$dummy,
760 $revision_id,
761 $name,
762 $value);
763
764}
765#
766##############################################################################
767#
768# Routine - certs
769#
770# Description - Get all the certs for the specified revision.
771#
772# Data - $self : The object.
773# $ref : A reference to a buffer or an array that is
774# to contain the output from this command.
775# $revision_id : The id of the revision that is to have its
776# certs returned.
777# Return Value : True on success, otherwise false on failure.
778#
779##############################################################################
780
781
782
783sub certs($$$)
784{
785
786 my($self, $ref, $revision_id) = @_;
787
788 # Run the command and get the data, either as one lump or as a structured
789 # list.
790
791 if (ref($ref) eq "SCALAR")
792 {
793return $self->mtn_command("certs", 0, 1, $ref, $revision_id);
794 }
795 else
796 {
797
798my($i,
799 @lines);
800
801if (! $self->mtn_command("certs", 0, 1, \@lines, $revision_id))
802{
803 return;
804}
805
806# Reformat the data into a structured array.
807
808for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
809{
810 if ($lines[$i] =~ m/$io_stanza_re/)
811 {
812my $kv_record;
813
814# Get the next key-value record.
815
816parse_kv_record(\@lines, \$i, \%certs_keys, \$kv_record);
817-- $i;
818
819# Validate it in terms of expected fields and store.
820
821foreach my $key ("key", "name", "signature", "trust", "value")
822{
823 &$croaker("Corrupt certs list, expected " . $key
824 . " field but did not find it")
825unless (exists($kv_record->{$key}));
826}
827push(@$ref, $kv_record);
828 }
829}
830
831return 1;
832
833 }
834
835}
836#
837##############################################################################
838#
839# Routine - children
840#
841# Description - Get a list of children for the specified revision.
842#
843# Data - $self : The object.
844# $list : A reference to a list that is to contain the
845# revision ids.
846# $revision_id : The revision id that is to have its children
847# returned.
848# Return Value : True on success, otherwise false on failure.
849#
850##############################################################################
851
852
853
854sub children($$$)
855{
856
857 my($self, $list, @revision_ids) = @_;
858
859 return $self->mtn_command("children", 0, 0, $list, @revision_ids);
860
861}
862#
863##############################################################################
864#
865# Routine - common_ancestors
866#
867# Description - Get a list of revisions that are all ancestors of the
868# specified revision.
869#
870# Data - $self : The object.
871# $list : A reference to a list that is to contain
872# the revision ids.
873# @revision_ids : The revision ids that are to have their
874# common ancestors returned.
875# Return Value : True on success, otherwise false on
876# failure.
877#
878##############################################################################
879
880
881
882sub common_ancestors($$@)
883{
884
885 my($self, $list, @revision_ids) = @_;
886
887 return $self->mtn_command("common_ancestors", 0, 0, $list, @revision_ids);
888
889}
890#
891##############################################################################
892#
893# Routine - content_diff
894#
895# Description - Get the difference between the two specified revisions,
896# optionally limiting the output by using the specified
897# options and file restrictions. If the second revision id is
898# undefined then the workspace's current revision is used. If
899# both revision ids are undefined then the workspace's
900# current and base revisions are used. If no file names are
901# listed then differences in all files are reported.
902#
903# Data - $self : The object.
904# $buffer : A reference to a buffer that is to contain
905# the output from this command.
906# $options : A reference to a list containing the
907# options to use.
908# $revision_id1 : The first revision id to compare against.
909# $revision_id2 : The second revision id to compare against.
910# @file_names : The list of file names that are to be
911# reported on.
912# Return Value : True on success, otherwise false on
913# failure.
914#
915##############################################################################
916
917
918
919sub content_diff($$;$$$@)
920{
921
922 my($self, $buffer, $options, $revision_id1, $revision_id2, @file_names)
923= @_;
924
925 my @opts;
926
927 # Process any options.
928
929 if (defined($options))
930 {
931for (my $i = 0; $i < scalar(@$options); ++ $i)
932{
933 if ($$options[$i] eq "reverse"
934|| $$options[$i] eq "with-header"
935|| $$options[$i] eq "without-header")
936 {
937push(@opts, {key => $$options[$i], value => ""});
938 }
939 else
940 {
941push(@opts, {key => $$options[$i], value => $$options[++ $i]});
942 }
943}
944 }
945 push(@opts, {key => "r", value => $revision_id1})
946if (defined($revision_id1));
947 push(@opts, {key => "r", value => $revision_id2})
948if (defined($revision_id2));
949
950 return $self->mtn_command_with_options("content_diff",
951 1,
952 1,
953 $buffer,
954 \@opts,
955 @file_names);
956
957}
958#
959##############################################################################
960#
961# Routine - db_get
962#
963# Description - Get the value of a database variable.
964#
965# Data - $self : The object.
966# $buffer : A reference to a buffer that is to contain
967# the output from this command.
968# $domain : The domain of the database variable.
969# $name : The name of the variable to fetch.
970# Return Value : True on success, otherwise false on failure.
971#
972##############################################################################
973
974
975
976sub db_get($$$$)
977{
978
979 my($self, $buffer, $domain, $name) = @_;
980
981 return $self->mtn_command("db_get", 1, 1, $buffer, $domain, $name);
982
983}
984#
985##############################################################################
986#
987# Routine - descendents
988#
989# Description - Get a list of descendents for the specified revisions.
990#
991# Data - $self : The object.
992# $list : A reference to a list that is to contain
993# the revision ids.
994# @revision_ids : The revision ids that are to have their
995# descendents returned.
996# Return Value : True on success, otherwise false on
997# failure.
998#
999##############################################################################
1000
1001
1002
1003sub descendents($$@)
1004{
1005
1006 my($self, $list, @revision_ids) = @_;
1007
1008 return $self->mtn_command("descendents", 0, 0, $list, @revision_ids);
1009
1010}
1011#
1012##############################################################################
1013#
1014# Routine - drop_attribute
1015#
1016# Description - Drop attributes from the specified file or directory,
1017# optionally limiting it to the specified attribute.
1018#
1019# Data - $self : The object.
1020# $path : The name of the file or directory that is to
1021# have an attribute dropped.
1022# $key : The name of the attribute that as to be
1023# dropped.
1024# Return Value : True on success, otherwise false on failure.
1025#
1026##############################################################################
1027
1028
1029
1030sub drop_attribute($$$)
1031{
1032
1033 my($self, $path, $key) = @_;
1034
1035 my $dummy;
1036
1037 return $self->mtn_command("drop_attribute", 1, 0, \$dummy, $path, $key);
1038
1039}
1040#
1041##############################################################################
1042#
1043# Routine - drop_db_variables
1044#
1045# Description - Drop variables from the specified domain, optionally
1046# limiting it to the specified variable.
1047#
1048# Data - $self : The object.
1049# $domain : The name of the domain that is to have one
1050# or all of its variables dropped.
1051# $name : The name of the variable that is to be
1052# dropped.
1053# Return Value : True on success, otherwise false on failure.
1054#
1055##############################################################################
1056
1057
1058
1059sub drop_db_variables($$;$)
1060{
1061
1062 my($self, $domain, $name) = @_;
1063
1064 my $dummy;
1065
1066 return $self->mtn_command("drop_db_variables",
1067 1,
1068 0,
1069 \$dummy,
1070 $domain,
1071 $name);
1072
1073}
1074#
1075##############################################################################
1076#
1077# Routine - erase_ancestors
1078#
1079# Description - For a given list of revisions, weed out those that are
1080# ancestors to other revisions specified within the list.
1081#
1082# Data - $self : The object.
1083# $list : A reference to a list that is to contain
1084# the revision ids.
1085# @revision_ids : The revision ids that are to have their
1086# descendents returned.
1087# Return Value : True on success, otherwise false on
1088# failure.
1089#
1090##############################################################################
1091
1092
1093
1094sub erase_ancestors($$;@)
1095{
1096
1097 my($self, $list, @revision_ids) = @_;
1098
1099 return $self->mtn_command("erase_ancestors", 0, 0, $list, @revision_ids);
1100
1101}
1102#
1103##############################################################################
1104#
1105# Routine - file_merge
1106#
1107# Description - Get the result of merging two files, both of which are on
1108# separate revisions.
1109#
1110# Data - $self : The object.
1111# $buffer : A reference to a buffer that is to
1112# contain the output from this command.
1113# $left_revision_id : The left hand revision id.
1114# $left_file_name : The name of the file on the left hand
1115# revision.
1116# $right_revision_id : The right hand revision id.
1117# $right_file_name : The name of the file on the right hand
1118# revision.
1119# Return Value : True on success, otherwise false on
1120# failure.
1121#
1122##############################################################################
1123
1124
1125
1126sub file_merge($$$$$$)
1127{
1128
1129 my($self,
1130 $buffer,
1131 $left_revision_id,
1132 $left_file_name,
1133 $right_revision_id,
1134 $right_file_name) = @_;
1135
1136 return $self->mtn_command("file_merge",
1137 1,
1138 1,
1139 $buffer,
1140 $left_revision_id,
1141 $left_file_name,
1142 $right_revision_id,
1143 $right_file_name);
1144
1145}
1146#
1147##############################################################################
1148#
1149# Routine - genkey
1150#
1151# Description - Generate a new key for use within the database.
1152#
1153# Data - $self : The object.
1154# $ref : A reference to a buffer or a hash that is to
1155# contain the output from this command.
1156# $key_id : The key id for the new key.
1157# $pass_phrase : The pass phrase for the key.
1158# Return Value : True on success, otherwise false on failure.
1159#
1160##############################################################################
1161
1162
1163
1164sub genkey($$$$)
1165{
1166
1167 my($self, $ref, $key_id, $pass_phrase) = @_;
1168
1169 # Run the command and get the data, either as one lump or as a structured
1170 # list.
1171
1172 if (ref($ref) eq "SCALAR")
1173 {
1174return $self->mtn_command("genkey", 1, 1, $ref, $key_id, $pass_phrase);
1175 }
1176 else
1177 {
1178
1179my($i,
1180 $kv_record,
1181 @lines);
1182
1183if (! $self->mtn_command("genkey",
1184 1,
1185 1,
1186 \@lines,
1187 $key_id,
1188 $pass_phrase))
1189{
1190 return;
1191}
1192
1193# Reformat the data into a structured record.
1194
1195# Get the key-value record.
1196
1197$i = 0;
1198parse_kv_record(\@lines, \$i, \%genkey_keys, \$kv_record);
1199
1200# Copy across the fields.
1201
1202%$ref = ();
1203foreach my $key (CORE::keys(%$kv_record))
1204{
1205 $$ref{$key} = $kv_record->{$key};
1206}
1207
1208return 1;
1209
1210 }
1211
1212}
1213#
1214##############################################################################
1215#
1216# Routine - get_attributes
1217#
1218# Description - Get the attributes of the specified file.
1219#
1220# Data - $self : The object.
1221# $ref : A reference to a buffer or an array that is
1222# to contain the output from this command.
1223# $file_name : The name of the file that is to be reported
1224# on.
1225# Return Value : True on success, otherwise false on failure.
1226#
1227##############################################################################
1228
1229
1230
1231sub get_attributes($$$)
1232{
1233
1234 my($self, $ref, $file_name) = @_;
1235
1236 my $cmd;
1237
1238 # This command was renamed in version 0.36 (i/f version 5.x).
1239
1240 if ($self->supports(MTN_GET_ATTRIBUTES))
1241 {
1242$cmd = "get_attributes";
1243 }
1244 else
1245 {
1246$cmd = "attributes";
1247 }
1248
1249 # Run the command and get the data, either as one lump or as a structured
1250 # list.
1251
1252 if (ref($ref) eq "SCALAR")
1253 {
1254return $self->mtn_command($cmd, 1, 1, $ref, $file_name);
1255 }
1256 else
1257 {
1258
1259my($i,
1260 @lines);
1261
1262if (! $self->mtn_command($cmd, 1, 1, \@lines, $file_name))
1263{
1264 return;
1265}
1266
1267# Reformat the data into a structured array.
1268
1269for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
1270{
1271 if ($lines[$i] =~ m/$io_stanza_re/)
1272 {
1273my $kv_record;
1274
1275# Get the next key-value record.
1276
1277parse_kv_record(\@lines,
1278\$i,
1279\%get_attributes_keys,
1280\$kv_record);
1281-- $i;
1282
1283# Validate it in terms of expected fields and store.
1284
1285if (exists($kv_record->{attr}))
1286{
1287 &$croaker("Corrupt attributes list, expected state field "
1288 . "but did not find it")
1289unless (exists($kv_record->{state}));
1290 push(@$ref, {attribute => $kv_record->{attr}->[0],
1291 value => $kv_record->{attr}->[1],
1292 state => $kv_record->{state}});
1293}
1294 }
1295}
1296
1297return 1;
1298
1299 }
1300
1301}
1302#
1303##############################################################################
1304#
1305# Routine - get_base_revision_id
1306#
1307# Description - Get the id of the revision upon which the workspace is
1308# based.
1309#
1310# Data - $self : The object.
1311# $buffer : A reference to a buffer that is to contain
1312# the output from this command.
1313# Return Value : True on success, otherwise false on failure.
1314#
1315##############################################################################
1316
1317
1318
1319sub get_base_revision_id($$)
1320{
1321
1322 my($self, $buffer) = @_;
1323
1324 my @list;
1325
1326 $$buffer = "";
1327 if (! $self->mtn_command("get_base_revision_id", 0, 0, \@list))
1328 {
1329return;
1330 }
1331 $$buffer = $list[0];
1332
1333 return 1;
1334
1335}
1336#
1337##############################################################################
1338#
1339# Routine - get_content_changed
1340#
1341# Description - Get a list of revisions in which the content was most
1342# recently changed, relative to the specified revision.
1343#
1344# Data - $self : The object.
1345# $list : A reference to a list that is to contain the
1346# revision ids.
1347# $revision_id : The id of the revision of the manifest that
1348# is to be returned.
1349# $file_name : The name of the file that is to be reported
1350# on.
1351# Return Value : True on success, otherwise false on failure.
1352#
1353##############################################################################
1354
1355
1356
1357sub get_content_changed($$$$)
1358{
1359
1360 my($self, $list, $revision_id, $file_name) = @_;
1361
1362 my($i,
1363 @lines);
1364
1365 # Run the command and get the data.
1366
1367 if (! $self->mtn_command("get_content_changed",
1368 1,
1369 0,
1370 \@lines,
1371 $revision_id,
1372 $file_name))
1373 {
1374return;
1375 }
1376
1377 # Reformat the data into a list.
1378
1379 for ($i = 0, @$list = (); $i < scalar(@lines); ++ $i)
1380 {
1381if ($lines[$i] =~ m/^ *content_mark \[([0-9a-f]+)\]$/)
1382{
1383 push(@$list, $1);
1384}
1385 }
1386
1387 return 1;
1388
1389}
1390#
1391##############################################################################
1392#
1393# Routine - get_corresponding_path
1394#
1395# Description - For the specified file name in the specified source
1396# revision, return the corresponding file name for the
1397# specified target revision.
1398#
1399# Data - $self : The object.
1400# $buffer : A reference to a buffer that is to
1401# contain the output from this command.
1402# $source_revision_id : The source revision id.
1403# $file_name : The name of the file that is to be
1404# searched for.
1405# $target_revision_id : The target revision id.
1406# Return Value : True on success, otherwise false on
1407# failure.
1408#
1409##############################################################################
1410
1411
1412
1413sub get_corresponding_path($$$$$)
1414{
1415
1416 my($self, $buffer, $source_revision_id, $file_name, $target_revision_id)
1417= @_;
1418
1419 my($i,
1420 @lines);
1421
1422 # Run the command and get the data.
1423
1424 if (! $self->mtn_command("get_corresponding_path",
1425 1,
1426 1,
1427 \@lines,
1428 $source_revision_id,
1429 $file_name,
1430 $target_revision_id))
1431 {
1432return;
1433 }
1434
1435 # Extract the file name.
1436
1437 for ($i = 0, $$buffer = ""; $i < scalar(@lines); ++ $i)
1438 {
1439if ($lines[$i] =~ m/^ *file \"/)
1440{
1441 get_quoted_value(\@lines, \$i, $buffer);
1442 $$buffer = unescape($$buffer);
1443}
1444 }
1445
1446 return 1;
1447
1448}
1449#
1450##############################################################################
1451#
1452# Routine - get_current_revision
1453#
1454# Description - Get the revision information for the current revision,
1455# optionally limiting the output by using the specified
1456# options and file restrictions.
1457#
1458# Data - $self : The object.
1459# $ref : A reference to a buffer or an array that is
1460# to contain the output from this command.
1461# $options : A reference to a list containing the options
1462# to use.
1463# @paths : A list of files or directories that are to
1464# be reported on instead of the entire
1465# workspace.
1466# Return Value : True on success, otherwise false on failure.
1467#
1468##############################################################################
1469
1470
1471
1472sub get_current_revision($$;$@)
1473{
1474
1475 my($self, $ref, $options, @paths) = @_;
1476
1477 my($i,
1478 @opts);
1479
1480 # Process any options.
1481
1482 if (defined($options))
1483 {
1484for ($i = 0; $i < scalar(@$options); ++ $i)
1485{
1486 if ($$options[$i] eq "depth" || $$options[$i] eq "exclude")
1487 {
1488push(@opts, {key => $$options[$i], value => $$options[++ $i]});
1489 }
1490 else
1491 {
1492push(@opts, {key => $$options[$i], value => ""});
1493 }
1494}
1495 }
1496
1497 # Run the command and get the data, either as one lump or as a structured
1498 # list.
1499
1500 if (ref($ref) eq "SCALAR")
1501 {
1502return $self->mtn_command_with_options("get_current_revision",
1503 1,
1504 1,
1505 $ref,
1506 \@opts,
1507 @paths);
1508 }
1509 else
1510 {
1511
1512my @lines;
1513
1514if (! $self->mtn_command_with_options("get_current_revision",
1515 1,
1516 1,
1517 \@lines,
1518 \@opts,
1519 @paths))
1520{
1521 return;
1522}
1523parse_revision_data($ref, \@lines);
1524
1525return 1;
1526
1527 }
1528
1529}
1530#
1531##############################################################################
1532#
1533# Routine - get_current_revision_id
1534#
1535# Description - Get the id of the revision that would be created if an
1536# unrestricted commit was done in the workspace.
1537#
1538# Data - $self : The object.
1539# $buffer : A reference to a buffer that is to contain
1540# the output from this command.
1541# Return Value : True on success, otherwise false on failure.
1542#
1543##############################################################################
1544
1545
1546
1547sub get_current_revision_id($$)
1548{
1549
1550 my($self, $buffer) = @_;
1551
1552 my @list;
1553
1554 $$buffer = "";
1555 if (! $self->mtn_command("get_current_revision_id", 0, 0, \@list))
1556 {
1557return;
1558 }
1559 $$buffer = $list[0];
1560
1561 return 1;
1562
1563}
1564#
1565##############################################################################
1566#
1567# Routine - get_db_variables
1568#
1569# Description - Get the variables stored in the database, optionally
1570# limiting it to the specified domain.
1571#
1572# Data - $self : The object.
1573# $ref : A reference to a buffer or an array that is
1574# to contain the output from this command.
1575# $domain : The name of the domain that is to have its
1576# variables listed.
1577# Return Value : True on success, otherwise false on failure.
1578#
1579##############################################################################
1580
1581
1582
1583sub get_db_variables($$;$)
1584{
1585
1586 my($self, $ref, $domain) = @_;
1587
1588 # Run the command and get the data, either as one lump or as a structured
1589 # list.
1590
1591 if (ref($ref) eq "SCALAR")
1592 {
1593return $self->mtn_command("get_db_variables", 1, 1, $ref, $domain);
1594 }
1595 else
1596 {
1597
1598my($domain_name,
1599 $i,
1600 @lines,
1601 $name,
1602 $value);
1603
1604if (! $self->mtn_command("get_db_variables", 1, 1, \@lines, $domain))
1605{
1606 return;
1607}
1608
1609# Reformat the data into a structured array. We cannot use
1610# parse_kv_record here as we can have multiple `entry' fields in each
1611# record block.
1612
1613for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
1614{
1615 if ($lines[$i] =~ m/^ *domain \"/)
1616 {
1617get_quoted_value(\@lines, \$i, \$domain_name);
1618 }
1619 if ($lines[$i] =~ m/^ *entry \"(.+)\"$/)
1620 {
1621($name, $value) = split(/\" \"/, $1);
1622if (defined($domain_name))
1623{
1624 push(@$ref, {domain => unescape($domain_name),
1625 name => unescape($name),
1626 value => unescape($value)});
1627}
1628else
1629{
1630 &$croaker("Corrupt variables list, expected domain field "
1631 . "but did not find it");
1632}
1633 }
1634}
1635
1636return 1;
1637
1638 }
1639
1640}
1641#
1642##############################################################################
1643#
1644# Routine - get_file
1645#
1646# Description - Get the contents of the file referenced by the specified
1647# file id.
1648#
1649# Data - $self : The object.
1650# $buffer : A reference to a buffer that is to contain
1651# the output from this command.
1652# $file_id : The file id of the file that is to be
1653# returned.
1654# Return Value : True on success, otherwise false on failure.
1655#
1656##############################################################################
1657
1658
1659
1660sub get_file($$$)
1661{
1662
1663 my($self, $buffer, $file_id) = @_;
1664
1665 return $self->mtn_command("get_file", 0, 0, $buffer, $file_id);
1666
1667}
1668#
1669##############################################################################
1670#
1671# Routine - get_file_of
1672#
1673# Description - Get the contents of the specified file under the specified
1674# revision. If the revision id is undefined then the current
1675# workspace revision is used.
1676#
1677# Data - $self : The object.
1678# $buffer : A reference to a buffer that is to contain
1679# the output from this command.
1680# $file_name : The name of the file to be fetched.
1681# $revision_id : The revision id upon which the file contents
1682# are to be based.
1683# Return Value : True on success, otherwise false on failure.
1684#
1685##############################################################################
1686
1687
1688
1689sub get_file_of($$$;$)
1690{
1691
1692 my($self, $buffer, $file_name, $revision_id) = @_;
1693
1694 my @opts;
1695
1696 push(@opts, {key => "r", value => $revision_id})
1697if (defined($revision_id));
1698
1699 return $self->mtn_command_with_options("get_file_of",
1700 1,
1701 0,
1702 $buffer,
1703 \@opts,
1704 $file_name);
1705
1706}
1707#
1708##############################################################################
1709#
1710# Routine - get_manifest_of
1711#
1712# Description - Get the manifest for the current or specified revision.
1713#
1714# Data - $self : The object.
1715# $ref : A reference to a buffer or an array that is
1716# to contain the output from this command.
1717# $revision_id : The revision id which is to have its
1718# manifest returned.
1719# Return Value : True on success, otherwise false on failure.
1720#
1721##############################################################################
1722
1723
1724
1725sub get_manifest_of($$;$)
1726{
1727
1728 my($self, $ref, $revision_id) = @_;
1729
1730 # Run the command and get the data, either as one lump or as a structured
1731 # list.
1732
1733 if (ref($ref) eq "SCALAR")
1734 {
1735return $self->mtn_command("get_manifest_of", 0, 1, $ref, $revision_id);
1736 }
1737 else
1738 {
1739
1740my($attrs,
1741 $i,
1742 $id,
1743 $key,
1744 @lines,
1745 $name,
1746 $type,
1747 $value);
1748
1749if (! $self->mtn_command("get_manifest_of",
1750 0,
1751 1,
1752 \@lines,
1753 $revision_id))
1754{
1755 return;
1756}
1757
1758# Reformat the data into a structured array. We cannot use
1759# parse_kv_record here as we can have multiple `attr' fields in each
1760# record block.
1761
1762for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
1763{
1764 $type = undef;
1765 if ($lines[$i] =~ m/^ *file \"/)
1766 {
1767$type = "file";
1768get_quoted_value(\@lines, \$i, \$name);
1769if ($lines[++ $i] =~ m/^ *content \[([0-9a-f]+)\]$/)
1770{
1771 $id = $1;
1772}
1773else
1774{
1775 &$croaker("Corrupt manifest, expected content field but "
1776 . "did not find it");
1777}
1778 }
1779 if ($lines[$i] =~ m/^ *dir \"/)
1780 {
1781$type = "directory";
1782get_quoted_value(\@lines, \$i, \$name);
1783 }
1784 for ($attrs = [];
1785 ($i + 1) < scalar(@lines)
1786 && $lines[$i + 1] =~ m/^ *attr \"(.+)\"$/;)
1787 {
1788++ $i;
1789($key, $value) = split(/\" \"/, $1);
1790push(@$attrs, {attribute => unescape($key),
1791 value => unescape($value)});
1792 }
1793 if (defined($type))
1794 {
1795if ($type eq "file")
1796{
1797 push(@$ref, {type => $type,
1798 name => unescape($name),
1799 file_id => $id,
1800 attributes => $attrs});
1801}
1802else
1803{
1804 push(@$ref, {type => $type,
1805 name => unescape($name),
1806 attributes => $attrs});
1807}
1808 }
1809}
1810
1811return 1;
1812
1813 }
1814
1815}
1816#
1817##############################################################################
1818#
1819# Routine - get_option
1820#
1821# Description - Get the value of an option stored in a workspace's _MTN
1822# directory.
1823#
1824# Data - $self : The object.
1825# $buffer : A reference to a buffer that is to contain
1826# the output from this command.
1827# $option_name : The name of the option to be fetched.
1828# Return Value : True on success, otherwise false on failure.
1829#
1830##############################################################################
1831
1832
1833
1834sub get_option($$$)
1835{
1836
1837 my($self, $buffer, $option_name) = @_;
1838
1839 if (! $self->mtn_command("get_option", 1, 1, $buffer, $option_name))
1840 {
1841return;
1842 }
1843 chomp($$buffer);
1844
1845 return 1;
1846
1847}
1848#
1849##############################################################################
1850#
1851# Routine - get_revision
1852#
1853# Description - Get the revision information for the current or specified
1854# revision.
1855#
1856# Data - $self : The object.
1857# $ref : A reference to a buffer or an array that is
1858# to contain the output from this command.
1859# $revision_id : The revision id which is to have its data
1860# returned.
1861# Return Value : True on success, otherwise false on failure.
1862#
1863##############################################################################
1864
1865
1866
1867sub get_revision($$$)
1868{
1869
1870 my($self, $ref, $revision_id) = @_;
1871
1872 # Run the command and get the data, either as one lump or as a structured
1873 # list.
1874
1875 if (ref($ref) eq "SCALAR")
1876 {
1877return $self->mtn_command("get_revision", 0, 1, $ref, $revision_id);
1878 }
1879 else
1880 {
1881
1882my @lines;
1883
1884if (! $self->mtn_command("get_revision", 0, 1, \@lines, $revision_id))
1885{
1886 return;
1887}
1888parse_revision_data($ref, \@lines);
1889
1890return 1;
1891
1892 }
1893
1894}
1895#
1896##############################################################################
1897#
1898# Routine - get_workspace_root
1899#
1900# Description - Get the absolute path for the current workspace's root
1901# directory.
1902#
1903# Data - $self : The object.
1904# $buffer : A reference to a buffer that is to contain
1905# the output from this command.
1906# Return Value : True on success, otherwise false on failure.
1907#
1908##############################################################################
1909
1910
1911
1912sub get_workspace_root($$)
1913{
1914
1915 my($self, $buffer) = @_;
1916
1917 if (! $self->mtn_command("get_workspace_root", 0, 1, $buffer))
1918 {
1919return;
1920 }
1921 chomp($$buffer);
1922
1923 return 1;
1924
1925}
1926#
1927##############################################################################
1928#
1929# Routine - graph
1930#
1931# Description - Get a complete ancestry graph of the database.
1932#
1933# Data - $self : The object.
1934# $ref : A reference to a buffer or an array that is
1935# to contain the output from this command.
1936# Return Value : True on success, otherwise false on failure.
1937#
1938##############################################################################
1939
1940
1941
1942sub graph($$)
1943{
1944
1945 my($self, $ref) = @_;
1946
1947 # Run the command and get the data, either as one lump or as a structured
1948 # list.
1949
1950 if (ref($ref) eq "SCALAR")
1951 {
1952return $self->mtn_command("graph", 0, 0, $ref);
1953 }
1954 else
1955 {
1956
1957my($i,
1958 @lines,
1959 @parent_ids);
1960
1961if (! $self->mtn_command("graph", 0, 0, \@lines))
1962{
1963 return;
1964}
1965for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
1966{
1967 @parent_ids = split(/ /, $lines[$i]);
1968 $$ref[$i] = {revision_id => shift(@parent_ids),
1969 parent_ids => [@parent_ids]};
1970}
1971
1972return 1;
1973
1974 }
1975
1976}
1977#
1978##############################################################################
1979#
1980# Routine - heads
1981#
1982# Description - Get a list of revision ids that are heads on the specified
1983# branch. If no branch is given then the workspace's branch
1984# is used.
1985#
1986# Data - $self : The object.
1987# $list : A reference to a list that is to contain the
1988# revision ids.
1989# $branch_name : The name of the branch that is to have its
1990# heads returned.
1991# Return Value : True on success, otherwise false on failure.
1992#
1993##############################################################################
1994
1995
1996
1997sub heads($$;$)
1998{
1999
2000 my($self, $list, $branch_name) = @_;
2001
2002 return $self->mtn_command("heads", 1, 0, $list, $branch_name);
2003
2004}
2005#
2006##############################################################################
2007#
2008# Routine - identify
2009#
2010# Description - Get the file id, i.e. hash, of the specified file.
2011#
2012# Data - $self : The object.
2013# $buffer : A reference to a buffer that is to contain
2014# the output from this command.
2015# $file_name : The name of the file that is to have its id
2016# returned.
2017# Return Value : True on success, otherwise false on failure.
2018#
2019##############################################################################
2020
2021
2022
2023sub identify($$$)
2024{
2025
2026 my($self, $buffer, $file_name) = @_;
2027
2028 my @list;
2029
2030 $$buffer = "";
2031 if (! $self->mtn_command("identify", 1, 0, \@list, $file_name))
2032 {
2033return;
2034 }
2035 $$buffer = $list[0];
2036
2037 return 1;
2038
2039}
2040#
2041##############################################################################
2042#
2043# Routine - interface_version
2044#
2045# Description - Get the version of the mtn automate interface.
2046#
2047# Data - $self : The object.
2048# $buffer : A reference to a buffer that is to contain
2049# the output from this command.
2050# Return Value : True on success, otherwise false on failure.
2051#
2052##############################################################################
2053
2054
2055
2056sub interface_version($$)
2057{
2058
2059 my($self, $buffer) = @_;
2060
2061 my @list;
2062
2063 $$buffer = "";
2064 if (! $self->mtn_command("interface_version", 0, 0, \@list))
2065 {
2066return;
2067 }
2068 $$buffer = $list[0];
2069
2070 return 1;
2071
2072}
2073#
2074##############################################################################
2075#
2076# Routine - inventory
2077#
2078# Description - Get the inventory for the current workspace, optionally
2079# limiting the output by using the specified options and file
2080# restrictions.
2081#
2082# Data - $self : The object.
2083# $ref : A reference to a buffer or an array that is
2084# to contain the output from this command.
2085# $options : A reference to a list containing the options
2086# to use.
2087# @paths : A list of files or directories that are to
2088# be reported on instead of the entire
2089# workspace.
2090# Return Value : True on success, otherwise false on failure.
2091#
2092##############################################################################
2093
2094
2095
2096sub inventory($$;$@)
2097{
2098
2099 my($self, $ref, $options, @paths) = @_;
2100
2101 my @opts;
2102
2103 # Process any options.
2104
2105 if (defined($options))
2106 {
2107for (my $i = 0; $i < scalar(@$options); ++ $i)
2108{
2109 if ($$options[$i] eq "depth" || $$options[$i] eq "exclude")
2110 {
2111push(@opts, {key => $$options[$i], value => $$options[++ $i]});
2112 }
2113 else
2114 {
2115push(@opts, {key => $$options[$i], value => ""});
2116 }
2117}
2118 }
2119
2120 # Run the command and get the data, either as one lump or as a structured
2121 # list.
2122
2123 if (ref($ref) eq "SCALAR")
2124 {
2125return $self->mtn_command_with_options("inventory",
2126 1,
2127 1,
2128 $ref,
2129 \@opts,
2130 @paths);
2131 }
2132 else
2133 {
2134
2135my @lines;
2136
2137if (! $self->mtn_command_with_options("inventory",
2138 1,
2139 1,
2140 \@lines,
2141 \@opts,
2142 @paths))
2143{
2144 return;
2145}
2146
2147# The output format of this command was switched over to a basic_io
2148# stanza in 0.37 (i/f version 6.x).
2149
2150if ($self->supports(MTN_INVENTORY_IN_IO_STANZA_FORMAT))
2151{
2152
2153 my $i;
2154
2155 # Reformat the data into a structured array.
2156
2157 for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2158 {
2159if ($lines[$i] =~ m/$io_stanza_re/)
2160{
2161 my $kv_record;
2162
2163 # Get the next key-value record and store it in the list.
2164
2165 parse_kv_record(\@lines,
2166 \$i,
2167 \%inventory_keys,
2168 \$kv_record);
2169 -- $i;
2170 if (exists($kv_record->{birth}))
2171 {
2172$kv_record->{birth_id} = $kv_record->{birth};
2173delete($kv_record->{birth});
2174 }
2175 push(@$ref, $kv_record);
2176}
2177 }
2178
2179}
2180else
2181{
2182
2183 my $i;
2184
2185 # Reformat the data into a structured array.
2186
2187 for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2188 {
2189if ($lines[$i] =~ m/^([A-Z ]{3}) (\d+) (\d+) (.+)$/)
2190{
2191 push(@$ref, {status => $1,
2192 crossref_one => $2,
2193 crossref_two => $3,
2194 name => $4});
2195}
2196 }
2197
2198}
2199
2200return 1;
2201
2202 }
2203
2204}
2205#
2206##############################################################################
2207#
2208# Routine - keys
2209#
2210# Description - Get a list of all the keys known to mtn.
2211#
2212# Data - $self : The object.
2213# $ref : A reference to a buffer or an array that is
2214# to contain the output from this command.
2215# Return Value : True on success, otherwise false on failure.
2216#
2217##############################################################################
2218
2219
2220
2221sub keys($$)
2222{
2223
2224 my($self, $ref) = @_;
2225
2226 # Run the command and get the data, either as one lump or as a structured
2227 # list.
2228
2229 if (ref($ref) eq "SCALAR")
2230 {
2231return $self->mtn_command("keys", 0, 1, $ref);
2232 }
2233 else
2234 {
2235
2236my($i,
2237 @lines,
2238 @valid_fields);
2239
2240if (! $self->mtn_command("keys", 0, 1, \@lines))
2241{
2242 return;
2243}
2244
2245# Build up a list of valid fields depending upon the version of
2246# Monotone in use.
2247
2248push(@valid_fields, "given_name", "local_name")
2249 if ($self->supports(MTN_HASHED_SIGNATURES));
2250if ($self->supports(MTN_COMMON_KEY_HASH))
2251{
2252 push(@valid_fields, "hash");
2253}
2254else
2255{
2256 push(@valid_fields, "public_hash");
2257}
2258push(@valid_fields, "public_location");
2259
2260# Reformat the data into a structured array.
2261
2262for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2263{
2264 if ($lines[$i] =~ m/$io_stanza_re/)
2265 {
2266my $kv_record;
2267
2268# Get the next key-value record.
2269
2270parse_kv_record(\@lines, \$i, \%keys_keys, \$kv_record);
2271-- $i;
2272
2273# Validate it in terms of expected fields and store.
2274
2275foreach my $key (@valid_fields)
2276{
2277 &$croaker("Corrupt keys list, expected " . $key
2278 . " field but did not find it")
2279unless (exists($kv_record->{$key}));
2280}
2281push(@$ref, $kv_record);
2282 }
2283}
2284
2285return 1;
2286
2287 }
2288
2289}
2290#
2291##############################################################################
2292#
2293# Routine - leaves
2294#
2295# Description - Get a list of leaf revisions.
2296#
2297# Data - $self : The object.
2298# $list : A reference to a list that is to contain the
2299# revision ids.
2300# Return Value : True on success, otherwise false on failure.
2301#
2302##############################################################################
2303
2304
2305
2306sub leaves($$)
2307{
2308
2309 my($self, $list) = @_;
2310
2311 return $self->mtn_command("leaves", 0, 0, $list);
2312
2313}
2314#
2315##############################################################################
2316#
2317# Routine - lua
2318#
2319# Description - Call the specified LUA function with any required
2320# arguments.
2321#
2322# Data - $self : The object.
2323# $buffer : A reference to a buffer that is to contain
2324# the output from this command.
2325# $lua_function : The name of the LUA function that is to be
2326# called.
2327# @arguments : A list of arguments that are to be passed
2328# to the LUA function.
2329# Return Value : True on success, otherwise false on
2330# failure.
2331#
2332##############################################################################
2333
2334
2335
2336sub lua($$$;@)
2337{
2338
2339 my($self, $buffer, $lua_function, @arguments) = @_;
2340
2341 return $self->mtn_command("lua", 1, 1, $buffer, $lua_function, @arguments);
2342
2343}
2344#
2345##############################################################################
2346#
2347# Routine - packet_for_fdata
2348#
2349# Description - Get the contents of the file referenced by the specified
2350# file id in packet format.
2351#
2352# Data - $self : The object.
2353# $buffer : A reference to a buffer that is to contain
2354# the output from this command.
2355# $file_id : The file id of the file that is to be
2356# returned.
2357# Return Value : True on success, otherwise false on failure.
2358#
2359##############################################################################
2360
2361
2362
2363sub packet_for_fdata($$$)
2364{
2365
2366 my($self, $buffer, $file_id) = @_;
2367
2368 return $self->mtn_command("packet_for_fdata", 0, 0, $buffer, $file_id);
2369
2370}
2371#
2372##############################################################################
2373#
2374# Routine - packet_for_fdelta
2375#
2376# Description - Get the file delta between the two files referenced by the
2377# specified file ids in packet format.
2378#
2379# Data - $self : The object.
2380# $buffer : A reference to a buffer that is to contain
2381# the output from this command.
2382# $from_file_id : The file id of the file that is to be used
2383# as the base in the delta operation.
2384# $to_file_id : The file id of the file that is to be used
2385# as the target in the delta operation.
2386# Return Value : True on success, otherwise false on
2387# failure.
2388#
2389##############################################################################
2390
2391
2392
2393sub packet_for_fdelta($$$$)
2394{
2395
2396 my($self, $buffer, $from_file_id, $to_file_id) = @_;
2397
2398 return $self->mtn_command("packet_for_fdelta",
2399 0,
2400 0,
2401 $buffer,
2402 $from_file_id,
2403 $to_file_id);
2404
2405}
2406#
2407##############################################################################
2408#
2409# Routine - packet_for_rdata
2410#
2411# Description - Get the contents of the revision referenced by the
2412# specified revision id in packet format.
2413#
2414# Data - $self : The object.
2415# $buffer : A reference to a buffer that is to contain
2416# the output from this command.
2417# $revision_id : The revision id of the revision that is to
2418# be returned.
2419# Return Value : True on success, otherwise false on failure.
2420#
2421##############################################################################
2422
2423
2424
2425sub packet_for_rdata($$$)
2426{
2427
2428 my($self, $buffer, $revision_id) = @_;
2429
2430 return $self->mtn_command("packet_for_rdata", 0, 0, $buffer, $revision_id);
2431
2432}
2433#
2434##############################################################################
2435#
2436# Routine - packets_for_certs
2437#
2438# Description - Get all the certs for the revision referenced by the
2439# specified revision id in packet format.
2440#
2441# Data - $self : The object.
2442# $buffer : A reference to a buffer that is to contain
2443# the output from this command.
2444# $revision_id : The revision id of the revision that is to
2445# have its certs returned.
2446# Return Value : True on success, otherwise false on failure.
2447#
2448##############################################################################
2449
2450
2451
2452sub packets_for_certs($$$)
2453{
2454
2455 my($self, $buffer, $revision_id) = @_;
2456
2457 return $self->mtn_command("packets_for_certs",
2458 0,
2459 0,
2460 $buffer,
2461 $revision_id);
2462
2463}
2464#
2465##############################################################################
2466#
2467# Routine - parents
2468#
2469# Description - Get a list of parents for the specified revision.
2470#
2471# Data - $self : The object.
2472# $list : A reference to a list that is to contain the
2473# revision ids.
2474# $revision_id : The revision id that is to have its parents
2475# returned.
2476# Return Value : True on success, otherwise false on failure.
2477#
2478##############################################################################
2479
2480
2481
2482sub parents($$$)
2483{
2484
2485 my($self, $list, $revision_id) = @_;
2486
2487 return $self->mtn_command("parents", 0, 0, $list, $revision_id);
2488
2489}
2490#
2491##############################################################################
2492#
2493# Routine - put_file
2494#
2495# Description - Put the specified file contents into the database,
2496# optionally basing it on the specified file id (this is used
2497# for delta encoding).
2498#
2499# Data - $self : The object.
2500# $buffer : A reference to a buffer that is to contain
2501# the output from this command.
2502# $base_file_id : The file id of the previous version of this
2503# file or undef if this is a new file.
2504# $contents : A reference to a buffer containing the
2505# file's contents.
2506# Return Value : True on success, otherwise false on
2507# failure.
2508#
2509##############################################################################
2510
2511
2512
2513sub put_file($$$$)
2514{
2515
2516 my($self, $buffer, $base_file_id, $contents) = @_;
2517
2518 my @list;
2519
2520 if (defined($base_file_id))
2521 {
2522if (! $self->mtn_command("put_file",
2523 0,
2524 0,
2525 \@list,
2526 $base_file_id,
2527 $contents))
2528{
2529 return;
2530}
2531 }
2532 else
2533 {
2534if (! $self->mtn_command("put_file", 0, 0, \@list, $contents))
2535{
2536 return;
2537}
2538 }
2539 $$buffer = $list[0];
2540
2541 return 1;
2542
2543}
2544#
2545##############################################################################
2546#
2547# Routine - put_revision
2548#
2549# Description - Put the specified revision data into the database.
2550#
2551# Data - $self : The object.
2552# $buffer : A reference to a buffer that is to contain
2553# the output from this command.
2554# $contents : A reference to a buffer containing the
2555# revision's contents.
2556# Return Value : True on success, otherwise false on failure.
2557#
2558##############################################################################
2559
2560
2561
2562sub put_revision($$$)
2563{
2564
2565 my($self, $buffer, $contents) = @_;
2566
2567 my @list;
2568
2569 if (! $self->mtn_command("put_revision", 1, 0, \@list, $contents))
2570 {
2571return;
2572 }
2573 $$buffer = $list[0];
2574
2575 return 1;
2576
2577}
2578#
2579##############################################################################
2580#
2581# Routine - read_packets
2582#
2583# Description - Decode and store the specified packet data in the database.
2584#
2585# Data - $self : The object.
2586# $packet_data : The packet data that is to be stored in the
2587# database.
2588# Return Value : True on success, otherwise false on failure.
2589#
2590##############################################################################
2591
2592
2593
2594sub read_packets($$)
2595{
2596
2597 my($self, $packet_data) = @_;
2598
2599 my $dummy;
2600
2601 return $self->mtn_command("read_packets", 0, 0, \$dummy, $packet_data);
2602
2603}
2604#
2605##############################################################################
2606#
2607# Routine - roots
2608#
2609# Description - Get a list of root revisions, i.e. revisions with no
2610# parents.
2611#
2612# Data - $self : The object.
2613# $list : A reference to a list that is to contain the
2614# revision ids.
2615# Return Value : True on success, otherwise false on failure.
2616#
2617##############################################################################
2618
2619
2620
2621sub roots($$)
2622{
2623
2624 my($self, $list) = @_;
2625
2626 return $self->mtn_command("roots", 0, 0, $list);
2627
2628}
2629#
2630##############################################################################
2631#
2632# Routine - select
2633#
2634# Description - Get a list of revision ids that match the specified
2635# selector.
2636#
2637# Data - $self : The object.
2638# $list : A reference to a list that is to contain the
2639# revision ids.
2640# $selector : The selector that is to be used.
2641# Return Value : True on success, otherwise false on failure.
2642#
2643##############################################################################
2644
2645
2646
2647sub select($$$)
2648{
2649
2650 my($self, $list, $selector) = @_;
2651
2652 return $self->mtn_command("select", 1, 0, $list, $selector);
2653
2654}
2655#
2656##############################################################################
2657#
2658# Routine - set_attribute
2659#
2660# Description - Set an attribute on the specified file or directory.
2661#
2662# Data - $self : The object.
2663# $path : The name of the file or directory that is to
2664# have an attribute set.
2665# $key : The name of the attribute that as to be set.
2666# $value : The value that the attribute is to be set
2667# to.
2668# Return Value : True on success, otherwise false on failure.
2669#
2670##############################################################################
2671
2672
2673
2674sub set_attribute($$$$)
2675{
2676
2677 my($self, $path, $key, $value) = @_;
2678
2679 my $dummy;
2680
2681 return $self->mtn_command("set_attribute",
2682 1,
2683 0,
2684 \$dummy,
2685 $path,
2686 $key,
2687 $value);
2688
2689}
2690#
2691##############################################################################
2692#
2693# Routine - set_db_variable
2694#
2695# Description - Set the value of a database variable.
2696#
2697# Data - $self : The object.
2698# $domain : The domain of the database variable.
2699# $name : The name of the variable to set.
2700# $value : The value to set the variable to.
2701# Return Value : True on success, otherwise false on failure.
2702#
2703##############################################################################
2704
2705
2706
2707sub set_db_variable($$$$)
2708{
2709
2710 my($self, $domain, $name, $value) = @_;
2711
2712 my($cmd,
2713 $dummy);
2714
2715 # This command was renamed in version 0.39 (i/f version 7.x).
2716
2717 if ($self->supports(MTN_SET_DB_VARIABLE))
2718 {
2719$cmd = "set_db_variable";
2720 }
2721 else
2722 {
2723$cmd = "db_set";
2724 }
2725 return $self->mtn_command($cmd, 1, 0, \$dummy, $domain, $name, $value);
2726
2727}
2728#
2729##############################################################################
2730#
2731# Routine - show_conflicts
2732#
2733# Description - Get a list of conflicts between the first two head
2734# revisions on the current branch, optionally one can specify
2735# both head revision ids and the name of the branch that they
2736# reside on.
2737#
2738# Data - $self : The object.
2739# $ref : A reference to a buffer or an array
2740# that is to contain the output from
2741# this command.
2742# $branch : The name of the branch that the head
2743# revisions are on.
2744# $left_revision_id : The left hand head revision id.
2745# $right_revision_id : The right hand head revision id.
2746# Return Value : True on success, otherwise false on
2747# failure.
2748#
2749##############################################################################
2750
2751
2752
2753sub show_conflicts($$;$$$)
2754{
2755
2756 my($self, $ref, $branch, $left_revision_id, $right_revision_id) = @_;
2757
2758 my @opts;
2759 my $this = $class_records{$self->{$class_name}};
2760
2761 # Validate the number of arguments and adjust them accordingly.
2762
2763 if (scalar(@_) == 4)
2764 {
2765
2766# Assume just the revision ids were given, so adjust the arguments
2767# accordingly.
2768
2769$right_revision_id = $left_revision_id;
2770$left_revision_id = $branch;
2771$branch = undef;
2772
2773 }
2774 elsif (scalar(@_) < 2 || scalar(@_) > 5)
2775 {
2776
2777# Wrong number of arguments.
2778
2779&$croaker("Wrong number of arguments given");
2780
2781 }
2782
2783 # Process any options.
2784
2785 @opts = ({key => "branch", value => $branch}) if (defined($branch));
2786
2787 # Run the command and get the data, either as one lump or as a structured
2788 # list.
2789
2790 if (ref($ref) eq "SCALAR")
2791 {
2792return $self->mtn_command_with_options("show_conflicts",
2793 1,
2794 1,
2795 $ref,
2796 \@opts,
2797 $left_revision_id,
2798 $right_revision_id);
2799 }
2800 else
2801 {
2802
2803my($i,
2804 @lines);
2805
2806if (! $self->mtn_command_with_options("show_conflicts",
2807 1,
2808 1,
2809 \@lines,
2810 \@opts,
2811 $left_revision_id,
2812 $right_revision_id))
2813{
2814 return;
2815}
2816
2817# Reformat the data into a structured array.
2818
2819for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2820{
2821 if ($lines[$i] =~ m/$io_stanza_re/)
2822 {
2823my $kv_record;
2824
2825# Get the next key-value record.
2826
2827parse_kv_record(\@lines,
2828\$i,
2829\%show_conflicts_keys,
2830\$kv_record);
2831-- $i;
2832
2833# Validate it in terms of expected fields and store.
2834
2835if (exists($kv_record->{left}))
2836{
2837 foreach my $key ("ancestor", "right")
2838 {
2839&$croaker("Corrupt show_conflicts list, expected "
2840 . $key . " field but did not find it")
2841 unless (exists($kv_record->{$key}));
2842 }
2843}
2844push(@$ref, $kv_record);
2845 }
2846}
2847
2848return 1;
2849
2850 }
2851
2852}
2853#
2854##############################################################################
2855#
2856# Routine - sync
2857#
2858# Description - Synchronises database changes between the local database
2859# and the specified remote server. This member function also
2860# provides the implementation to the pull and push methods.
2861#
2862# Data - $self : The object.
2863# $options : A reference to a list containing the options
2864# to use.
2865# $service : The name of the server to synchronise with,
2866# optionally followed by a colon and the port
2867# to connect to or a URI.
2868# @patterns : A list of branch patterns to include in the
2869# pull operation.
2870# Return Value : True on success, otherwise false on failure.
2871#
2872##############################################################################
2873
2874
2875
2876sub sync($;$$@)
2877{
2878
2879 my($self, $options, $service, @patterns) = @_;
2880
2881 my($cmd,
2882 $dummy,
2883 @opts);
2884
2885 # Find out how we were called (and hence the command that is to be run).
2886 # Remember that the routine name will be fully qualified.
2887
2888 $cmd = (caller(0))[3];
2889 $cmd = $1 if ($cmd =~ m/^.+\:\:([^:]+)$/);
2890
2891 # Process any options.
2892
2893 if (defined($options))
2894 {
2895for (my $i = 0; $i < scalar(@$options); ++ $i)
2896{
2897 if ($$options[$i] eq "set-default")
2898 {
2899push(@opts, {key => $$options[$i], value => ""});
2900 }
2901 else
2902 {
2903push(@opts, {key => $$options[$i], value => $$options[++ $i]});
2904 }
2905}
2906 }
2907
2908 # Run the command.
2909
2910 if (defined($service))
2911 {
2912return $self->mtn_command_with_options($cmd,
2913 1,
2914 1,
2915 \$dummy,
2916 \@opts,
2917 $service,
2918 @patterns);
2919 }
2920 else
2921 {
2922return $self->mtn_command_with_options($cmd, 1, 1, \$dummy, \@opts);
2923 }
2924
2925}
2926#
2927##############################################################################
2928#
2929# Routine - tags
2930#
2931# Description - Get all the tags attached to revisions on branches that
2932# match the specified branch pattern. If no pattern is given
2933# then all branches are searched.
2934#
2935# Data - $self : The object.
2936# $ref : A reference to a buffer or an array that
2937# is to contain the output from this
2938# command.
2939# $branch_pattern : The branch name pattern that the search
2940# is to be limited to.
2941# Return Value : True on success, otherwise false on
2942# failure.
2943#
2944##############################################################################
2945
2946
2947
2948sub tags($$;$)
2949{
2950
2951 my($self, $ref, $branch_pattern) = @_;
2952
2953 # Run the command and get the data, either as one lump or as a structured
2954 # list.
2955
2956 if (ref($ref) eq "SCALAR")
2957 {
2958return $self->mtn_command("tags", 1, 1, $ref, $branch_pattern);
2959 }
2960 else
2961 {
2962
2963my($i,
2964 @lines);
2965
2966if (! $self->mtn_command("tags", 1, 1, \@lines, $branch_pattern))
2967{
2968 return;
2969}
2970
2971# Reformat the data into a structured array.
2972
2973for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
2974{
2975 if ($lines[$i] =~ m/$io_stanza_re/)
2976 {
2977my $kv_record;
2978
2979# Get the next key-value record.
2980
2981parse_kv_record(\@lines, \$i, \%tags_keys, \$kv_record);
2982-- $i;
2983
2984# Validate it in terms of expected fields and store.
2985
2986if (exists($kv_record->{tag}))
2987{
2988 foreach my $key ("revision", "signer")
2989 {
2990&$croaker("Corrupt tags list, expected " . $key
2991 . " field but did not find it")
2992 unless (exists($kv_record->{$key}));
2993 }
2994 $kv_record->{branches} = []
2995unless (exists($kv_record->{branches})
2996&& defined($kv_record->{branches}));
2997 $kv_record->{revision_id} = $kv_record->{revision};
2998 delete($kv_record->{revision});
2999 push(@$ref, $kv_record);
3000}
3001 }
3002}
3003
3004return 1;
3005
3006 }
3007
3008}
3009#
3010##############################################################################
3011#
3012# Routine - toposort
3013#
3014# Description - Sort the specified revision ids such that the ancestors
3015# come out first.
3016#
3017# Data - $self : The object.
3018# $list : A reference to a list that is to contain
3019# the revision ids.
3020# @revision_ids : The revision ids that are to be sorted with
3021# the ancestors coming first.
3022# Return Value : True on success, otherwise false on
3023# failure.
3024#
3025##############################################################################
3026
3027
3028
3029sub toposort($$@)
3030{
3031
3032 my($self, $list, @revision_ids) = @_;
3033
3034 return $self->mtn_command("toposort", 0, 0, $list, @revision_ids);
3035
3036}
3037#
3038##############################################################################
3039#
3040# Routine - update
3041#
3042# Description - Updates the current workspace to the specified revision and
3043# possible branch. If no options are specified then the
3044# workspace is updated to the head revision of the current
3045# branch.
3046#
3047# Data - $self : The object.
3048# $options : A reference to a list containing the options
3049# to use.
3050# Return Value : True on success, otherwise false on failure.
3051#
3052##############################################################################
3053
3054
3055
3056sub update($;$)
3057{
3058
3059 my($self, $options) = @_;
3060
3061 my($dummy,
3062 @opts);
3063
3064 # Process any options.
3065
3066 if (defined($options))
3067 {
3068for (my $i = 0; $i < scalar(@$options); ++ $i)
3069{
3070 if ($$options[$i] eq "move-conflicting-paths")
3071 {
3072push(@opts, {key => $$options[$i], value => ""});
3073 }
3074 else
3075 {
3076push(@opts, {key => $$options[$i], value => $$options[++ $i]});
3077 }
3078}
3079 }
3080
3081 # Run the command.
3082
3083 return $self->mtn_command_with_options("update", 1, 1, \$dummy, \@opts);
3084
3085}
3086#
3087##############################################################################
3088#
3089# Routine - closedown
3090#
3091# Description - If started then stop the mtn subprocess.
3092#
3093# Data - $self : The object.
3094#
3095##############################################################################
3096
3097
3098
3099sub closedown($)
3100{
3101
3102 my $self = $_[0];
3103
3104 my $this = $class_records{$self->{$class_name}};
3105
3106 if ($this->{mtn_pid} != 0)
3107 {
3108
3109# Close off all file descriptors to the mtn subprocess. This should be
3110# enough to cause it to exit gracefully.
3111
3112close($this->{mtn_in});
3113close($this->{mtn_out});
3114close($this->{mtn_err});
3115
3116# Reap the mtn subprocess and deal with any errors.
3117
3118for (my $i = 0; $i < 4; ++ $i)
3119{
3120
3121 my $wait_status = 0;
3122
3123 # Wait for the mtn subprocess to exit (preserving the current state
3124 # of $@ so that any exception that has already occurred is not
3125 # lost, also ignore any errors resulting from waitpid()
3126 # interruption).
3127
3128 {
3129local $@;
3130eval
3131{
3132 local $SIG{ALRM} = sub { die(WAITPID_INTERRUPT); };
3133 alarm(5);
3134 $wait_status = waitpid($this->{mtn_pid}, 0);
3135 alarm(0);
3136};
3137$wait_status = 0
3138 if ($@ eq WAITPID_INTERRUPT && $wait_status < 0
3139&& $! == EINTR);
3140 }
3141
3142 # The mtn subprocess has terminated.
3143
3144 if ($wait_status == $this->{mtn_pid})
3145 {
3146last;
3147 }
3148
3149 # The mtn subprocess is still there so try and kill it unless it's
3150 # time to just give up.
3151
3152 elsif ($i < 3 && $wait_status == 0)
3153 {
3154if ($i == 0)
3155{
3156 kill("INT", $this->{mtn_pid});
3157}
3158elsif ($i == 1)
3159{
3160 kill("TERM", $this->{mtn_pid});
3161}
3162else
3163{
3164 kill("KILL", $this->{mtn_pid});
3165}
3166 }
3167
3168 # Stop if we don't have any relevant children to wait for anymore.
3169
3170 elsif ($wait_status < 0 && $! == ECHILD)
3171 {
3172last;
3173 }
3174
3175 # Either there is some other error with waitpid() or a child
3176 # process has been reaped that we aren't interested in (in which
3177 # case just ignore it).
3178
3179 elsif ($wait_status < 0)
3180 {
3181my $err_msg = $!;
3182kill("KILL", $this->{mtn_pid});
3183&$croaker("waitpid failed: " . $err_msg);
3184 }
3185
3186}
3187
3188$this->{poll} = undef;
3189$this->{mtn_pid} = 0;
3190
3191 }
3192
3193 return;
3194
3195}
3196#
3197##############################################################################
3198#
3199# Routine - db_locked_condition_detected
3200#
3201# Description - Check to see if the Monotone database was locked the last
3202# time a command was issued.
3203#
3204# Data - $self : The object.
3205# Return Value : True if the database was locked the last
3206# time a command was issues, otherwise false.
3207#
3208##############################################################################
3209
3210
3211
3212sub db_locked_condition_detected($)
3213{
3214
3215 my $self = $_[0];
3216
3217 my $this = $class_records{$self->{$class_name}};
3218
3219 return $this->{db_is_locked};
3220
3221}
3222#
3223##############################################################################
3224#
3225# Routine - get_db_name
3226#
3227# Description - Return the file name of the Monotone database as given to
3228# the constructor.
3229#
3230# Data - $self : The object.
3231# Return Value : The file name of the database as given to
3232# the constructor or undef if no database was
3233# specified.
3234#
3235##############################################################################
3236
3237
3238
3239sub get_db_name($)
3240{
3241
3242 my $self = $_[0];
3243
3244 my $this = $class_records{$self->{$class_name}};
3245
3246 if (defined($this->{dn_name}) && $this->{db_name} eq IN_MEMORY_DB_NAME)
3247 {
3248return undef;
3249 }
3250 else
3251 {
3252return $this->{db_name};
3253 }
3254
3255}
3256#
3257##############################################################################
3258#
3259# Routine - get_error_message
3260#
3261# Description - Return the message for the last error reported by this
3262# class.
3263#
3264# Data - $self : The object.
3265# Return Value : The message for the last error detected, or
3266# an empty string if nothing has gone wrong
3267# yet.
3268#
3269##############################################################################
3270
3271
3272
3273sub get_error_message($)
3274{
3275
3276 my $self = $_[0];
3277
3278 my $this = $class_records{$self->{$class_name}};
3279
3280 return $this->{error_msg};
3281
3282}
3283#
3284##############################################################################
3285#
3286# Routine - get_pid
3287#
3288# Description - Return the process id of the mtn automate stdio process.
3289#
3290# Data - $self : The object.
3291# Return Value : The process id of the mtn automate stdio
3292# process, or zero if no process is thought to
3293# be running.
3294#
3295##############################################################################
3296
3297
3298
3299sub get_pid($)
3300{
3301
3302 my $self = $_[0];
3303
3304 my $this = $class_records{$self->{$class_name}};
3305
3306 return $this->{mtn_pid};
3307
3308}
3309#
3310##############################################################################
3311#
3312# Routine - get_service_name
3313#
3314# Description - Return the service name of the Monotone server as given to
3315# the constructor.
3316#
3317# Data - $self : The object.
3318# Return Value : The service name of the Monotone server as
3319# given to the constructor or undef if no
3320# service was specified.
3321#
3322##############################################################################
3323
3324
3325
3326sub get_service_name($)
3327{
3328
3329 my $self = $_[0];
3330
3331 my $this = $class_records{$self->{$class_name}};
3332
3333 return $this->{network_service};
3334
3335}
3336#
3337##############################################################################
3338#
3339# Routine - get_ws_path
3340#
3341# Description - Return the the workspace's base directory as either given
3342# to the constructor or deduced from the current workspace.
3343# If neither condition holds true then undef is returned.
3344# Please note that the workspace's base directory may differ
3345# from that given to the constructor if the specified
3346# workspace path is actually a subdirectory within that
3347# workspace.
3348#
3349# Data - $self : The object.
3350# Return Value : The workspace's base directory or undef if
3351# no workspace was specified and there is no
3352# current workspace.
3353#
3354##############################################################################
3355
3356
3357
3358sub get_ws_path($)
3359{
3360
3361 my $self = $_[0];
3362
3363 my $this = $class_records{$self->{$class_name}};
3364
3365 return $this->{ws_path};
3366
3367}
3368#
3369##############################################################################
3370#
3371# Routine - ignore_suspend_certs
3372#
3373# Description - Determine whether revisions with the suspend cert are to be
3374# ignored or not. If the head revisions on a branch are all
3375# suspended then that branch is also ignored.
3376#
3377# Data - $self : The object.
3378# $ignore : True if suspend certs are to be ignored
3379# (i.e. all revisions are `visible'),
3380# otherwise false if suspend certs are to be
3381# honoured.
3382# Return Value : True on success, otherwise false on failure.
3383#
3384##############################################################################
3385
3386
3387
3388sub ignore_suspend_certs($$)
3389{
3390
3391 my($self, $ignore) = @_;
3392
3393 my $this = $class_records{$self->{$class_name}};
3394
3395 # This only works from version 0.37 (i/f version 6.x).
3396
3397 if ($this->{honour_suspend_certs} && $ignore)
3398 {
3399if ($self->supports(MTN_IGNORING_OF_SUSPEND_CERTS))
3400{
3401 $this->{honour_suspend_certs} = undef;
3402 $self->closedown();
3403 $self->startup();
3404}
3405else
3406{
3407 $this->{error_msg} = "Ignoring suspend certs is unsupported in "
3408. "this version of Monotone";
3409 &$carper($this->{error_msg});
3410 return;
3411}
3412 }
3413 elsif (! ($this->{honour_suspend_certs} || $ignore))
3414 {
3415$this->{honour_suspend_certs} = 1;
3416$self->closedown();
3417$self->startup();
3418 }
3419
3420 return 1;
3421
3422}
3423#
3424##############################################################################
3425#
3426# Routine - register_db_locked_handler
3427#
3428# Description - Register the specified routine as a database locked handler
3429# for this class. This is both a class as well as an object
3430# method. When used as a class method, the specified database
3431# locked handler is used as the default handler for all those
3432# objects that do not specify their own handlers.
3433#
3434# Data - $self : Either the object, the package name or not
3435# present depending upon how this method is
3436# called.
3437# $handler : A reference to the database locked handler
3438# routine. If this is not provided then the
3439# existing database locked handler routine is
3440# unregistered and database locking clashes
3441# are handled in the default way.
3442# $client_data : The client data that is to be passed to the
3443# registered database locked handler when it
3444# is called.
3445#
3446##############################################################################
3447
3448
3449
3450sub register_db_locked_handler(;$$$)
3451{
3452
3453 my($self,
3454 $this);
3455 if ($_[0]->isa(__PACKAGE__))
3456 {
3457if (ref($_[0]) ne "")
3458{
3459 $self = shift();
3460 $this = $class_records{$self->{$class_name}};
3461}
3462else
3463{
3464 shift();
3465}
3466 }
3467 my($handler, $client_data) = @_;
3468
3469 if (defined($self))
3470 {
3471if (defined($handler))
3472{
3473 $this->{db_locked_handler} = $handler;
3474 $this->{db_locked_handler_data} = $client_data;
3475}
3476else
3477{
3478 $this->{db_locked_handler} = $this->{db_locked_handler_data} =
3479undef;
3480}
3481 }
3482 else
3483 {
3484if (defined($handler))
3485{
3486 $db_locked_handler = $handler;
3487 $db_locked_handler_data = $client_data;
3488}
3489else
3490{
3491 $db_locked_handler = $db_locked_handler_data = undef;
3492}
3493 }
3494
3495 return;
3496
3497}
3498#
3499##############################################################################
3500#
3501# Routine - register_error_handler
3502#
3503# Description - Register the specified routine as an error handler for
3504# class. This is a class method rather than an object one as
3505# errors can be raised when calling the constructor.
3506#
3507# Data - $self : The object. This may not be present
3508# depending upon how this method is called and
3509# is ignored if it is present anyway.
3510# $severity : The level of error that the handler is being
3511# registered for.
3512# $handler : A reference to the error handler routine. If
3513# this is not provided then the existing error
3514# handler routine is unregistered and errors
3515# are handled in the default way.
3516# $client_data : The client data that is to be passed to the
3517# registered error handler when it is called.
3518#
3519##############################################################################
3520
3521
3522
3523sub register_error_handler($;$$$)
3524{
3525
3526 shift() if ($_[0]->isa(__PACKAGE__));
3527 my($severity, $handler, $client_data) = @_;
3528
3529 if ($severity == MTN_SEVERITY_ERROR)
3530 {
3531if (defined($handler))
3532{
3533 $error_handler = $handler;
3534 $error_handler_data = $client_data;
3535 $croaker = \&error_handler_wrapper;
3536}
3537else
3538{
3539 $croaker = \&croak;
3540 $error_handler = $error_handler_data = undef;
3541}
3542 }
3543 elsif ($severity == MTN_SEVERITY_WARNING)
3544 {
3545if (defined($handler))
3546{
3547 $warning_handler = $handler;
3548 $warning_handler_data = $client_data;
3549 $carper = \&warning_handler_wrapper;
3550}
3551else
3552{
3553 $carper = sub { return; };
3554 $warning_handler = $warning_handler_data = undef;
3555}
3556 }
3557 elsif ($severity == MTN_SEVERITY_ALL)
3558 {
3559if (defined($handler))
3560{
3561 $error_handler = $warning_handler = $handler;
3562 $error_handler_data = $warning_handler_data = $client_data;
3563 $carper = \&warning_handler_wrapper;
3564 $croaker = \&error_handler_wrapper;
3565}
3566else
3567{
3568 $warning_handler = $warning_handler_data = undef;
3569 $error_handler_data = $warning_handler_data = undef;
3570 $carper = sub { return; };
3571 $croaker = \&croak;
3572}
3573 }
3574 else
3575 {
3576&$croaker("Unknown error handler severity");
3577 }
3578
3579 return;
3580
3581}
3582#
3583##############################################################################
3584#
3585# Routine - register_io_wait_handler
3586#
3587# Description - Register the specified routine as an I/O wait handler for
3588# this class. This is both a class as well as an object
3589# method. When used as a class method, the specified I/O wait
3590# handler is used as the default handler for all those
3591# objects that do not specify their own handlers.
3592#
3593# Data - $self : Either the object, the package name or not
3594# present depending upon how this method is
3595# called.
3596# $handler : A reference to the I/O wait handler routine.
3597# If this is not provided then the existing
3598# I/O wait handler routine is unregistered.
3599# $timeout : The timeout, in seconds, that this class
3600# should wait for input before calling the I/O
3601# wait handler.
3602# $client_data : The client data that is to be passed to the
3603# registered I/O wait handler when it is
3604# called.
3605#
3606##############################################################################
3607
3608
3609
3610sub register_io_wait_handler(;$$$$)
3611{
3612
3613 my($self,
3614 $this);
3615 if ($_[0]->isa(__PACKAGE__))
3616 {
3617if (ref($_[0]) ne "")
3618{
3619 $self = shift();
3620 $this = $class_records{$self->{$class_name}};
3621}
3622else
3623{
3624 shift();
3625}
3626 }
3627 my($handler, $timeout, $client_data) = @_;
3628
3629 if (defined($timeout))
3630 {
3631if ($timeout !~ m/^\d*\.{0,1}\d+$/ || $timeout < 0 || $timeout > 20)
3632{
3633 my $msg =
3634"I/O wait handler timeout invalid or out of range, resetting";
3635 $this->{error_msg} = $msg if (defined($this));
3636 &$carper($msg);
3637 $timeout = 1;
3638}
3639 }
3640 else
3641 {
3642$timeout = 1;
3643 }
3644
3645 if (defined($self))
3646 {
3647if (defined($handler))
3648{
3649 $this->{io_wait_handler} = $handler;
3650 $this->{io_wait_handler_data} = $client_data;
3651 $this->{io_wait_handler_timeout} = $timeout;
3652}
3653else
3654{
3655 $this->{io_wait_handler} = $this->{io_wait_handler_data} = undef;
3656}
3657 }
3658 else
3659 {
3660if (defined($handler))
3661{
3662 $io_wait_handler = $handler;
3663 $io_wait_handler_data = $client_data;
3664 $io_wait_handler_timeout = $timeout;
3665}
3666else
3667{
3668 $io_wait_handler = $io_wait_handler_data = undef;
3669}
3670 }
3671
3672 return;
3673
3674}
3675#
3676##############################################################################
3677#
3678# Routine - register_stream_handle
3679#
3680# Description - Register the specified file handle to receive data from the
3681# specified mtn automate stdio output stream.
3682#
3683# Data - $self : The object.
3684# $stream : The mtn output stream from which data is to be
3685# read and then written to the specified file
3686# handle.
3687# $handle : The file handle that is to receive the data from
3688# the specified output stream. If this is not
3689# provided then any existing file handle for that
3690# stream is unregistered.
3691#
3692##############################################################################
3693
3694
3695
3696sub register_stream_handle($$$)
3697{
3698
3699 my($self, $stream, $handle) = @_;
3700
3701 my $this = $class_records{$self->{$class_name}};
3702
3703 if (defined($handle) && ref($handle) !~ m/^IO::[^:]+/
3704&& ref($handle) ne "GLOB" && ref(\$handle) ne "GLOB")
3705 {
3706&$croaker("Handle must be either undef or a valid handle");
3707 }
3708 autoflush($stream, 1);
3709 if ($stream == MTN_P_STREAM)
3710 {
3711$this->{p_stream_handle} = $handle;
3712 }
3713 elsif ($stream == MTN_T_STREAM)
3714 {
3715$this->{t_stream_handle} = $handle;
3716 }
3717 else
3718 {
3719&$croaker("Unknown stream specified");
3720 }
3721
3722 return;
3723
3724}
3725#
3726##############################################################################
3727#
3728# Routine - supports
3729#
3730# Description - Determine whether a certain feature is available with the
3731# version of Monotone that is currently being used.
3732#
3733# Data - $self : The object.
3734# $feature : A constant specifying the feature that is
3735# to be checked for.
3736# Return Value : True if the feature is supported, otherwise
3737# false if it is not.
3738#
3739##############################################################################
3740
3741
3742
3743sub supports($$)
3744{
3745
3746 my($self, $feature) = @_;
3747
3748 my $this = $class_records{$self->{$class_name}};
3749
3750 if ($feature == MTN_DROP_ATTRIBUTE
3751|| $feature == MTN_GET_ATTRIBUTES
3752|| $feature == MTN_SET_ATTRIBUTE)
3753 {
3754
3755# These are only available from version 0.36 (i/f version 5.x).
3756
3757return 1 if ($this->{mtn_aif_version} >= 5);
3758
3759 }
3760 elsif ($feature == MTN_IGNORING_OF_SUSPEND_CERTS
3761 || $feature == MTN_INVENTORY_IN_IO_STANZA_FORMAT
3762 || $feature == MTN_P_SELECTOR)
3763 {
3764
3765# These are only available from version 0.37 (i/f version 6.x).
3766
3767return 1 if ($this->{mtn_aif_version} >= 6);
3768
3769 }
3770 elsif ($feature == MTN_DROP_DB_VARIABLES
3771 || $feature == MTN_GET_CURRENT_REVISION
3772 || $feature == MTN_GET_DB_VARIABLES
3773 || $feature == MTN_INVENTORY_TAKING_OPTIONS
3774 || $feature == MTN_SET_DB_VARIABLE)
3775 {
3776
3777# These are only available from version 0.39 (i/f version 7.x).
3778
3779return 1 if ($this->{mtn_aif_version} >= 7);
3780
3781 }
3782 elsif ($feature == MTN_DB_GET)
3783 {
3784
3785# This is only available prior version 0.39 (i/f version 7.x).
3786
3787return 1 if ($this->{mtn_aif_version} < 7);
3788
3789 }
3790 elsif ($feature == MTN_GET_WORKSPACE_ROOT
3791 || $feature == MTN_INVENTORY_WITH_BIRTH_ID
3792 || $feature == MTN_SHOW_CONFLICTS)
3793 {
3794
3795# These are only available from version 0.41 (i/f version 8.x).
3796
3797return 1 if ($this->{mtn_aif_version} >= 8);
3798
3799 }
3800 elsif ($feature == MTN_CONTENT_DIFF_EXTRA_OPTIONS
3801 || $feature == MTN_FILE_MERGE
3802 || $feature == MTN_LUA
3803 || $feature == MTN_READ_PACKETS)
3804 {
3805
3806# These are only available from version 0.42 (i/f version 9.x).
3807
3808return 1 if ($this->{mtn_aif_version} >= 9);
3809
3810 }
3811 elsif ($feature == MTN_M_SELECTOR || $feature == MTN_U_SELECTOR)
3812 {
3813
3814# These are only available from version 0.43 (i/f version 9.x).
3815
3816return 1 if ($this->{mtn_aif_version} >= 10
3817 || (int($this->{mtn_aif_version}) == 9
3818 && $mtn_version == 0.43));
3819
3820 }
3821 elsif ($feature == MTN_COMMON_KEY_HASH || $feature == MTN_W_SELECTOR)
3822 {
3823
3824# These are only available from version 0.44 (i/f version 10.x).
3825
3826return 1 if ($this->{mtn_aif_version} >= 10);
3827
3828 }
3829 elsif ($feature == MTN_HASHED_SIGNATURES)
3830 {
3831
3832# This is only available from version 0.45 (i/f version 11.x).
3833
3834return 1 if ($this->{mtn_aif_version} >= 11);
3835
3836 }
3837 elsif ($feature == MTN_REMOTE_CONNECTIONS
3838 || $feature == MTN_STREAM_IO
3839 || $feature == MTN_SYNCHRONISATION)
3840 {
3841
3842# These are only available from version 0.46 (i/f version 12.x).
3843
3844return 1 if ($this->{mtn_aif_version} >= 12);
3845
3846 }
3847 elsif ($feature == MTN_UPDATE)
3848 {
3849
3850# This is only available from version 0.48 (i/f version 12.1).
3851
3852return 1 if ($this->{mtn_aif_version} >= 12.1);
3853
3854 }
3855 else
3856 {
3857&$croaker("Unknown feature requested");
3858 }
3859
3860 return;
3861
3862}
3863#
3864##############################################################################
3865#
3866# Routine - suppress_utf8_conversion
3867#
3868# Description - Controls whether UTF-8 conversion should be done on the
3869# data sent to and from the mtn subprocess by this class.
3870# This is both a class as well as an object method. When used
3871# as a class method, the specified setting is used as the
3872# default for all those objects that do not specify their own
3873# setting. The default setting is to perform UTF-8
3874# conversion.
3875#
3876# Data - $self : Either the object, the package name or not
3877# present depending upon how this method is
3878# called.
3879# $suppress : True if UTF-8 conversion is not to be done,
3880# otherwise false if it is.
3881#
3882##############################################################################
3883
3884
3885
3886sub suppress_utf8_conversion($$)
3887{
3888
3889 my($self,
3890 $this);
3891 if ($_[0]->isa(__PACKAGE__))
3892 {
3893if (ref($_[0]) ne "")
3894{
3895 $self = shift();
3896 $this = $class_records{$self->{$class_name}};
3897}
3898else
3899{
3900 shift();
3901}
3902 }
3903 my $suppress = $_[0];
3904
3905 if (defined($self))
3906 {
3907$this->{convert_to_utf8} = $suppress ? undef : 1;
3908 }
3909 else
3910 {
3911$convert_to_utf8 = $suppress ? undef : 1;
3912 }
3913
3914 return;
3915
3916}
3917#
3918##############################################################################
3919#
3920# Routine - switch_to_ws_root
3921#
3922# Description - Control whether this class automatically switches to a
3923# workspace's root directory before running the mtn
3924# subprocess. The default action is to do so as this is
3925# generally safer.
3926#
3927# Data - $self : The object.
3928# $switch : True if the mtn subprocess should be started
3929# in a workspace's root directory, otherwise
3930# false if it should be started in the current
3931# working directory.
3932# Return Value : True on success, otherwise false on failure.
3933#
3934##############################################################################
3935
3936
3937
3938sub switch_to_ws_root($$)
3939{
3940
3941 my($self,
3942 $this);
3943 if ($_[0]->isa(__PACKAGE__))
3944 {
3945if (ref($_[0]) ne "")
3946{
3947 $self = shift();
3948 $this = $class_records{$self->{$class_name}};
3949}
3950else
3951{
3952 shift();
3953}
3954 }
3955 my $switch = $_[0];
3956
3957 if (defined($self))
3958 {
3959if (! $this->{ws_constructed})
3960{
3961 if ($this->{cd_to_ws_root} && ! $switch)
3962 {
3963$this->{cd_to_ws_root} = undef;
3964$self->closedown();
3965$self->startup();
3966 }
3967 elsif (! $this->{cd_to_ws_root} && $switch)
3968 {
3969$this->{cd_to_ws_root} = 1;
3970$self->closedown();
3971$self->startup();
3972 }
3973}
3974else
3975{
3976 $this->{error_msg} =
3977"Cannot call Monotone::AutomateStdio->switch_to_ws_root() on "
3978. "objects constructed with new_from_ws()";
3979 &$carper($this->{error_msg});
3980 return;
3981}
3982 }
3983 else
3984 {
3985$cd_to_ws_root = $switch ? 1 : undef;
3986 }
3987
3988 return 1;
3989
3990}
3991#
3992##############################################################################
3993#
3994# Routine - parse_revision_data
3995#
3996# Description - Parse the specified revision data into a list of records.
3997#
3998# Data - $list : A reference to a list that is to contain the
3999# records.
4000# $data : A reference to a list containing the revision data,
4001# line by line.
4002#
4003##############################################################################
4004
4005
4006
4007sub parse_revision_data($$)
4008{
4009
4010 my($list, $data) = @_;
4011
4012 my $i;
4013
4014 # Reformat the data into a structured array.
4015
4016 for ($i = 0, @$list = (); $i < scalar(@$data); ++ $i)
4017 {
4018if ($$data[$i] =~ m/$io_stanza_re/)
4019{
4020 my $kv_record;
4021
4022 # Get the next key-value record.
4023
4024 parse_kv_record($data, \$i, \%revision_details_keys, \$kv_record);
4025 -- $i;
4026
4027 # Validate it in terms of expected fields and copy data across to
4028 # the correct revision fields.
4029
4030 if (exists($kv_record->{add_dir}))
4031 {
4032push(@$list, {type => "add_dir",
4033 name => $kv_record->{add_dir}});
4034 }
4035 elsif (exists($kv_record->{add_file}))
4036 {
4037&$croaker("Corrupt revision, expected content field but "
4038 . "did not find it")
4039 unless (exists($kv_record->{content}));
4040push(@$list, {type => "add_file",
4041 name => $kv_record->{add_file},
4042 file_id => $kv_record->{content}});
4043 }
4044 elsif (exists($kv_record->{clear}))
4045 {
4046&$croaker("Corrupt revision, expected attr field but did not "
4047 . "find it")
4048 unless (exists($kv_record->{attr}));
4049push(@$list, {type => "clear",
4050 name => $kv_record->{clear},
4051 attribute => $kv_record->{attr}});
4052 }
4053 elsif (exists($kv_record->{delete}))
4054 {
4055push(@$list, {type => "delete",
4056 name => $kv_record->{delete}});
4057 }
4058 elsif (exists($kv_record->{new_manifest}))
4059 {
4060push(@$list, {type => "new_manifest",
4061 manifest_id => $kv_record->{new_manifest}});
4062 }
4063 elsif (exists($kv_record->{old_revision}))
4064 {
4065push(@$list, {type => "old_revision",
4066 revision_id => $kv_record->{old_revision}});
4067 }
4068 elsif (exists($kv_record->{patch}))
4069 {
4070&$croaker("Corrupt revision, expected from field but did not "
4071 . "find it")
4072 unless (exists($kv_record->{from}));
4073&$croaker("Corrupt revision, expected to field but did not "
4074 . "find it")
4075 unless (exists($kv_record->{to}));
4076push(@$list, {type => "patch",
4077 name => $kv_record->{patch},
4078 from_file_id => $kv_record->{from},
4079 to_file_id => $kv_record->{to}});
4080 }
4081 elsif (exists($kv_record->{rename}))
4082 {
4083&$croaker("Corrupt revision, expected to field but did not "
4084 . "find it")
4085 unless (exists($kv_record->{to}));
4086push(@$list, {type => "rename",
4087 from_name => $kv_record->{rename},
4088 to_name => $kv_record->{to}});
4089 }
4090 elsif (exists($kv_record->{set}))
4091 {
4092&$croaker("Corrupt revision, expected attr field but did not "
4093 . "find it")
4094 unless (exists($kv_record->{attr}));
4095&$croaker("Corrupt revision, expected value field but did not "
4096 . "find it")
4097 unless (exists($kv_record->{value}));
4098push(@$list, {type => "set",
4099 name => $kv_record->{set},
4100 attribute => $kv_record->{attr},
4101 value => $kv_record->{value}});
4102 }
4103}
4104 }
4105
4106}
4107#
4108##############################################################################
4109#
4110# Routine - parse_kv_record
4111#
4112# Description - Parse the specified data for a key-value style record, with
4113# each record being separated by a white space line,
4114# returning the extracted record.
4115#
4116# Data - $list : A reference to the list that contains the
4117# data.
4118# $index : A reference to a variable containing the
4119# index of the first line of the record in
4120# the array. It is updated with the index of
4121# the first line after the record.
4122# $key_type_map : A reference to the key type map, this is a
4123# map indexed by key name and has an
4124# enumeration as its value that describes the
4125# type of value that is to be read in.
4126# $record : A reference to a variable that is to be
4127# updated with the reference to the newly
4128# created record.
4129# $no_errors : True if this routine should not report
4130# errors relating to unknown fields,
4131# otherwise undef if these errors are to be
4132# reported. This is optional.
4133#
4134##############################################################################
4135
4136
4137
4138sub parse_kv_record($$$$;$)
4139{
4140
4141 my($list, $index, $key_type_map, $record, $no_errors) = @_;
4142
4143 my($i,
4144 $key,
4145 $type,
4146 $value);
4147
4148 for ($i = $$index, $$record = {};
4149 $i < scalar(@$list) && $$list[$i] =~ m/$io_stanza_re/;
4150 ++ $i)
4151 {
4152$key = $1;
4153if (exists($$key_type_map{$key}))
4154{
4155 $type = $$key_type_map{$key};
4156 $value = undef;
4157 if ($type & BARE_PHRASE && $$list[$i] =~ m/^ *[a-z_]+ ([a-z_]+)$/)
4158 {
4159$value = $1;
4160 }
4161 elsif ($type & HEX_ID
4162 && $$list[$i] =~ m/^ *[a-z_]+ \[([0-9a-f]+)\]$/)
4163 {
4164$value = $1;
4165 }
4166 elsif ($type & OPTIONAL_HEX_ID
4167 && $$list[$i] =~ m/^ *[a-z_]+ \[([0-9a-f]*)\]$/)
4168 {
4169$value = $1;
4170 }
4171 elsif ($type & STRING && $$list[$i] =~ m/^ *[a-z_]+ \"/)
4172 {
4173get_quoted_value($list, \$i, \$value);
4174$value = unescape($value);
4175 }
4176 elsif ($type & STRING_ENUM
4177 && $$list[$i] =~ m/^ *[a-z_]+ \"([^\"]+)\"$/)
4178 {
4179$value = $1;
4180 }
4181 elsif ($type & STRING_LIST
4182 && $$list[$i] =~ m/^ *[a-z_]+ \"(.+)\"$/)
4183 {
4184foreach my $string (split(/\" \"/, $1))
4185{
4186 push(@$value, unescape($string));
4187}
4188 }
4189 elsif ($type & NULL && $$list[$i] =~ m/^ *[a-z_]+ ?$/)
4190 {
4191 }
4192 else
4193 {
4194&$croaker("Unsupported key type or corrupt field value "
4195 . "detected");
4196 }
4197 $$record->{$key} = $value;
4198}
4199else
4200{
4201 &$croaker("Unrecognised field " . $key . " found")
4202unless ($no_errors);
4203}
4204 }
4205 $$index = $i;
4206
4207}
4208#
4209##############################################################################
4210#
4211# Routine - mtn_command
4212#
4213# Description - Handle mtn commands that take no options and zero or more
4214# arguments. Depending upon what type of reference is passed,
4215# data is either returned in one large lump (scalar
4216# reference), or an array of lines (array reference).
4217#
4218# Data - $self : The object.
4219# $cmd : The mtn automate command that is to be run.
4220# $out_as_utf8 : True if any data output to mtn should be
4221# converted into raw UTF-8, otherwise false if
4222# the data should be treated as binary. If
4223# UTF-8 conversion has been disabled by a call
4224# to the suppress_utf8_conversion() method
4225# then this argument is ignored.
4226# $in_as_utf8 : True if any data input from mtn should be
4227# converted into Perl's internal UTF-8 string
4228# format, otherwise false if the data should
4229# be treated as binary. If UTF-8 conversion
4230# has been disabled by a call to the
4231# suppress_utf8_conversion() method then this
4232# argument is ignored.
4233# $ref : A reference to a buffer or an array that is
4234# to contain the output from this command.
4235# @parameters : A list of parameters to be applied to the
4236# command.
4237# Return Value : True on success, otherwise false on failure.
4238#
4239##############################################################################
4240
4241
4242
4243sub mtn_command($$$$$;@)
4244{
4245
4246 my($self, $cmd, $out_as_utf8, $in_as_utf8, $ref, @parameters) = @_;
4247
4248 return $self->mtn_command_with_options($cmd,
4249 $out_as_utf8,
4250 $in_as_utf8,
4251 $ref,
4252 [],
4253 @parameters);
4254
4255}
4256#
4257##############################################################################
4258#
4259# Routine - mtn_command_with_options
4260#
4261# Description - Handle mtn commands that take options and zero or more
4262# arguments. Depending upon what type of reference is passed,
4263# data is either returned in one large lump (scalar
4264# reference), or an array of lines (array reference).
4265#
4266# Data - $self : The object.
4267# $cmd : The mtn automate command that is to be run.
4268# $out_as_utf8 : True if any data output to mtn should be
4269# converted into raw UTF-8, otherwise false if
4270# the data should be treated as binary. If
4271# UTF-8 conversion has been disabled by a call
4272# to the suppress_utf8_conversion() method
4273# then this argument is ignored.
4274# $in_as_utf8 : True if any data input from mtn should be
4275# converted into Perl's internal UTF-8 string
4276# format, otherwise false if the data should
4277# be treated as binary. If UTF-8 conversion
4278# has been disabled by a call to the
4279# suppress_utf8_conversion() method then this
4280# argument is ignored.
4281# $ref : A reference to a buffer or an array that is
4282# to contain the output from this command.
4283# $options : A reference to a list containing key/value
4284# anonymous hashes.
4285# @parameters : A list of parameters to be applied to the
4286# command.
4287# Return Value : True on success, otherwise false on failure.
4288#
4289##############################################################################
4290
4291
4292
4293sub mtn_command_with_options($$$$$$;@)
4294{
4295
4296 my($self, $cmd, $out_as_utf8, $in_as_utf8, $ref, $options, @parameters)
4297= @_;
4298
4299 my($buffer,
4300 $buffer_ref,
4301 $db_locked_exception,
4302 $handler,
4303 $handler_data,
4304 $opt,
4305 $param,
4306 $read_ok,
4307 $retry);
4308 my $this = $class_records{$self->{$class_name}};
4309
4310 # Work out whether UTF-8 conversion is to be done at all.
4311
4312 $out_as_utf8 = $in_as_utf8 = undef unless ($this->{convert_to_utf8});
4313
4314 # Work out what database locked handler is to be used.
4315
4316 if (defined($this->{db_locked_handler}))
4317 {
4318$handler = $this->{db_locked_handler};
4319$handler_data = $this->{db_locked_handler_data};
4320 }
4321 else
4322 {
4323$handler = $db_locked_handler;
4324$handler_data = $db_locked_handler_data;
4325 }
4326
4327 # If the output is to be returned as an array of lines as against one lump
4328 # then we need to read the output into a temporary buffer before breaking
4329 # it up into lines.
4330
4331 if (ref($ref) eq "SCALAR")
4332 {
4333$buffer_ref = $ref;
4334 }
4335 elsif (ref($ref) eq "ARRAY")
4336 {
4337$buffer_ref = \$buffer;
4338 }
4339 else
4340 {
4341&$croaker("Expected a reference to a scalar or an array");
4342 }
4343
4344 # Send the command, reading its output, repeating if necessary if retries
4345 # should be attempted when the database is locked.
4346
4347 do
4348 {
4349
4350# Startup the subordinate mtn process if it hasn't already been
4351# started.
4352
4353$self->startup() if ($this->{mtn_pid} == 0);
4354
4355# Send the command.
4356
4357if (scalar(@$options) > 0)
4358{
4359 $this->{mtn_in}->print("o");
4360 foreach $opt (@$options)
4361 {
4362my($key,
4363 $key_ref,
4364 $value,
4365 $value_ref);
4366if ($out_as_utf8)
4367{
4368 $key = encode_utf8($opt->{key});
4369 $value = encode_utf8($opt->{value});
4370 $key_ref = \$key;
4371 $value_ref = \$value;
4372}
4373else
4374{
4375 $key_ref = \$opt->{key};
4376 $value_ref = \$opt->{value};
4377}
4378$this->{mtn_in}->printf("%d:%s%d:%s",
4379length($$key_ref),
4380$$key_ref,
4381length($$value_ref),
4382$$value_ref);
4383 }
4384 $this->{mtn_in}->print("e ");
4385}
4386$this->{mtn_in}->printf("l%d:%s", length($cmd), $cmd);
4387foreach $param (@parameters)
4388{
4389
4390 # Cater for passing by reference (useful when sending large lumps
4391 # of data as in put_file). Also defend against undef being passed
4392 # as the only parameter (which can happen when a mandatory argument
4393 # is not passed by the caller).
4394
4395 if (defined $param)
4396 {
4397my($data,
4398 $param_ref);
4399if (ref($param) ne "")
4400{
4401 if ($out_as_utf8)
4402 {
4403$data = encode_utf8($$param);
4404$param_ref = \$data;
4405 }
4406 else
4407 {
4408$param_ref = $param;
4409 }
4410}
4411else
4412{
4413 if ($out_as_utf8)
4414 {
4415$data = encode_utf8($param);
4416$param_ref = \$data;
4417 }
4418 else
4419 {
4420$param_ref = \$param;
4421 }
4422}
4423$this->{mtn_in}->printf("%d:%s",
4424length($$param_ref),
4425$$param_ref);
4426 }
4427
4428}
4429$this->{mtn_in}->print("e\n");
4430
4431# Attempt to read the output of the command, rethrowing any exception
4432# that does not relate to locked databases.
4433
4434$db_locked_exception = $read_ok = $retry = undef;
4435eval
4436{
4437 $read_ok = $self->mtn_read_output($buffer_ref);
4438};
4439if ($@)
4440{
4441 if ($@ =~ m/$database_locked_re/)
4442 {
4443
4444# We need to properly closedown the mtn subprocess at this
4445# point because we are quietly handling the exception that
4446# caused it to exit but the calling application may reap the
4447# process and compare the reaped PID with the return value from
4448# the get_pid() method. At least by calling closedown() here
4449# get_pid() will return 0 and the caller can then distinguish
4450# between a handled exit and one that should be dealt with.
4451
4452$self->closedown();
4453$db_locked_exception = 1;
4454
4455 }
4456 else
4457 {
4458&$croaker($@);
4459 }
4460}
4461
4462# If the data was read in ok then carry out any necessary character set
4463# conversions. Otherwise deal with locked database exceptions and any
4464# warning messages that appeared in the output.
4465
4466if ($read_ok && $in_as_utf8)
4467{
4468 local $@;
4469 eval
4470 {
4471$$buffer_ref = decode_utf8($$buffer_ref, Encode::FB_CROAK);
4472 };
4473 if ($@)
4474 {
4475$this->{error_msg} = "The output from Monotone was not UTF-8 "
4476 . "encoded as expected";
4477&$carper($this->{error_msg});
4478return;
4479 }
4480}
4481elsif (! $read_ok)
4482{
4483
4484 # See if we are to retry on database locked conditions.
4485
4486 if ($db_locked_exception
4487|| $this->{error_msg} =~ m/$database_locked_re/)
4488 {
4489$this->{db_is_locked} = 1;
4490$retry = &$handler($self, $handler_data);
4491 }
4492
4493 # If we are to retry then close down the subordinate mtn process,
4494 # otherwise report the error to the caller.
4495
4496 if ($retry)
4497 {
4498$self->closedown();
4499 }
4500 else
4501 {
4502&$carper($this->{error_msg});
4503return;
4504 }
4505
4506}
4507
4508 }
4509 while ($retry);
4510
4511 # Split the output up into lines if that is what is required.
4512
4513 @$ref = split(/\n/, $$buffer_ref) if (ref($ref) eq "ARRAY");
4514
4515 return 1;
4516
4517}
4518#
4519##############################################################################
4520#
4521# Routine - mtn_read_output_format_1
4522#
4523# Description - Reads the output from mtn as format 1, removing chunk
4524# headers.
4525#
4526# Data - $self : The object.
4527# $buffer : A reference to the buffer that is to contain
4528# the data.
4529# Return Value : True on success, otherwise false on failure.
4530#
4531##############################################################################
4532
4533
4534
4535sub mtn_read_output_format_1($$)
4536{
4537
4538 my($self, $buffer) = @_;
4539
4540 my($bytes_read,
4541 $char,
4542 $chunk_start,
4543 $cmd_nr,
4544 $colons,
4545 $err_code,
4546 $err_occurred,
4547 $handler,
4548 $handler_data,
4549 $handler_timeout,
4550 $header,
4551 $i,
4552 $last,
4553 $offset,
4554 $size);
4555 my $this = $class_records{$self->{$class_name}};
4556
4557 # Work out what I/O wait handler is to be used.
4558
4559 if (defined($this->{io_wait_handler}))
4560 {
4561$handler = $this->{io_wait_handler};
4562$handler_data = $this->{io_wait_handler_data};
4563$handler_timeout = $this->{io_wait_handler_timeout};
4564 }
4565 else
4566 {
4567$handler = $io_wait_handler;
4568$handler_data = $io_wait_handler_data;
4569$handler_timeout = $io_wait_handler_timeout;
4570 }
4571