##############################################################################
#
# File Name - AutomateStdio.pm
#
# Description - A class module that provides an interface to Monotone's
# automate stdio interface.
#
# Authors - A.E.Cooper. With contributions from T.Keller.
#
# Legal Stuff - Copyright (c) 2007 Anthony Edward Cooper
# <aecooper@coosoft.plus.com>.
#
# This library is free software; you can redistribute it
# and/or modify it under the terms of the GNU Lesser General
# Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your
# option) any later version.
#
# This library is distributed in the hope that it will be
# useful, but WITHOUT ANY WARRANTY; without even the implied
# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
# PURPOSE. See the GNU Lesser General Public License for
# more details.
#
# You should have received a copy of the GNU Lesser General
# Public License along with this library; if not, write to
# the Free Software Foundation, Inc., 59 Temple Place - Suite
# 330, Boston, MA 02111-1307 USA.
#
##############################################################################
#
##############################################################################
#
# Package - Monotone::AutomateStdio
#
# Description - See above.
#
##############################################################################
# ***** PACKAGE DECLARATION *****
package Monotone::AutomateStdio;
# ***** DIRECTIVES *****
require 5.008005;
no locale;
use strict;
use warnings;
# ***** REQUIRED PACKAGES *****
# Standard Perl and CPAN modules.
use Carp;
use Cwd qw(abs_path getcwd);
use Encode;
use File::Basename;
use File::Spec;
use IO::File;
use IO::Handle qw(autoflush);
use IO::Poll qw(POLLHUP POLLIN POLLPRI);
use IPC::Open3;
use POSIX qw(:errno_h :limits_h);
use Socket;
use Symbol qw(gensym);
# ***** GLOBAL DATA DECLARATIONS *****
# Constants used to represent the different types of capability Monotone may or
# may not provide depending upon its version.
use constant MTN_CHECKOUT => 0;
use constant MTN_COMMON_KEY_HASH => 1;
use constant MTN_CONTENT_DIFF_EXTRA_OPTIONS => 2;
use constant MTN_DB_GET => 3;
use constant MTN_DROP_ATTRIBUTE => 4;
use constant MTN_DROP_DB_VARIABLES => 5;
use constant MTN_DROP_PUBLIC_KEY => 6;
use constant MTN_ERASE_DESCENDANTS => 7;
use constant MTN_FILE_MERGE => 8;
use constant MTN_GENERATE_KEY => 9;
use constant MTN_GET_ATTRIBUTES => 10;
use constant MTN_GET_ATTRIBUTES_TAKING_OPTIONS => 11;
use constant MTN_GET_CURRENT_REVISION => 12;
use constant MTN_GET_DB_VARIABLES => 13;
use constant MTN_GET_EXTENDED_MANIFEST_OF => 14;
use constant MTN_GET_FILE_SIZE => 15;
use constant MTN_GET_PUBLIC_KEY => 16;
use constant MTN_GET_WORKSPACE_ROOT => 17;
use constant MTN_HASHED_SIGNATURES => 18;
use constant MTN_IGNORING_OF_SUSPEND_CERTS => 19;
use constant MTN_INVENTORY_IN_IO_STANZA_FORMAT => 20;
use constant MTN_INVENTORY_TAKING_OPTIONS => 21;
use constant MTN_INVENTORY_WITH_BIRTH_ID => 22;
use constant MTN_K_SELECTOR => 23;
use constant MTN_LOG => 24;
use constant MTN_LUA => 25;
use constant MTN_M_SELECTOR => 26;
use constant MTN_P_SELECTOR => 27;
use constant MTN_PUT_PUBLIC_KEY => 28;
use constant MTN_READ_PACKETS => 29;
use constant MTN_REMOTE_CONNECTIONS => 30;
use constant MTN_SELECTOR_FUNCTIONS => 31;
use constant MTN_SELECTOR_MIN_FUNCTION => 32;
use constant MTN_SELECTOR_NOT_FUNCTION => 33;
use constant MTN_SELECTOR_OR_OPERATOR => 34;
use constant MTN_SET_ATTRIBUTE => 35;
use constant MTN_SET_DB_VARIABLE => 36;
use constant MTN_SHOW_CONFLICTS => 37;
use constant MTN_STREAM_IO => 38;
use constant MTN_SYNCHRONISATION => 39;
use constant MTN_SYNCHRONISATION_WITH_OUTPUT => 40;
use constant MTN_U_SELECTOR => 41;
use constant MTN_UPDATE => 42;
use constant MTN_W_SELECTOR => 43;
# Constants used to represent the different error levels.
use constant MTN_SEVERITY_ALL => 0x03;
use constant MTN_SEVERITY_ERROR => 0x01;
use constant MTN_SEVERITY_WARNING => 0x02;
# Constants used to represent data streams from Monotone that can be tied into
# file handles by the caller.
use constant MTN_P_STREAM => 0;
use constant MTN_T_STREAM => 1;
# Constant used to represent the exception thrown when interrupting waitpid().
use constant WAITPID_INTERRUPT => __PACKAGE__ . "::waitpid-interrupt";
# Constant used to represent the in memory database name.
use constant IN_MEMORY_DB_NAME => ":memory:";
# Constants used to represent different value formats.
use constant BARE_PHRASE => 0x001; # E.g. orphaned_directory.
use constant HEX_ID => 0x002; # E.g. [ab2 ... 1be].
use constant NON_UNIQUE => 0x004; # Key can occur more than once.
use constant NULL => 0x008; # Nothing, i.e. we just have the key.
use constant OPTIONAL_HEX_ID => 0x010; # As HEX_ID but also [].
use constant STRING => 0x020; # Quoted string, possibly escaped.
use constant STRING_AND_HEX_ID => 0x040; # E.g. "fileprop" [ab2 ... 1be].
use constant STRING_ENUM => 0x080; # E.g. "rename_source".
use constant STRING_KEY_VALUE => 0x100; # Quoted key and value (STRING).
use constant STRING_LIST => 0x200; # E.g. "..." "...", possibly escaped.
# Private structures for managing inside-out key caching style objects.
my $class_name = __PACKAGE__;
my %class_records;
# Pre-compiled regular expressions for: finding the end of a quoted string
# possibly containing escaped quotes (i.e. " preceeded by a non-backslash
# character or an even number of backslash characters), recognising data locked
# conditions and detecting the beginning of an I/O stanza.
my $closing_quote_re = qr/((^.*[^\\])|^)(\\{2})*\"$/;
my $database_locked_re = qr/.*sqlite error: database is locked.*/;
my $io_stanza_re = qr/^ *([a-z_]+)(?:(?: \S)|(?: ?$))/;
# A map for quickly detecting valid mtn subprocess options and the number of
# their arguments.
my %valid_mtn_options = ("--allow-default-confdir" => 0,
"--allow-workspace" => 0,
"--builtin-rcfile" => 0,
"--clear-rcfiles" => 0,
"--confdir" => 1,
"--key" => 1,
"--keydir" => 1,
"--no-builtin-rcfile" => 0,
"--no-default-confdir" => 0,
"--no-standard-rcfiles" => 0,
"--no-workspace" => 0,
"--norc" => 0,
"--nostd" => 0,
"--rcfile" => 1,
"--root" => 1,
"--ssh-sign" => 1,
"--standard-rcfiles" => 0,
"--use-default-key" => 0);
# A map for quickly detecting all non-argument options that can be used on any
# command.
my %non_arg_options = ("clear-from" => 1,
"clear-to" => 1,
"corresponding-renames" => 1,
"dry-run" => 1,
"ignore-suspend-certs" => 1,
"ignored" => 1,
"merges" => 1,
"move-conflicting-paths" => 1,
"no-corresponding-renames" => 1,
"no-ignore-suspend-certs" => 1,
"no-ignored" => 1,
"no-merges" => 1,
"no-move-conflicting-paths" => 1,
"no-set-default" => 1,
"no-unchanged" => 1,
"no-unknown" => 1,
"reverse" => 1,
"set-default" => 1,
"unchanged" => 1,
"unknown" => 1,
"with-header" => 1,
"without-header" => 1);
# Maps for quickly detecting valid keys and determining their value types.
my %certs_keys = ("key" => HEX_ID | STRING,
"name" => STRING,
"signature" => STRING,
"trust" => STRING_ENUM,
"value" => STRING);
my %generate_key_keys = ("given_name" => STRING,
"hash" => HEX_ID,
"local_name" => STRING,
"name" => STRING,
"private_hash" => HEX_ID,
"private_location" => STRING_LIST,
"public_hash" => HEX_ID,
"public_location" => STRING_LIST);
my %get_attributes_keys = ("attr" => STRING_KEY_VALUE,
"format_version" => STRING_ENUM,
"state" => STRING_ENUM);
my %get_db_variables_keys = ("domain" => STRING,
"entry" => NON_UNIQUE | STRING_KEY_VALUE);
my %get_extended_manifest_of_keys = ("attr" => NON_UNIQUE
| STRING_KEY_VALUE,
"attr_mark" => NON_UNIQUE
| STRING_AND_HEX_ID,
"birth" => HEX_ID,
"content" => HEX_ID,
"content_mark" => HEX_ID,
"dir" => STRING,
"dormant_attr" => NON_UNIQUE | STRING,
"file" => STRING,
"path_mark" => HEX_ID,
"size" => STRING);
my %get_manifest_of_keys = ("attr" => NON_UNIQUE | STRING_KEY_VALUE,
"content" => HEX_ID,
"dir" => STRING,
"file" => STRING,
"format_version" => STRING_ENUM);
my %inventory_keys = ("birth" => HEX_ID,
"changes" => STRING_LIST,
"fs_type" => STRING_ENUM,
"new_path" => STRING,
"new_type" => STRING_ENUM,
"old_path" => STRING,
"old_type" => STRING_ENUM,
"path" => STRING,
"status" => STRING_LIST);
my %keys_keys = %generate_key_keys;
my %options_file_keys = ("branch" => STRING,
"database" => STRING,
"keydir" => STRING);
my %revision_details_keys = ("add_dir" => STRING,
"add_file" => STRING,
"attr" => STRING,
"clear" => STRING,
"content" => HEX_ID,
"delete" => STRING,
"format_version" => STRING_ENUM,
"from" => HEX_ID,
"new_manifest" => HEX_ID,
"old_revision" => OPTIONAL_HEX_ID,
"patch" => STRING,
"rename" => STRING,
"set" => STRING,
"to" => HEX_ID | STRING,
"value" => STRING);
my %show_conflicts_keys = ("ancestor" => OPTIONAL_HEX_ID,
"ancestor_file_id" => HEX_ID,
"ancestor_name" => STRING,
"attr_name" => STRING,
"conflict" => BARE_PHRASE,
"left" => HEX_ID,
"left_attr_state" => STRING,
"left_attr_value" => STRING,
"left_file_id" => HEX_ID,
"left_name" => STRING,
"left_type" => STRING,
"node_type" => STRING,
"resolved_internal" => NULL,
"right" => HEX_ID,
"right_attr_state" => STRING,
"right_attr_value" => STRING,
"right_file_id" => HEX_ID,
"right_name" => STRING,
"right_type" => STRING);
my %sync_keys = ("key" => HEX_ID,
"receive_cert" => STRING,
"receive_key" => HEX_ID,
"receive_revision" => HEX_ID,
"revision" => HEX_ID,
"send_cert" => STRING,
"send_key" => HEX_ID,
"send_revision" => HEX_ID,
"value" => STRING);
my %tags_keys = ("branches" => NULL | STRING_LIST,
"format_version" => STRING_ENUM,
"revision" => HEX_ID,
"signer" => HEX_ID | STRING,
"tag" => STRING);
# Version of Monotone being used.
my $mtn_version;
# Flag for determining whether the mtn subprocess should be started in a
# workspace's root directory.
my $cd_to_ws_root = 1;
# Flag for detemining whether UTF-8 conversion should be done on the data sent
# to and from the mtn subprocess.
my $convert_to_utf8 = 1;
# Error, database locked and io wait callback routine references and associated
# client data.
my $carper = sub { return; };
my $croaker = \&croak;
my $db_locked_handler = sub { return; };
my $io_wait_handler = sub { return; };
my ($db_locked_handler_data,
$error_handler,
$error_handler_data,
$io_wait_handler_data,
$io_wait_handler_timeout,
$warning_handler,
$warning_handler_data);
# ***** FUNCTIONAL PROTOTYPES *****
# Constructors and destructor.
sub new_from_db($;$$);
sub new_from_service($$;$);
sub new_from_ws($;$$);
*new = *new_from_db;
sub DESTROY($);
# Public methods.
sub ancestors($$@);
sub ancestry_difference($$$;@);
sub branches($$);
sub cert($$$$);
sub certs($$$);
sub checkout($$$);
sub children($$$);
sub closedown($);
sub common_ancestors($$@);
sub content_diff($$;$$$@);
sub db_get($$$$);
sub db_locked_condition_detected($);
sub descendents($$@);
sub drop_attribute($$$);
sub drop_db_variables($$;$);
sub drop_public_key($$);
sub erase_ancestors($$;@);
sub erase_descendants($$;@);
sub file_merge($$$$$$);
sub generate_key($$$$);
sub get_attributes($$$;$);
sub get_base_revision_id($$);
sub get_content_changed($$$$);
sub get_corresponding_path($$$$$);
sub get_current_revision($$;$@);
sub get_current_revision_id($$);
sub get_db_name($);
sub get_db_variables($$;$);
sub get_error_message($);
sub get_extended_manifest_of($$$);
sub get_file($$$);
sub get_file_of($$$;$);
sub get_file_size($$$);
sub get_manifest_of($$;$);
sub get_option($$$);
sub get_pid($);
sub get_public_key($$$);
sub get_revision($$$);
sub get_service_name($);
sub get_workspace_root($$);
sub get_ws_path($);
sub graph($$);
sub heads($$;$);
sub identify($$$);
sub ignore_suspend_certs($$);
sub interface_version($$);
sub inventory($$;$@);
sub keys($$);
sub leaves($$);
sub log($$;$$);
sub lua($$$;@);
sub packet_for_fdata($$$);
sub packet_for_fdelta($$$$);
sub packet_for_rdata($$$);
sub packets_for_certs($$$);
sub parents($$$);
sub put_file($$$$);
sub put_public_key($$);
sub put_revision($$$);
sub read_packets($$);
sub register_db_locked_handler(;$$$);
sub register_error_handler($;$$$);
sub register_io_wait_handler(;$$$$);
sub register_stream_handle($$$);
sub roots($$);
sub select($$$);
sub set_attribute($$$$);
sub set_db_variable($$$$);
sub show_conflicts($$;$$$);
sub supports($$);
sub suppress_utf8_conversion($$);
sub switch_to_ws_root($$);
sub sync($$;$$);
sub tags($$;$);
sub toposort($$@);
sub update($;$);
# Public aliased methods.
*attributes = *get_attributes;
*db_set = *set_db_variable;
*genkey = *generate_key;
*pull = *sync;
*push = *sync;
# Private methods and routines.
sub create_object($);
sub error_handler_wrapper($);
sub expand_options($$);
sub get_quoted_value($$$$);
sub get_ws_details($$$);
sub mtn_command($$$$$;@);
sub mtn_command_with_options($$$$$$;@);
sub mtn_read_output_format_1($$);
sub mtn_read_output_format_2($$);
sub parse_kv_record($$$$;$);
sub parse_revision_data($$);
sub startup($);
sub unescape($);
sub validate_database($);
sub validate_mtn_options($);
sub warning_handler_wrapper($);
# ***** PACKAGE INFORMATION *****
# We are just a base class.
use base qw(Exporter);
our %EXPORT_TAGS = (capabilities => [qw(MTN_CHECKOUT
MTN_COMMON_KEY_HASH
MTN_CONTENT_DIFF_EXTRA_OPTIONS
MTN_DB_GET
MTN_DROP_ATTRIBUTE
MTN_DROP_DB_VARIABLES
MTN_DROP_PUBLIC_KEY
MTN_ERASE_DESCENDANTS
MTN_FILE_MERGE
MTN_GENERATE_KEY
MTN_GET_ATTRIBUTES
MTN_GET_ATTRIBUTES_TAKING_OPTIONS
MTN_GET_CURRENT_REVISION
MTN_GET_DB_VARIABLES
MTN_GET_EXTENDED_MANIFEST_OF
MTN_GET_FILE_SIZE
MTN_GET_PUBLIC_KEY
MTN_GET_WORKSPACE_ROOT
MTN_HASHED_SIGNATURES
MTN_IGNORING_OF_SUSPEND_CERTS
MTN_INVENTORY_IN_IO_STANZA_FORMAT
MTN_INVENTORY_TAKING_OPTIONS
MTN_INVENTORY_WITH_BIRTH_ID
MTN_K_SELECTOR
MTN_LOG
MTN_LUA
MTN_M_SELECTOR
MTN_P_SELECTOR
MTN_PUT_PUBLIC_KEY
MTN_READ_PACKETS
MTN_REMOTE_CONNECTIONS
MTN_SELECTOR_FUNCTIONS
MTN_SELECTOR_MIN_FUNCTION
MTN_SELECTOR_NOT_FUNCTION
MTN_SELECTOR_OR_OPERATOR
MTN_SET_ATTRIBUTE
MTN_SET_DB_VARIABLE
MTN_SHOW_CONFLICTS
MTN_STREAM_IO
MTN_SYNCHRONISATION
MTN_SYNCHRONISATION_WITH_OUTPUT
MTN_U_SELECTOR
MTN_UPDATE
MTN_W_SELECTOR)],
severities => [qw(MTN_SEVERITY_ALL
MTN_SEVERITY_ERROR
MTN_SEVERITY_WARNING)],
streams => [qw(MTN_P_STREAM
MTN_T_STREAM)]);
our @EXPORT = qw();
Exporter::export_ok_tags(qw(capabilities severities streams));
our $VERSION = "1.10";
#
##############################################################################
#
# Routine - new_from_db
#
# Description - Class constructor. Construct an object using the specified
# Monotone database.
#
# Data - $class : The name of the class that is to be created.
# $db_name : The full path of the Monotone database. If
# this is not provided then the database
# associated with the current workspace is
# used.
# $options : A reference to a list containing a list of
# options to use on the mtn subprocess.
# Return Value : A reference to the newly created object.
#
##############################################################################
sub new_from_db($;$$)
{
my $class = shift();
my $db_name = (ref($_[0]) eq "ARRAY") ? undef : shift();
my $options = shift();
$options = [] unless (defined($options));
my ($db,
$this,
$self,
$ws_path);
# Check all the arguments given to us.
validate_mtn_options($options);
if (defined($db_name))
{
$db = $db_name;
}
else
{
get_ws_details(getcwd(), \$db, \$ws_path);
}
validate_database($db);
# Actually construct the object.
$self = create_object($class);
$this = $class_records{$self->{$class_name}};
$this->{db_name} = $db_name;
$this->{ws_path} = $ws_path;
$this->{mtn_options} = $options;
# Startup the mtn subprocess (also determining the interface version).
$self->startup();
return $self;
}
#
##############################################################################
#
# Routine - new_from_service
#
# Description - Class constructor. Construct an object using the specified
# Monotone service.
#
# Data - $class : The name of the class that is to be created.
# $service : The name of the Monotone server to connect
# to, either in the form of a Monotone style
# URL or a host name optionally followed by a
# colon and the port number.
# $options : A reference to a list containing a list of
# options to use on the mtn subprocess.
# Return Value : A reference to the newly created object.
#
##############################################################################
sub new_from_service($$;$)
{
my ($class, $service, $options) = @_;
my ($self,
$server,
$this);
$options = [] unless (defined($options));
# Check all the arguments given to us.
validate_mtn_options($options);
# Check the service name, either a Monotone style URL or server name
# followed by an optional colon and port number.
if ($service =~ m/\//)
{
# A URL has been given so extract the host name.
if ($service =~ m/^(?:mtn:\/\/)?([^\/]+)(?:\/.*)?$/)
{
$server = $1;
}
else
{
&$croaker("Invalid URL `" . $service . "'.");
}
}
else
{
# A hostname and optional port number has been given so extract the
# host name part.
if ($service =~ m/^([^:]+):\d+$/)
{
$server = $1;
}
else
{
$server = $service;
}
}
# Check that the hostname is know to us.
&$croaker("`" . $server . "' is not known to the system")
unless (defined(inet_aton($server)));
# Actually construct the object.
$self = create_object($class);
$this = $class_records{$self->{$class_name}};
$this->{db_name} = IN_MEMORY_DB_NAME;
$this->{network_service} = $service;
$this->{mtn_options} = $options;
# Startup the mtn subprocess (also determining the interface version).
$self->startup();
return $self;
}
#
##############################################################################
#
# Routine - new_from_ws
#
# Description - Class constructor. Construct an object using the specified
# Monotone workspace.
#
# Data - $class : The name of the class that is to be created.
# $ws_path : The base directory of a Monotone workspace.
# If this is not provided then the current
# workspace is used.
# $options : A reference to a list containing a list of
# options to use on the mtn subprocess.
# Return Value : A reference to the newly created object.
#
##############################################################################
sub new_from_ws($;$$)
{
my $class = shift();
my $ws_path = (ref($_[0]) eq "ARRAY") ? undef : shift();
my $options = shift();
$options = [] unless (defined($options));
my ($db_name,
$self,
$this);
# Check all the arguments given to us.
validate_mtn_options($options);
if (! defined($ws_path))
{
$ws_path = getcwd();
}
get_ws_details($ws_path, \$db_name, \$ws_path);
validate_database($db_name);
# Actually construct the object.
$self = create_object($class);
$this = $class_records{$self->{$class_name}};
$this->{ws_path} = $ws_path;
$this->{ws_constructed} = 1;
$this->{mtn_options} = $options;
# Startup the mtn subprocess (also determining the interface version).
$self->startup();
return $self;
}
#
##############################################################################
#
# Routine - DESTROY
#
# Description - Class destructor.
#
# Data - $self : The object.
#
##############################################################################
sub DESTROY($)
{
my $self = $_[0];
# Make sure the destructor doesn't throw any exceptions and that any
# existing exception status is preserved, otherwise constructor
# exceptions could be lost. E.g. if the constructor throws an exception
# after blessing the object, Perl immediately calls the destructor,
# which calls code that could use eval thereby resetting $@. Why not
# simply call bless as the last statement in the constructor? Well
# firstly callbacks can be called in the constructor and they have the
# object passed to them as their first argument and so it needs to be
# blessed, secondly the mtn subprocess needs to be properly closed down
# if there is an exception, which it won't be unless the destructor is
# called.
local $@;
eval
{
eval
{
$self->closedown();
};
delete($class_records{$self->{$class_name}});
};
}
#
##############################################################################
#
# Routine - ancestors
#
# Description - Get a list of ancestors for the specified revisions.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain
# the revision ids.
# @revision_ids : The revision ids that are to have their
# ancestors returned.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub ancestors($$@)
{
my ($self, $list, @revision_ids) = @_;
return $self->mtn_command("ancestors", 0, 0, $list, @revision_ids);
}
#
##############################################################################
#
# Routine - ancestry_difference
#
# Description - Get a list of ancestors for the specified revision, that
# are not also ancestors for the specified old revisions.
#
# Data - $self : The object.
# $list : A reference to a list that is to
# contain the revision ids.
# $new_revision_id : The revision id that is to have its
# ancestors returned.
# @old_revision_ids : The revision ids that are to have their
# ancestors excluded from the above list.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub ancestry_difference($$$;@)
{
my ($self, $list, $new_revision_id, @old_revision_ids) = @_;
return $self->mtn_command("ancestry_difference",
0,
0,
$list,
$new_revision_id,
@old_revision_ids);
}
#
##############################################################################
#
# Routine - branches
#
# Description - Get a list of branches.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# branch names.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub branches($$)
{
my ($self, $list) = @_;
return $self->mtn_command("branches", 0, 1, $list);
}
#
##############################################################################
#
# Routine - cert
#
# Description - Add the specified cert to the specified revision.
#
# Data - $self : The object.
# $revision_id : The revision id to which the cert is to be
# applied.
# $name : The name of the cert to be applied.
# $value : The value of the cert.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub cert($$$$)
{
my ($self, $revision_id, $name, $value) = @_;
my $dummy;
return $self->mtn_command("cert",
1,
1,
\$dummy,
$revision_id,
$name,
$value);
}
#
##############################################################################
#
# Routine - certs
#
# Description - Get all the certs for the specified revision.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $revision_id : The id of the revision that is to have its
# certs returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub certs($$$)
{
my ($self, $ref, $revision_id) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("certs", 0, 1, $ref, $revision_id);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command("certs", 0, 1, \@lines, $revision_id))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines, \$i, \%certs_keys, \$kv_record);
-- $i;
# Validate it in terms of expected fields and store.
foreach my $key ("key", "name", "signature", "trust", "value")
{
&$croaker("Corrupt certs list, expected " . $key
. " field but did not find it")
unless (exists($kv_record->{$key}));
}
push(@$ref, $kv_record);
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - checkout
#
# Description - Create a new workspace from the specified branch and or
# revision.
#
# Data - $self : The object.
# $options : A reference to a list containing the options
# to use.
# $ws_dir : The name of the directory that is to be
# created with a workspace inside of it.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub checkout($$$)
{
my ($self, $options, $ws_dir) = @_;
my ($dummy,
@opts);
# Process any options.
expand_options($options, \@opts);
# Run the command.
return $self->mtn_command_with_options("checkout",
0,
0,
\$dummy,
\@opts,
$ws_dir);
}
#
##############################################################################
#
# Routine - children
#
# Description - Get a list of children for the specified revision.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# revision ids.
# $revision_id : The revision id that is to have its children
# returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub children($$$)
{
my ($self, $list, @revision_ids) = @_;
return $self->mtn_command("children", 0, 0, $list, @revision_ids);
}
#
##############################################################################
#
# Routine - common_ancestors
#
# Description - Get a list of revisions that are all ancestors of the
# specified revision.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain
# the revision ids.
# @revision_ids : The revision ids that are to have their
# common ancestors returned.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub common_ancestors($$@)
{
my ($self, $list, @revision_ids) = @_;
return $self->mtn_command("common_ancestors", 0, 0, $list, @revision_ids);
}
#
##############################################################################
#
# Routine - content_diff
#
# Description - Get the difference between the two specified revisions,
# optionally limiting the output by using the specified
# options and file restrictions. If the second revision id is
# undefined then the workspace's current revision is used. If
# both revision ids are undefined then the workspace's
# current and base revisions are used. If no file names are
# listed then differences in all files are reported.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $options : A reference to a list containing the
# options to use.
# $revision_id1 : The first revision id to compare against.
# $revision_id2 : The second revision id to compare against.
# @file_names : The list of file names that are to be
# reported on.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub content_diff($$;$$$@)
{
my ($self, $buffer, $options, $revision_id1, $revision_id2, @file_names)
= @_;
my @opts;
# Process any options.
expand_options($options, \@opts);
push(@opts, {key => "r", value => $revision_id1})
if (defined($revision_id1));
push(@opts, {key => "r", value => $revision_id2})
if (defined($revision_id2));
return $self->mtn_command_with_options("content_diff",
1,
1,
$buffer,
\@opts,
@file_names);
}
#
##############################################################################
#
# Routine - db_get
#
# Description - Get the value of a database variable.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $domain : The domain of the database variable.
# $name : The name of the variable to fetch.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub db_get($$$$)
{
my ($self, $buffer, $domain, $name) = @_;
return $self->mtn_command("db_get", 1, 1, $buffer, $domain, $name);
}
#
##############################################################################
#
# Routine - descendents
#
# Description - Get a list of descendents for the specified revisions.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain
# the revision ids.
# @revision_ids : The revision ids that are to have their
# descendents returned.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub descendents($$@)
{
my ($self, $list, @revision_ids) = @_;
return $self->mtn_command("descendents", 0, 0, $list, @revision_ids);
}
#
##############################################################################
#
# Routine - drop_attribute
#
# Description - Drop attributes from the specified file or directory,
# optionally limiting it to the specified attribute.
#
# Data - $self : The object.
# $path : The name of the file or directory that is to
# have an attribute dropped.
# $key : The name of the attribute that as to be
# dropped.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub drop_attribute($$$)
{
my ($self, $path, $key) = @_;
my $dummy;
return $self->mtn_command("drop_attribute", 1, 0, \$dummy, $path, $key);
}
#
##############################################################################
#
# Routine - drop_db_variables
#
# Description - Drop variables from the specified domain, optionally
# limiting it to the specified variable.
#
# Data - $self : The object.
# $domain : The name of the domain that is to have one
# or all of its variables dropped.
# $name : The name of the variable that is to be
# dropped.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub drop_db_variables($$;$)
{
my ($self, $domain, $name) = @_;
my $dummy;
return $self->mtn_command("drop_db_variables",
1,
0,
\$dummy,
$domain,
$name);
}
#
##############################################################################
#
# Routine - drop_public_key
#
# Description - Drop the public key from the database for the specified key
# id.
#
# Data - $self : The object.
# $key_id : The id of the key, either in the form of its
# name or its hash.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub drop_public_key($$)
{
my ($self, $key_id) = @_;
my $dummy;
return $self->mtn_command("drop_public_key", 1, 0, \$dummy, $key_id);
}
#
##############################################################################
#
# Routine - erase_ancestors
#
# Description - For a given list of revisions, weed out those that are
# ancestors to other revisions specified within the list.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain
# the revision ids.
# @revision_ids : The revision ids that are to have their
# ancestors removed from the list.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub erase_ancestors($$;@)
{
my ($self, $list, @revision_ids) = @_;
return $self->mtn_command("erase_ancestors", 0, 0, $list, @revision_ids);
}
#
##############################################################################
#
# Routine - erase_descendants
#
# Description - For a given list of revisions, weed out those that are
# descendants to other revisions specified within the list.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain
# the revision ids.
# @revision_ids : The revision ids that are to have their
# descendents removed from the list.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub erase_descendants($$;@)
{
my ($self, $list, @revision_ids) = @_;
return $self->mtn_command("erase_descendants", 0, 0, $list, @revision_ids);
}
#
##############################################################################
#
# Routine - file_merge
#
# Description - Get the result of merging two files, both of which are on
# separate revisions.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to
# contain the output from this command.
# $left_revision_id : The left hand revision id.
# $left_file_name : The name of the file on the left hand
# revision.
# $right_revision_id : The right hand revision id.
# $right_file_name : The name of the file on the right hand
# revision.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub file_merge($$$$$$)
{
my ($self,
$buffer,
$left_revision_id,
$left_file_name,
$right_revision_id,
$right_file_name) = @_;
return $self->mtn_command("file_merge",
1,
1,
$buffer,
$left_revision_id,
$left_file_name,
$right_revision_id,
$right_file_name);
}
#
##############################################################################
#
# Routine - generate_key
#
# Description - Generate a new key for use within the database.
#
# Data - $self : The object.
# $ref : A reference to a buffer or a hash that is to
# contain the output from this command.
# $key_id : The key id for the new key.
# $pass_phrase : The pass phrase for the key.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub generate_key($$$$)
{
my ($self, $ref, $key_id, $pass_phrase) = @_;
my $cmd;
# This command was renamed in version 0.99.1 (i/f version 13.x).
if ($self->supports(MTN_GENERATE_KEY))
{
$cmd = "generate_key";
}
else
{
$cmd = "genkey";
}
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command($cmd, 1, 1, $ref, $key_id, $pass_phrase);
}
else
{
my ($i,
$kv_record,
@lines);
if (! $self->mtn_command($cmd, 1, 1, \@lines, $key_id, $pass_phrase))
{
return;
}
# Reformat the data into a structured record.
# Get the key-value record.
$i = 0;
parse_kv_record(\@lines, \$i, \%generate_key_keys, \$kv_record);
# Copy across the fields.
%$ref = ();
foreach my $key (CORE::keys(%$kv_record))
{
$$ref{$key} = $kv_record->{$key};
}
return 1;
}
}
#
##############################################################################
#
# Routine - get_attributes
#
# Description - Get the attributes of the specified file under the
# specified revision. If the revision id is undefined then
# the current workspace revision is used.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $file_name : The name of the file that is to be reported
# on.
# $revision_id : The revision id upon which the file
# attributes are to be based.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_attributes($$$;$)
{
my ($self, $ref, $file_name, $revision_id) = @_;
my ($cmd,
@opts);
# This command was renamed in version 0.36 (i/f version 5.x).
if ($self->supports(MTN_GET_ATTRIBUTES))
{
$cmd = "get_attributes";
}
else
{
$cmd = "attributes";
}
# Deal with the optional revision id option.
push(@opts, {key => "r", value => $revision_id})
if (defined($revision_id));
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command_with_options($cmd,
1,
1,
$ref,
\@opts,
$file_name);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command_with_options($cmd,
1,
1,
\@lines,
\@opts,
$file_name))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines,
\$i,
\%get_attributes_keys,
\$kv_record);
-- $i;
# Validate it in terms of expected fields and store.
if (exists($kv_record->{attr}))
{
&$croaker("Corrupt attributes list, expected state field "
. "but did not find it")
unless (exists($kv_record->{state}));
push(@$ref, {attribute => $kv_record->{attr}->[0],
value => $kv_record->{attr}->[1],
state => $kv_record->{state}});
}
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - get_base_revision_id
#
# Description - Get the id of the revision upon which the workspace is
# based.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_base_revision_id($$)
{
my ($self, $buffer) = @_;
my @list;
$$buffer = "";
if (! $self->mtn_command("get_base_revision_id", 0, 0, \@list))
{
return;
}
$$buffer = $list[0];
return 1;
}
#
##############################################################################
#
# Routine - get_content_changed
#
# Description - Get a list of revisions in which the content was most
# recently changed, relative to the specified revision.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# revision ids.
# $revision_id : The id of the revision of the manifest that
# is to be returned.
# $file_name : The name of the file that is to be reported
# on.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_content_changed($$$$)
{
my ($self, $list, $revision_id, $file_name) = @_;
my ($i,
@lines);
# Run the command and get the data.
if (! $self->mtn_command("get_content_changed",
1,
0,
\@lines,
$revision_id,
$file_name))
{
return;
}
# Reformat the data into a list.
for ($i = 0, @$list = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/^ *content_mark \[([0-9a-f]+)\]$/)
{
push(@$list, $1);
}
}
return 1;
}
#
##############################################################################
#
# Routine - get_corresponding_path
#
# Description - For the specified file name in the specified source
# revision, return the corresponding file name for the
# specified target revision.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to
# contain the output from this command.
# $source_revision_id : The source revision id.
# $file_name : The name of the file that is to be
# searched for.
# $target_revision_id : The target revision id.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub get_corresponding_path($$$$$)
{
my ($self, $buffer, $source_revision_id, $file_name, $target_revision_id)
= @_;
my ($i,
@lines);
# Run the command and get the data.
if (! $self->mtn_command("get_corresponding_path",
1,
1,
\@lines,
$source_revision_id,
$file_name,
$target_revision_id))
{
return;
}
# Extract the file name.
for ($i = 0, $$buffer = ""; $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/^ *file \"/)
{
get_quoted_value(\@lines, \$i, 0, $buffer);
$$buffer = unescape($$buffer);
}
}
return 1;
}
#
##############################################################################
#
# Routine - get_current_revision
#
# Description - Get the revision information for the current revision,
# optionally limiting the output by using the specified
# options and file restrictions.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $options : A reference to a list containing the options
# to use.
# @paths : A list of files or directories that are to
# be reported on instead of the entire
# workspace.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_current_revision($$;$@)
{
my ($self, $ref, $options, @paths) = @_;
my @opts;
# Process any options.
expand_options($options, \@opts);
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command_with_options("get_current_revision",
1,
1,
$ref,
\@opts,
@paths);
}
else
{
my @lines;
if (! $self->mtn_command_with_options("get_current_revision",
1,
1,
\@lines,
\@opts,
@paths))
{
return;
}
parse_revision_data($ref, \@lines);
return 1;
}
}
#
##############################################################################
#
# Routine - get_current_revision_id
#
# Description - Get the id of the revision that would be created if an
# unrestricted commit was done in the workspace.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_current_revision_id($$)
{
my ($self, $buffer) = @_;
my @list;
$$buffer = "";
if (! $self->mtn_command("get_current_revision_id", 0, 0, \@list))
{
return;
}
$$buffer = $list[0];
return 1;
}
#
##############################################################################
#
# Routine - get_db_variables
#
# Description - Get the variables stored in the database, optionally
# limiting it to the specified domain.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $domain : The name of the domain that is to have its
# variables listed.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_db_variables($$;$)
{
my ($self, $ref, $domain) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("get_db_variables", 1, 1, $ref, $domain);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command("get_db_variables", 1, 1, \@lines, $domain))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines,
\$i,
\%get_db_variables_keys,
\$kv_record);
-- $i;
# Validate it in terms of expected fields and copy data across
# to the correct fields.
if (! exists($kv_record->{domain})
|| ! exists($kv_record->{entry}))
{
&$croaker("Corrupt database variables list, expected "
. "domain and entry fields but did not find "
. "them");
}
foreach my $entry (@{$kv_record->{entry}})
{
push(@$ref, {domain => $kv_record->{domain},
name => $entry->[0],
value => $entry->[1]});
}
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - get_extended_manifest_of
#
# Description - Get the extended manifest for the specified revision.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $revision_id : The revision id which is to have its
# extended manifest returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_extended_manifest_of($$$)
{
my ($self, $ref, $revision_id) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("get_extended_manifest_of",
0,
1,
$ref,
$revision_id);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command("get_extended_manifest_of",
0,
1,
\@lines,
$revision_id))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines,
\$i,
\%get_extended_manifest_of_keys,
\$kv_record);
-- $i;
# Validate it in terms of expected fields.
if (! exists($kv_record->{dir})
&& ! exists($kv_record->{file}))
{
&$croaker("Corrupt extended manifest list, expected dir "
. "or file field but did not find them");
}
# Set up the name and type fields.
if (exists($kv_record->{file}))
{
$kv_record->{type} = "file";
$kv_record->{name} = $kv_record->{file};
delete($kv_record->{file});
}
elsif (exists($kv_record->{dir}))
{
$kv_record->{type} = "directory";
$kv_record->{name} = $kv_record->{dir};
delete($kv_record->{dir});
}
# Now reformat some fields to be more meaningful/consistent.
if (exists($kv_record->{attr}))
{
my $value = [];
foreach my $entry (@{$kv_record->{attr}})
{
push(@$value, {attribute => $entry->[0],
value => $entry->[1]});
}
$kv_record->{attributes} = $value;
delete($kv_record->{attr});
}
if (exists($kv_record->{attr_mark}))
{
my $value = [];
foreach my $entry (@{$kv_record->{attr_mark}})
{
push(@$value, {attribute => $entry->[0],
revision_id => $entry->[1]});
}
$kv_record->{attr_mark} = $value;
}
if (exists($kv_record->{content}))
{
$kv_record->{file_id} = $kv_record->{content};
delete($kv_record->{content});
}
# Store the record.
push(@$ref, $kv_record);
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - get_file
#
# Description - Get the contents of the file referenced by the specified
# file id.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $file_id : The file id of the file that is to be
# returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_file($$$)
{
my ($self, $buffer, $file_id) = @_;
return $self->mtn_command("get_file", 0, 0, $buffer, $file_id);
}
#
##############################################################################
#
# Routine - get_file_of
#
# Description - Get the contents of the specified file under the specified
# revision. If the revision id is undefined then the current
# workspace revision is used.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $file_name : The name of the file to be fetched.
# $revision_id : The revision id upon which the file contents
# are to be based.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_file_of($$$;$)
{
my ($self, $buffer, $file_name, $revision_id) = @_;
my @opts;
push(@opts, {key => "r", value => $revision_id})
if (defined($revision_id));
return $self->mtn_command_with_options("get_file_of",
1,
0,
$buffer,
\@opts,
$file_name);
}
#
##############################################################################
#
# Routine - get_file_size
#
# Description - Get the size of the file referenced by the specified file
# id.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $file_id : The file id of the file that is to have its
# size returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_file_size($$$)
{
my ($self, $buffer, $file_id) = @_;
my @list;
$$buffer = "";
if (! $self->mtn_command("get_file_size", 0, 0, \@list, $file_id))
{
return;
}
$$buffer = $list[0];
return 1;
}
#
##############################################################################
#
# Routine - get_manifest_of
#
# Description - Get the manifest for the current or specified revision.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $revision_id : The revision id which is to have its
# manifest returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_manifest_of($$;$)
{
my ($self, $ref, $revision_id) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("get_manifest_of", 0, 1, $ref, $revision_id);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command("get_manifest_of",
0,
1,
\@lines,
$revision_id))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines,
\$i,
\%get_manifest_of_keys,
\$kv_record);
-- $i;
# Validate it in terms of expected fields and copy data across
# to the correct fields.
if (exists($kv_record->{file}) || exists($kv_record->{dir}))
{
my ($attrs,
$id,
$name,
$type);
if (exists($kv_record->{file}))
{
$type = "file";
$name = $kv_record->{file};
&$croaker("Corrupt manifest, expected content field "
. "but did not find it")
unless (exists($kv_record->{content}));
$id = $kv_record->{content};
}
elsif (exists($kv_record->{dir}))
{
$type = "directory";
$name = $kv_record->{dir};
}
$attrs = [];
if (exists($kv_record->{attr}))
{
foreach my $entry (@{$kv_record->{attr}})
{
push(@$attrs, {attribute => $entry->[0],
value => $entry->[1]});
}
}
if ($type eq "file")
{
push(@$ref, {type => $type,
name => $name,
file_id => $id,
attributes => $attrs});
}
else
{
push(@$ref, {type => $type,
name => $name,
attributes => $attrs});
}
}
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - get_option
#
# Description - Get the value of an option stored in a workspace's _MTN
# directory.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $option_name : The name of the option to be fetched.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_option($$$)
{
my ($self, $buffer, $option_name) = @_;
if (! $self->mtn_command("get_option", 1, 1, $buffer, $option_name))
{
return;
}
chomp($$buffer);
return 1;
}
#
##############################################################################
#
# Routine - get_public_key
#
# Description - Get the public key for the specified key id.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $key_id : The id of the key, either in the form of its
# name or its hash.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_public_key($$$)
{
my ($self, $buffer, $key_id) = @_;
return $self->mtn_command("get_public_key", 1, 1, $buffer, $key_id);
}
#
##############################################################################
#
# Routine - get_revision
#
# Description - Get the revision information for the current or specified
# revision.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $revision_id : The revision id which is to have its data
# returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_revision($$$)
{
my ($self, $ref, $revision_id) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("get_revision", 0, 1, $ref, $revision_id);
}
else
{
my @lines;
if (! $self->mtn_command("get_revision", 0, 1, \@lines, $revision_id))
{
return;
}
parse_revision_data($ref, \@lines);
return 1;
}
}
#
##############################################################################
#
# Routine - get_workspace_root
#
# Description - Get the absolute path for the current workspace's root
# directory.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub get_workspace_root($$)
{
my ($self, $buffer) = @_;
if (! $self->mtn_command("get_workspace_root", 0, 1, $buffer))
{
return;
}
chomp($$buffer);
return 1;
}
#
##############################################################################
#
# Routine - graph
#
# Description - Get a complete ancestry graph of the database.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub graph($$)
{
my ($self, $ref) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("graph", 0, 0, $ref);
}
else
{
my ($i,
@lines,
@parent_ids);
if (! $self->mtn_command("graph", 0, 0, \@lines))
{
return;
}
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
@parent_ids = split(/ /, $lines[$i]);
$$ref[$i] = {revision_id => shift(@parent_ids),
parent_ids => [@parent_ids]};
}
return 1;
}
}
#
##############################################################################
#
# Routine - heads
#
# Description - Get a list of revision ids that are heads on the specified
# branch. If no branch is given then the workspace's branch
# is used.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# revision ids.
# $branch_name : The name of the branch that is to have its
# heads returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub heads($$;$)
{
my ($self, $list, $branch_name) = @_;
return $self->mtn_command("heads", 1, 0, $list, $branch_name);
}
#
##############################################################################
#
# Routine - identify
#
# Description - Get the file id, i.e. hash, of the specified file.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $file_name : The name of the file that is to have its id
# returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub identify($$$)
{
my ($self, $buffer, $file_name) = @_;
my @list;
$$buffer = "";
if (! $self->mtn_command("identify", 1, 0, \@list, $file_name))
{
return;
}
$$buffer = $list[0];
return 1;
}
#
##############################################################################
#
# Routine - interface_version
#
# Description - Get the version of the mtn automate interface.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub interface_version($$)
{
my ($self, $buffer) = @_;
my @list;
$$buffer = "";
if (! $self->mtn_command("interface_version", 0, 0, \@list))
{
return;
}
$$buffer = $list[0];
return 1;
}
#
##############################################################################
#
# Routine - inventory
#
# Description - Get the inventory for the current workspace, optionally
# limiting the output by using the specified options and file
# restrictions.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $options : A reference to a list containing the options
# to use.
# @paths : A list of files or directories that are to
# be reported on instead of the entire
# workspace.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub inventory($$;$@)
{
my ($self, $ref, $options, @paths) = @_;
my @opts;
# Process any options.
expand_options($options, \@opts);
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command_with_options("inventory",
1,
1,
$ref,
\@opts,
@paths);
}
else
{
my @lines;
if (! $self->mtn_command_with_options("inventory",
1,
1,
\@lines,
\@opts,
@paths))
{
return;
}
# The output format of this command was switched over to a basic_io
# stanza in 0.37 (i/f version 6.x).
if ($self->supports(MTN_INVENTORY_IN_IO_STANZA_FORMAT))
{
my $i;
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record and store it in the list.
parse_kv_record(\@lines,
\$i,
\%inventory_keys,
\$kv_record);
-- $i;
push(@$ref, $kv_record);
}
}
}
else
{
my $i;
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/^([A-Z ]{3}) (\d+) (\d+) (.+)$/)
{
push(@$ref, {status => $1,
crossref_one => $2,
crossref_two => $3,
name => $4});
}
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - keys
#
# Description - Get a list of all the keys known to mtn.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub keys($$)
{
my ($self, $ref) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("keys", 0, 1, $ref);
}
else
{
my ($i,
@lines,
@valid_fields);
if (! $self->mtn_command("keys", 0, 1, \@lines))
{
return;
}
# Build up a list of valid fields depending upon the version of
# Monotone in use.
push(@valid_fields, "given_name", "local_name")
if ($self->supports(MTN_HASHED_SIGNATURES));
if ($self->supports(MTN_COMMON_KEY_HASH))
{
push(@valid_fields, "hash");
}
else
{
push(@valid_fields, "public_hash");
}
push(@valid_fields, "public_location");
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines, \$i, \%keys_keys, \$kv_record);
-- $i;
# Validate it in terms of expected fields and store.
foreach my $key (@valid_fields)
{
&$croaker("Corrupt keys list, expected " . $key
. " field but did not find it")
unless (exists($kv_record->{$key}));
}
push(@$ref, $kv_record);
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - leaves
#
# Description - Get a list of leaf revisions.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# revision ids.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub leaves($$)
{
my ($self, $list) = @_;
return $self->mtn_command("leaves", 0, 0, $list);
}
#
##############################################################################
#
# Routine - log
#
# Description - Get a list of revision ids that form a log history for an
# entire project, optionally limiting the output by using the
# specified options and file name restrictions.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# branch names.
# $options : A reference to a list containing the options
# to use.
# $file_name : The name of the file that is to be reported
# on instead of the entire project.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub log($$;$$)
{
my ($self, $list, $options, $file_name) = @_;
my @opts;
# Process any options.
expand_options($options, \@opts);
# Run the command and get the data.
return $self->mtn_command_with_options("log",
1,
1,
$list,
\@opts,
$file_name);
}
#
##############################################################################
#
# Routine - lua
#
# Description - Call the specified LUA function with any required
# arguments.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $lua_function : The name of the LUA function that is to be
# called.
# @arguments : A list of arguments that are to be passed
# to the LUA function.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub lua($$$;@)
{
my ($self, $buffer, $lua_function, @arguments) = @_;
return $self->mtn_command("lua", 1, 1, $buffer, $lua_function, @arguments);
}
#
##############################################################################
#
# Routine - packet_for_fdata
#
# Description - Get the contents of the file referenced by the specified
# file id in packet format.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $file_id : The file id of the file that is to be
# returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub packet_for_fdata($$$)
{
my ($self, $buffer, $file_id) = @_;
return $self->mtn_command("packet_for_fdata", 0, 0, $buffer, $file_id);
}
#
##############################################################################
#
# Routine - packet_for_fdelta
#
# Description - Get the file delta between the two files referenced by the
# specified file ids in packet format.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $from_file_id : The file id of the file that is to be used
# as the base in the delta operation.
# $to_file_id : The file id of the file that is to be used
# as the target in the delta operation.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub packet_for_fdelta($$$$)
{
my ($self, $buffer, $from_file_id, $to_file_id) = @_;
return $self->mtn_command("packet_for_fdelta",
0,
0,
$buffer,
$from_file_id,
$to_file_id);
}
#
##############################################################################
#
# Routine - packet_for_rdata
#
# Description - Get the contents of the revision referenced by the
# specified revision id in packet format.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $revision_id : The revision id of the revision that is to
# be returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub packet_for_rdata($$$)
{
my ($self, $buffer, $revision_id) = @_;
return $self->mtn_command("packet_for_rdata", 0, 0, $buffer, $revision_id);
}
#
##############################################################################
#
# Routine - packets_for_certs
#
# Description - Get all the certs for the revision referenced by the
# specified revision id in packet format.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $revision_id : The revision id of the revision that is to
# have its certs returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub packets_for_certs($$$)
{
my ($self, $buffer, $revision_id) = @_;
return $self->mtn_command("packets_for_certs",
0,
0,
$buffer,
$revision_id);
}
#
##############################################################################
#
# Routine - parents
#
# Description - Get a list of parents for the specified revision.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# revision ids.
# $revision_id : The revision id that is to have its parents
# returned.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub parents($$$)
{
my ($self, $list, $revision_id) = @_;
return $self->mtn_command("parents", 0, 0, $list, $revision_id);
}
#
##############################################################################
#
# Routine - put_file
#
# Description - Put the specified file contents into the database,
# optionally basing it on the specified file id (this is used
# for delta encoding).
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $base_file_id : The file id of the previous version of this
# file or undef if this is a new file.
# $contents : A reference to a buffer containing the
# file's contents.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub put_file($$$$)
{
my ($self, $buffer, $base_file_id, $contents) = @_;
my @list;
if (defined($base_file_id))
{
if (! $self->mtn_command("put_file",
0,
0,
\@list,
$base_file_id,
$contents))
{
return;
}
}
else
{
if (! $self->mtn_command("put_file", 0, 0, \@list, $contents))
{
return;
}
}
$$buffer = $list[0];
return 1;
}
#
##############################################################################
#
# Routine - put_public_key
#
# Description - Put the specified public key data into the database.
#
# Data - $self : The object.
# $public_key : The public key data that is to be stored in
# the database.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub put_public_key($$)
{
my ($self, $public_key) = @_;
my $dummy;
return $self->mtn_command("put_public_key", 1, 0, \$dummy, $public_key);
}
#
##############################################################################
#
# Routine - put_revision
#
# Description - Put the specified revision data into the database.
#
# Data - $self : The object.
# $buffer : A reference to a buffer that is to contain
# the output from this command.
# $contents : A reference to a buffer containing the
# revision's contents.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub put_revision($$$)
{
my ($self, $buffer, $contents) = @_;
my @list;
if (! $self->mtn_command("put_revision", 1, 0, \@list, $contents))
{
return;
}
$$buffer = $list[0];
return 1;
}
#
##############################################################################
#
# Routine - read_packets
#
# Description - Decode and store the specified packet data in the database.
#
# Data - $self : The object.
# $packet_data : The packet data that is to be stored in the
# database.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub read_packets($$)
{
my ($self, $packet_data) = @_;
my $dummy;
return $self->mtn_command("read_packets", 0, 0, \$dummy, $packet_data);
}
#
##############################################################################
#
# Routine - roots
#
# Description - Get a list of root revisions, i.e. revisions with no
# parents.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# revision ids.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub roots($$)
{
my ($self, $list) = @_;
return $self->mtn_command("roots", 0, 0, $list);
}
#
##############################################################################
#
# Routine - select
#
# Description - Get a list of revision ids that match the specified
# selector.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain the
# revision ids.
# $selector : The selector that is to be used.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub select($$$)
{
my ($self, $list, $selector) = @_;
return $self->mtn_command("select", 1, 0, $list, $selector);
}
#
##############################################################################
#
# Routine - set_attribute
#
# Description - Set an attribute on the specified file or directory.
#
# Data - $self : The object.
# $path : The name of the file or directory that is to
# have an attribute set.
# $key : The name of the attribute that as to be set.
# $value : The value that the attribute is to be set
# to.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub set_attribute($$$$)
{
my ($self, $path, $key, $value) = @_;
my $dummy;
return $self->mtn_command("set_attribute",
1,
0,
\$dummy,
$path,
$key,
$value);
}
#
##############################################################################
#
# Routine - set_db_variable
#
# Description - Set the value of a database variable.
#
# Data - $self : The object.
# $domain : The domain of the database variable.
# $name : The name of the variable to set.
# $value : The value to set the variable to.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub set_db_variable($$$$)
{
my ($self, $domain, $name, $value) = @_;
my ($cmd,
$dummy);
# This command was renamed in version 0.39 (i/f version 7.x).
if ($self->supports(MTN_SET_DB_VARIABLE))
{
$cmd = "set_db_variable";
}
else
{
$cmd = "db_set";
}
return $self->mtn_command($cmd, 1, 0, \$dummy, $domain, $name, $value);
}
#
##############################################################################
#
# Routine - show_conflicts
#
# Description - Get a list of conflicts between the first two head
# revisions on the current branch, optionally one can specify
# both head revision ids and the name of the branch that they
# reside on.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array
# that is to contain the output from
# this command.
# $branch : The name of the branch that the head
# revisions are on.
# $left_revision_id : The left hand head revision id.
# $right_revision_id : The right hand head revision id.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub show_conflicts($$;$$$)
{
my ($self, $ref, $branch, $left_revision_id, $right_revision_id) = @_;
my @opts;
my $this = $class_records{$self->{$class_name}};
# Validate the number of arguments and adjust them accordingly.
if (scalar(@_) == 4)
{
# Assume just the revision ids were given, so adjust the arguments
# accordingly.
$right_revision_id = $left_revision_id;
$left_revision_id = $branch;
$branch = undef;
}
elsif (scalar(@_) < 2 || scalar(@_) > 5)
{
# Wrong number of arguments.
&$croaker("Wrong number of arguments given");
}
# Process any options.
@opts = ({key => "branch", value => $branch}) if (defined($branch));
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command_with_options("show_conflicts",
1,
1,
$ref,
\@opts,
$left_revision_id,
$right_revision_id);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command_with_options("show_conflicts",
1,
1,
\@lines,
\@opts,
$left_revision_id,
$right_revision_id))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines,
\$i,
\%show_conflicts_keys,
\$kv_record);
-- $i;
# Validate it in terms of expected fields and store.
if (exists($kv_record->{left}))
{
foreach my $key ("ancestor", "right")
{
&$croaker("Corrupt show_conflicts list, expected "
. $key . " field but did not find it")
unless (exists($kv_record->{$key}));
}
}
push(@$ref, $kv_record);
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - sync
#
# Description - Synchronises database changes between the local database
# and the specified remote server. This member function also
# provides the implementation to the pull and push methods.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $options : A reference to a list containing the options
# to use.
# $uri : The URI that is to be synchronised with.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub sync($$;$$)
{
my ($self, $ref, $options, $uri) = @_;
my ($cmd,
@opts);
# Find out how we were called (and hence the command that is to be run).
# Remember that the routine name will be fully qualified.
$cmd = (caller(0))[3];
$cmd = $1 if ($cmd =~ m/^.+\:\:([^:]+)$/);
# Process any options.
expand_options($options, \@opts);
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command_with_options($cmd,
1,
1,
$ref,
\@opts,
$uri);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command_with_options($cmd,
1,
1,
\@lines,
\@opts,
$uri))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record and store it in the list.
parse_kv_record(\@lines,
\$i,
\%sync_keys,
\$kv_record);
-- $i;
push(@$ref, $kv_record);
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - tags
#
# Description - Get all the tags attached to revisions on branches that
# match the specified branch pattern. If no pattern is given
# then all branches are searched.
#
# Data - $self : The object.
# $ref : A reference to a buffer or an array that
# is to contain the output from this
# command.
# $branch_pattern : The branch name pattern that the search
# is to be limited to.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub tags($$;$)
{
my ($self, $ref, $branch_pattern) = @_;
# Run the command and get the data, either as one lump or as a structured
# list.
if (ref($ref) eq "SCALAR")
{
return $self->mtn_command("tags", 1, 1, $ref, $branch_pattern);
}
else
{
my ($i,
@lines);
if (! $self->mtn_command("tags", 1, 1, \@lines, $branch_pattern))
{
return;
}
# Reformat the data into a structured array.
for ($i = 0, @$ref = (); $i < scalar(@lines); ++ $i)
{
if ($lines[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record(\@lines, \$i, \%tags_keys, \$kv_record);
-- $i;
# Validate it in terms of expected fields and store.
if (exists($kv_record->{tag}))
{
foreach my $key ("revision", "signer")
{
&$croaker("Corrupt tags list, expected " . $key
. " field but did not find it")
unless (exists($kv_record->{$key}));
}
$kv_record->{branches} = []
unless (exists($kv_record->{branches})
&& defined($kv_record->{branches}));
$kv_record->{revision_id} = $kv_record->{revision};
delete($kv_record->{revision});
push(@$ref, $kv_record);
}
}
}
return 1;
}
}
#
##############################################################################
#
# Routine - toposort
#
# Description - Sort the specified revision ids such that the ancestors
# come out first.
#
# Data - $self : The object.
# $list : A reference to a list that is to contain
# the revision ids.
# @revision_ids : The revision ids that are to be sorted with
# the ancestors coming first.
# Return Value : True on success, otherwise false on
# failure.
#
##############################################################################
sub toposort($$@)
{
my ($self, $list, @revision_ids) = @_;
return $self->mtn_command("toposort", 0, 0, $list, @revision_ids);
}
#
##############################################################################
#
# Routine - update
#
# Description - Updates the current workspace to the specified revision and
# possible branch. If no options are specified then the
# workspace is updated to the head revision of the current
# branch.
#
# Data - $self : The object.
# $options : A reference to a list containing the options
# to use.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub update($;$)
{
my ($self, $options) = @_;
my ($dummy,
@opts);
# Process any options.
expand_options($options, \@opts);
# Run the command.
return $self->mtn_command_with_options("update", 1, 1, \$dummy, \@opts);
}
#
##############################################################################
#
# Routine - closedown
#
# Description - If started then stop the mtn subprocess.
#
# Data - $self : The object.
#
##############################################################################
sub closedown($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
if ($this->{mtn_pid} != 0)
{
# Close off all file descriptors to the mtn subprocess. This should be
# enough to cause it to exit gracefully.
$this->{mtn_in}->close();
$this->{mtn_out}->close();
$this->{mtn_err}->close();
# Reap the mtn subprocess and deal with any errors.
for (my $i = 0; $i < 4; ++ $i)
{
my $wait_status = 0;
# Wait for the mtn subprocess to exit (preserving the current state
# of $@ so that any exception that has already occurred is not
# lost, also ignore any errors resulting from waitpid()
# interruption).
{
local $@;
eval
{
local $SIG{ALRM} = sub { die(WAITPID_INTERRUPT); };
alarm(5);
$wait_status = waitpid($this->{mtn_pid}, 0);
alarm(0);
};
$wait_status = 0
if ($@ eq WAITPID_INTERRUPT && $wait_status < 0
&& $! == EINTR);
}
# The mtn subprocess has terminated.
if ($wait_status == $this->{mtn_pid})
{
last;
}
# The mtn subprocess is still there so try and kill it unless it's
# time to just give up.
elsif ($i < 3 && $wait_status == 0)
{
if ($i == 0)
{
kill("INT", $this->{mtn_pid});
}
elsif ($i == 1)
{
kill("TERM", $this->{mtn_pid});
}
else
{
kill("KILL", $this->{mtn_pid});
}
}
# Stop if we don't have any relevant children to wait for anymore.
elsif ($wait_status < 0 && $! == ECHILD)
{
last;
}
# Either there is some other error with waitpid() or a child
# process has been reaped that we aren't interested in (in which
# case just ignore it).
elsif ($wait_status < 0)
{
my $err_msg = $!;
kill("KILL", $this->{mtn_pid});
&$croaker("waitpid failed: " . $err_msg);
}
}
$this->{poll_out} = undef;
$this->{poll_err} = undef;
$this->{mtn_pid} = 0;
}
return;
}
#
##############################################################################
#
# Routine - db_locked_condition_detected
#
# Description - Check to see if the Monotone database was locked the last
# time a command was issued.
#
# Data - $self : The object.
# Return Value : True if the database was locked the last
# time a command was issues, otherwise false.
#
##############################################################################
sub db_locked_condition_detected($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
return $this->{db_is_locked};
}
#
##############################################################################
#
# Routine - get_db_name
#
# Description - Return the file name of the Monotone database as given to
# the constructor.
#
# Data - $self : The object.
# Return Value : The file name of the database as given to
# the constructor or undef if no database was
# specified.
#
##############################################################################
sub get_db_name($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
if (defined($this->{db_name}) && $this->{db_name} eq IN_MEMORY_DB_NAME)
{
return undef;
}
else
{
return $this->{db_name};
}
}
#
##############################################################################
#
# Routine - get_error_message
#
# Description - Return the message for the last error reported by this
# class.
#
# Data - $self : The object.
# Return Value : The message for the last error detected, or
# an empty string if nothing has gone wrong
# yet.
#
##############################################################################
sub get_error_message($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
return $this->{error_msg};
}
#
##############################################################################
#
# Routine - get_pid
#
# Description - Return the process id of the mtn automate stdio process.
#
# Data - $self : The object.
# Return Value : The process id of the mtn automate stdio
# process, or zero if no process is thought to
# be running.
#
##############################################################################
sub get_pid($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
return $this->{mtn_pid};
}
#
##############################################################################
#
# Routine - get_service_name
#
# Description - Return the service name of the Monotone server as given to
# the constructor.
#
# Data - $self : The object.
# Return Value : The service name of the Monotone server as
# given to the constructor or undef if no
# service was specified.
#
##############################################################################
sub get_service_name($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
return $this->{network_service};
}
#
##############################################################################
#
# Routine - get_ws_path
#
# Description - Return the the workspace's base directory as either given
# to the constructor or deduced from the current workspace.
# If neither condition holds true then undef is returned.
# Please note that the workspace's base directory may differ
# from that given to the constructor if the specified
# workspace path is actually a subdirectory within that
# workspace.
#
# Data - $self : The object.
# Return Value : The workspace's base directory or undef if
# no workspace was specified and there is no
# current workspace.
#
##############################################################################
sub get_ws_path($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
return $this->{ws_path};
}
#
##############################################################################
#
# Routine - ignore_suspend_certs
#
# Description - Determine whether revisions with the suspend cert are to be
# ignored or not. If the head revisions on a branch are all
# suspended then that branch is also ignored.
#
# Data - $self : The object.
# $ignore : True if suspend certs are to be ignored
# (i.e. all revisions are `visible'),
# otherwise false if suspend certs are to be
# honoured.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub ignore_suspend_certs($$)
{
my ($self, $ignore) = @_;
my $this = $class_records{$self->{$class_name}};
# This only works from version 0.37 (i/f version 6.x).
if ($this->{honour_suspend_certs} && $ignore)
{
if ($self->supports(MTN_IGNORING_OF_SUSPEND_CERTS))
{
$this->{honour_suspend_certs} = undef;
$self->closedown();
$self->startup();
}
else
{
$this->{error_msg} = "Ignoring suspend certs is unsupported in "
. "this version of Monotone";
&$carper($this->{error_msg});
return;
}
}
elsif (! ($this->{honour_suspend_certs} || $ignore))
{
$this->{honour_suspend_certs} = 1;
$self->closedown();
$self->startup();
}
return 1;
}
#
##############################################################################
#
# Routine - register_db_locked_handler
#
# Description - Register the specified routine as a database locked handler
# for this class. This is both a class as well as an object
# method. When used as a class method, the specified database
# locked handler is used as the default handler for all those
# objects that do not specify their own handlers.
#
# Data - $self : Either the object, the package name or not
# present depending upon how this method is
# called.
# $handler : A reference to the database locked handler
# routine. If this is not provided then the
# existing database locked handler routine is
# unregistered and database locking clashes
# are handled in the default way.
# $client_data : The client data that is to be passed to the
# registered database locked handler when it
# is called.
#
##############################################################################
sub register_db_locked_handler(;$$$)
{
my ($self,
$this);
if ($_[0]->isa(__PACKAGE__))
{
if (ref($_[0]) ne "")
{
$self = shift();
$this = $class_records{$self->{$class_name}};
}
else
{
shift();
}
}
my ($handler, $client_data) = @_;
if (defined($self))
{
if (defined($handler))
{
$this->{db_locked_handler} = $handler;
$this->{db_locked_handler_data} = $client_data;
}
else
{
$this->{db_locked_handler} = $this->{db_locked_handler_data} =
undef;
}
}
else
{
if (defined($handler))
{
$db_locked_handler = $handler;
$db_locked_handler_data = $client_data;
}
else
{
$db_locked_handler = $db_locked_handler_data = undef;
}
}
return;
}
#
##############################################################################
#
# Routine - register_error_handler
#
# Description - Register the specified routine as an error handler for
# class. This is a class method rather than an object one as
# errors can be raised when calling the constructor.
#
# Data - $self : The object. This may not be present
# depending upon how this method is called and
# is ignored if it is present anyway.
# $severity : The level of error that the handler is being
# registered for.
# $handler : A reference to the error handler routine. If
# this is not provided then the existing error
# handler routine is unregistered and errors
# are handled in the default way.
# $client_data : The client data that is to be passed to the
# registered error handler when it is called.
#
##############################################################################
sub register_error_handler($;$$$)
{
shift() if ($_[0]->isa(__PACKAGE__));
my ($severity, $handler, $client_data) = @_;
if ($severity == MTN_SEVERITY_ERROR)
{
if (defined($handler))
{
$error_handler = $handler;
$error_handler_data = $client_data;
$croaker = \&error_handler_wrapper;
}
else
{
$croaker = \&croak;
$error_handler = $error_handler_data = undef;
}
}
elsif ($severity == MTN_SEVERITY_WARNING)
{
if (defined($handler))
{
$warning_handler = $handler;
$warning_handler_data = $client_data;
$carper = \&warning_handler_wrapper;
}
else
{
$carper = sub { return; };
$warning_handler = $warning_handler_data = undef;
}
}
elsif ($severity == MTN_SEVERITY_ALL)
{
if (defined($handler))
{
$error_handler = $warning_handler = $handler;
$error_handler_data = $warning_handler_data = $client_data;
$carper = \&warning_handler_wrapper;
$croaker = \&error_handler_wrapper;
}
else
{
$warning_handler = $warning_handler_data = undef;
$error_handler_data = $warning_handler_data = undef;
$carper = sub { return; };
$croaker = \&croak;
}
}
else
{
&$croaker("Unknown error handler severity");
}
return;
}
#
##############################################################################
#
# Routine - register_io_wait_handler
#
# Description - Register the specified routine as an I/O wait handler for
# this class. This is both a class as well as an object
# method. When used as a class method, the specified I/O wait
# handler is used as the default handler for all those
# objects that do not specify their own handlers.
#
# Data - $self : Either the object, the package name or not
# present depending upon how this method is
# called.
# $handler : A reference to the I/O wait handler routine.
# If this is not provided then the existing
# I/O wait handler routine is unregistered.
# $timeout : The timeout, in seconds, that this class
# should wait for input before calling the I/O
# wait handler.
# $client_data : The client data that is to be passed to the
# registered I/O wait handler when it is
# called.
#
##############################################################################
sub register_io_wait_handler(;$$$$)
{
my ($self,
$this);
if ($_[0]->isa(__PACKAGE__))
{
if (ref($_[0]) ne "")
{
$self = shift();
$this = $class_records{$self->{$class_name}};
}
else
{
shift();
}
}
my ($handler, $timeout, $client_data) = @_;
if (defined($timeout))
{
if ($timeout !~ m/^\d*\.{0,1}\d+$/ || $timeout < 0 || $timeout > 20)
{
my $msg =
"I/O wait handler timeout invalid or out of range, resetting";
$this->{error_msg} = $msg if (defined($this));
&$carper($msg);
$timeout = 1;
}
}
else
{
$timeout = 1;
}
if (defined($self))
{
if (defined($handler))
{
$this->{io_wait_handler} = $handler;
$this->{io_wait_handler_data} = $client_data;
$this->{io_wait_handler_timeout} = $timeout;
}
else
{
$this->{io_wait_handler} = $this->{io_wait_handler_data} = undef;
}
}
else
{
if (defined($handler))
{
$io_wait_handler = $handler;
$io_wait_handler_data = $client_data;
$io_wait_handler_timeout = $timeout;
}
else
{
$io_wait_handler = $io_wait_handler_data = undef;
}
}
return;
}
#
##############################################################################
#
# Routine - register_stream_handle
#
# Description - Register the specified file handle to receive data from the
# specified mtn automate stdio output stream.
#
# Data - $self : The object.
# $stream : The mtn output stream from which data is to be
# read and then written to the specified file
# handle.
# $handle : The file handle that is to receive the data from
# the specified output stream. If this is not
# provided then any existing file handle for that
# stream is unregistered.
#
##############################################################################
sub register_stream_handle($$$)
{
my ($self, $stream, $handle) = @_;
my $this = $class_records{$self->{$class_name}};
if (defined($handle) && ref($handle) !~ m/^IO::[^:]+/
&& ref($handle) ne "GLOB" && ref(\$handle) ne "GLOB")
{
&$croaker("Handle must be either undef or a valid handle");
}
autoflush($stream, 1);
if ($stream == MTN_P_STREAM)
{
$this->{p_stream_handle} = $handle;
}
elsif ($stream == MTN_T_STREAM)
{
$this->{t_stream_handle} = $handle;
}
else
{
&$croaker("Unknown stream specified");
}
return;
}
#
##############################################################################
#
# Routine - supports
#
# Description - Determine whether a certain feature is available with the
# version of Monotone that is currently being used.
#
# Data - $self : The object.
# $feature : A constant specifying the feature that is
# to be checked for.
# Return Value : True if the feature is supported, otherwise
# false if it is not.
#
##############################################################################
sub supports($$)
{
my ($self, $feature) = @_;
my $this = $class_records{$self->{$class_name}};
if ($feature == MTN_DROP_ATTRIBUTE
|| $feature == MTN_GET_ATTRIBUTES
|| $feature == MTN_SET_ATTRIBUTE)
{
# These are only available from version 0.36 (i/f version 5.x).
return 1 if ($this->{mtn_aif_version} >= 5);
}
elsif ($feature == MTN_IGNORING_OF_SUSPEND_CERTS
|| $feature == MTN_INVENTORY_IN_IO_STANZA_FORMAT
|| $feature == MTN_P_SELECTOR)
{
# These are only available from version 0.37 (i/f version 6.x).
return 1 if ($this->{mtn_aif_version} >= 6);
}
elsif ($feature == MTN_DROP_DB_VARIABLES
|| $feature == MTN_GET_CURRENT_REVISION
|| $feature == MTN_GET_DB_VARIABLES
|| $feature == MTN_INVENTORY_TAKING_OPTIONS
|| $feature == MTN_SET_DB_VARIABLE)
{
# These are only available from version 0.39 (i/f version 7.x).
return 1 if ($this->{mtn_aif_version} >= 7);
}
elsif ($feature == MTN_DB_GET)
{
# This is only available prior version 0.39 (i/f version 7.x).
return 1 if ($this->{mtn_aif_version} < 7);
}
elsif ($feature == MTN_GET_WORKSPACE_ROOT
|| $feature == MTN_INVENTORY_WITH_BIRTH_ID
|| $feature == MTN_SHOW_CONFLICTS)
{
# These are only available from version 0.41 (i/f version 8.x).
return 1 if ($this->{mtn_aif_version} >= 8);
}
elsif ($feature == MTN_CONTENT_DIFF_EXTRA_OPTIONS
|| $feature == MTN_FILE_MERGE
|| $feature == MTN_LUA
|| $feature == MTN_READ_PACKETS)
{
# These are only available from version 0.42 (i/f version 9.x).
return 1 if ($this->{mtn_aif_version} >= 9);
}
elsif ($feature == MTN_M_SELECTOR || $feature == MTN_U_SELECTOR)
{
# These are only available from version 0.43 (i/f version 9.x).
return 1 if ($this->{mtn_aif_version} >= 10
|| (int($this->{mtn_aif_version}) == 9
&& $mtn_version == 0.43));
}
elsif ($feature == MTN_COMMON_KEY_HASH || $feature == MTN_W_SELECTOR)
{
# These are only available from version 0.44 (i/f version 10.x).
return 1 if ($this->{mtn_aif_version} >= 10);
}
elsif ($feature == MTN_HASHED_SIGNATURES)
{
# This is only available from version 0.45 (i/f version 11.x).
return 1 if ($this->{mtn_aif_version} >= 11);
}
elsif ($feature == MTN_REMOTE_CONNECTIONS
|| $feature == MTN_STREAM_IO
|| $feature == MTN_SYNCHRONISATION)
{
# These are only available from version 0.46 (i/f version 12.x).
return 1 if ($this->{mtn_aif_version} >= 12);
}
elsif ($feature == MTN_UPDATE)
{
# This is only available from version 0.48 (i/f version 12.1).
return 1 if ($this->{mtn_aif_version} >= 12.1);
}
elsif ($feature == MTN_LOG)
{
# This is only available from version 0.99 (i/f version 12.2).
return 1 if ($this->{mtn_aif_version} >= 12.2);
}
elsif ($feature == MTN_CHECKOUT
|| $feature == MTN_DROP_PUBLIC_KEY
|| $feature == MTN_GENERATE_KEY
|| $feature == MTN_GET_EXTENDED_MANIFEST_OF
|| $feature == MTN_GET_FILE_SIZE
|| $feature == MTN_GET_PUBLIC_KEY
|| $feature == MTN_K_SELECTOR
|| $feature == MTN_PUT_PUBLIC_KEY
|| $feature == MTN_SELECTOR_FUNCTIONS
|| $feature == MTN_SELECTOR_OR_OPERATOR
|| $feature == MTN_SYNCHRONISATION_WITH_OUTPUT)
{
# These are only available from version 0.99.1 (i/f version 13.x).
return 1 if ($this->{mtn_aif_version} >= 13);
}
elsif ($feature == MTN_ERASE_DESCENDANTS
|| $feature == MTN_GET_ATTRIBUTES_TAKING_OPTIONS
|| $feature == MTN_SELECTOR_MIN_FUNCTION
|| $feature == MTN_SELECTOR_NOT_FUNCTION)
{
# These are only available from version 1.10 (i/f version 13.1).
return 1 if ($this->{mtn_aif_version} >= 13.1);
}
else
{
&$croaker("Unknown feature requested");
}
return;
}
#
##############################################################################
#
# Routine - suppress_utf8_conversion
#
# Description - Controls whether UTF-8 conversion should be done on the
# data sent to and from the mtn subprocess by this class.
# This is both a class as well as an object method. When used
# as a class method, the specified setting is used as the
# default for all those objects that do not specify their own
# setting. The default setting is to perform UTF-8
# conversion.
#
# Data - $self : Either the object, the package name or not
# present depending upon how this method is
# called.
# $suppress : True if UTF-8 conversion is not to be done,
# otherwise false if it is.
#
##############################################################################
sub suppress_utf8_conversion($$)
{
my ($self,
$this);
if ($_[0]->isa(__PACKAGE__))
{
if (ref($_[0]) ne "")
{
$self = shift();
$this = $class_records{$self->{$class_name}};
}
else
{
shift();
}
}
my $suppress = $_[0];
if (defined($self))
{
$this->{convert_to_utf8} = $suppress ? undef : 1;
}
else
{
$convert_to_utf8 = $suppress ? undef : 1;
}
return;
}
#
##############################################################################
#
# Routine - switch_to_ws_root
#
# Description - Control whether this class automatically switches to a
# workspace's root directory before running the mtn
# subprocess. The default action is to do so as this is
# generally safer.
#
# Data - $self : The object.
# $switch : True if the mtn subprocess should be started
# in a workspace's root directory, otherwise
# false if it should be started in the current
# working directory.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub switch_to_ws_root($$)
{
my ($self,
$this);
if ($_[0]->isa(__PACKAGE__))
{
if (ref($_[0]) ne "")
{
$self = shift();
$this = $class_records{$self->{$class_name}};
}
else
{
shift();
}
}
my $switch = $_[0];
if (defined($self))
{
if (! $this->{ws_constructed})
{
if ($this->{cd_to_ws_root} && ! $switch)
{
$this->{cd_to_ws_root} = undef;
$self->closedown();
$self->startup();
}
elsif (! $this->{cd_to_ws_root} && $switch)
{
$this->{cd_to_ws_root} = 1;
$self->closedown();
$self->startup();
}
}
else
{
$this->{error_msg} =
"Cannot call Monotone::AutomateStdio->switch_to_ws_root() on "
. "objects constructed with new_from_ws()";
&$carper($this->{error_msg});
return;
}
}
else
{
$cd_to_ws_root = $switch ? 1 : undef;
}
return 1;
}
#
##############################################################################
#
# Routine - parse_revision_data
#
# Description - Parse the specified revision data into a list of records.
#
# Data - $list : A reference to a list that is to contain the
# records.
# $data : A reference to a list containing the revision data,
# line by line.
#
##############################################################################
sub parse_revision_data($$)
{
my ($list, $data) = @_;
my $i;
# Reformat the data into a structured array.
for ($i = 0, @$list = (); $i < scalar(@$data); ++ $i)
{
if ($$data[$i] =~ m/$io_stanza_re/)
{
my $kv_record;
# Get the next key-value record.
parse_kv_record($data, \$i, \%revision_details_keys, \$kv_record);
-- $i;
# Validate it in terms of expected fields and copy data across to
# the correct revision fields.
if (exists($kv_record->{add_dir}))
{
push(@$list, {type => "add_dir",
name => $kv_record->{add_dir}});
}
elsif (exists($kv_record->{add_file}))
{
&$croaker("Corrupt revision, expected content field but "
. "did not find it")
unless (exists($kv_record->{content}));
push(@$list, {type => "add_file",
name => $kv_record->{add_file},
file_id => $kv_record->{content}});
}
elsif (exists($kv_record->{clear}))
{
&$croaker("Corrupt revision, expected attr field but did not "
. "find it")
unless (exists($kv_record->{attr}));
push(@$list, {type => "clear",
name => $kv_record->{clear},
attribute => $kv_record->{attr}});
}
elsif (exists($kv_record->{delete}))
{
push(@$list, {type => "delete",
name => $kv_record->{delete}});
}
elsif (exists($kv_record->{new_manifest}))
{
push(@$list, {type => "new_manifest",
manifest_id => $kv_record->{new_manifest}});
}
elsif (exists($kv_record->{old_revision}))
{
push(@$list, {type => "old_revision",
revision_id => $kv_record->{old_revision}});
}
elsif (exists($kv_record->{patch}))
{
&$croaker("Corrupt revision, expected from field but did not "
. "find it")
unless (exists($kv_record->{from}));
&$croaker("Corrupt revision, expected to field but did not "
. "find it")
unless (exists($kv_record->{to}));
push(@$list, {type => "patch",
name => $kv_record->{patch},
from_file_id => $kv_record->{from},
to_file_id => $kv_record->{to}});
}
elsif (exists($kv_record->{rename}))
{
&$croaker("Corrupt revision, expected to field but did not "
. "find it")
unless (exists($kv_record->{to}));
push(@$list, {type => "rename",
from_name => $kv_record->{rename},
to_name => $kv_record->{to}});
}
elsif (exists($kv_record->{set}))
{
&$croaker("Corrupt revision, expected attr field but did not "
. "find it")
unless (exists($kv_record->{attr}));
&$croaker("Corrupt revision, expected value field but did not "
. "find it")
unless (exists($kv_record->{value}));
push(@$list, {type => "set",
name => $kv_record->{set},
attribute => $kv_record->{attr},
value => $kv_record->{value}});
}
}
}
}
#
##############################################################################
#
# Routine - parse_kv_record
#
# Description - Parse the specified data for a key-value style record, with
# each record being separated by a white space line,
# returning the extracted record.
#
# Data - $list : A reference to the list that contains the
# data.
# $index : A reference to a variable containing the
# index of the first line of the record in
# the array. It is updated with the index of
# the first line after the record.
# $key_type_map : A reference to the key type map, this is a
# map indexed by key name and has an
# enumeration as its value that describes the
# type of value that is to be read in.
# $record : A reference to a variable that is to be
# updated with the reference to the newly
# created record.
# $no_errors : True if this routine should not report
# errors relating to unknown fields,
# otherwise undef if these errors are to be
# reported. This is optional.
#
##############################################################################
sub parse_kv_record($$$$;$)
{
my ($list, $index, $key_type_map, $record, $no_errors) = @_;
my ($i,
$key,
$type,
$value);
# Process a line at a time whilst we are looking at an IO stanza record.
for ($i = $$index, $$record = {};
$i < scalar(@$list) && $$list[$i] =~ m/$io_stanza_re/;
++ $i)
{
# Look up the key with respect to its formatting.
$key = $1;
if (exists($$key_type_map{$key}))
{
$type = $$key_type_map{$key};
$value = undef;
# Extract the key's value.
if ($type & BARE_PHRASE && $$list[$i] =~ m/^ *[a-z_]+ ([a-z_]+)$/)
{
$value = $1;
}
elsif ($type & HEX_ID
&& $$list[$i] =~ m/^ *[a-z_]+ \[([0-9a-f]+)\]$/)
{
$value = $1;
}
elsif ($type & OPTIONAL_HEX_ID
&& $$list[$i] =~ m/^ *[a-z_]+ \[([0-9a-f]*)\]$/)
{
$value = $1;
}
elsif ($type & STRING && $$list[$i] =~ m/^ *[a-z_]+ \"/)
{
get_quoted_value($list, \$i, 0, \$value);
$value = unescape($value);
}
elsif ($type & STRING_AND_HEX_ID
&& $$list[$i] =~ m/^ *[a-z_]+ \"(.*)\" \[([0-9a-f]+)\]$/)
{
$value = [unescape($1), $2];
}
elsif ($type & STRING_ENUM
&& $$list[$i] =~ m/^ *[a-z_]+ \"([^\"]+)\"$/)
{
$value = $1;
}
elsif ($type & STRING_KEY_VALUE
&& $$list[$i] =~ m/^ *[a-z_]+ \"([^\"]+)\" (\".*)$/)
{
my $string;
$value = [$1];
get_quoted_value($list, \$i, $-[2], \$string);
push(@$value, unescape($string));
}
elsif ($type & STRING_LIST
&& $$list[$i] =~ m/^ *[a-z_]+ \"(.+)\"$/)
{
$value = [];
foreach my $string (split(/\" \"/, $1))
{
push(@$value, unescape($string));
}
}
elsif ($type & NULL && $$list[$i] =~ m/^ *[a-z_]+ ?$/)
{
}
else
{
&$croaker("Unsupported key type or corrupt field value "
. "detected");
}
# Store the value in the record. If its non-unique then store the
# values in a list, otherwise just store it normally.
if ($type & NON_UNIQUE)
{
if (exists($$record->{$key}))
{
push(@{$$record->{$key}}, $value);
}
else
{
$$record->{$key} = [$value];
}
}
else
{
$$record->{$key} = $value;
}
}
else
{
&$croaker("Unrecognised field " . $key . " found")
unless ($no_errors);
}
}
$$index = $i;
}
#
##############################################################################
#
# Routine - mtn_command
#
# Description - Handle mtn commands that take no options and zero or more
# arguments. Depending upon what type of reference is passed,
# data is either returned in one large lump (scalar
# reference), or an array of lines (array reference).
#
# Data - $self : The object.
# $cmd : The mtn automate command that is to be run.
# $out_as_utf8 : True if any data output to mtn should be
# converted into raw UTF-8, otherwise false if
# the data should be treated as binary. If
# UTF-8 conversion has been disabled by a call
# to the suppress_utf8_conversion() method
# then this argument is ignored.
# $in_as_utf8 : True if any data input from mtn should be
# converted into Perl's internal UTF-8 string
# format, otherwise false if the data should
# be treated as binary. If UTF-8 conversion
# has been disabled by a call to the
# suppress_utf8_conversion() method then this
# argument is ignored.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# @parameters : A list of parameters to be applied to the
# command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub mtn_command($$$$$;@)
{
my ($self, $cmd, $out_as_utf8, $in_as_utf8, $ref, @parameters) = @_;
return $self->mtn_command_with_options($cmd,
$out_as_utf8,
$in_as_utf8,
$ref,
[],
@parameters);
}
#
##############################################################################
#
# Routine - mtn_command_with_options
#
# Description - Handle mtn commands that take options and zero or more
# arguments. Depending upon what type of reference is passed,
# data is either returned in one large lump (scalar
# reference), or an array of lines (array reference).
#
# Data - $self : The object.
# $cmd : The mtn automate command that is to be run.
# $out_as_utf8 : True if any data output to mtn should be
# converted into raw UTF-8, otherwise false if
# the data should be treated as binary. If
# UTF-8 conversion has been disabled by a call
# to the suppress_utf8_conversion() method
# then this argument is ignored.
# $in_as_utf8 : True if any data input from mtn should be
# converted into Perl's internal UTF-8 string
# format, otherwise false if the data should
# be treated as binary. If UTF-8 conversion
# has been disabled by a call to the
# suppress_utf8_conversion() method then this
# argument is ignored.
# $ref : A reference to a buffer or an array that is
# to contain the output from this command.
# $options : A reference to a list containing key/value
# anonymous hashes.
# @parameters : A list of parameters to be applied to the
# command.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub mtn_command_with_options($$$$$$;@)
{
my ($self, $cmd, $out_as_utf8, $in_as_utf8, $ref, $options, @parameters)
= @_;
my ($buffer,
$buffer_ref,
$db_locked_exception,
$handler,
$handler_data,
$opt,
$param,
$read_ok,
$retry);
my $this = $class_records{$self->{$class_name}};
# Work out whether UTF-8 conversion is to be done at all.
$out_as_utf8 = $in_as_utf8 = undef unless ($this->{convert_to_utf8});
# Work out what database locked handler is to be used.
if (defined($this->{db_locked_handler}))
{
$handler = $this->{db_locked_handler};
$handler_data = $this->{db_locked_handler_data};
}
else
{
$handler = $db_locked_handler;
$handler_data = $db_locked_handler_data;
}
# If the output is to be returned as an array of lines as against one lump
# then we need to read the output into a temporary buffer before breaking
# it up into lines.
if (ref($ref) eq "SCALAR")
{
$buffer_ref = $ref;
}
elsif (ref($ref) eq "ARRAY")
{
$buffer_ref = \$buffer;
}
else
{
&$croaker("Expected a reference to a scalar or an array");
}
# Send the command, reading its output, repeating if necessary if retries
# should be attempted when the database is locked.
do
{
# Startup the subordinate mtn process if it hasn't already been
# started.
$self->startup() if ($this->{mtn_pid} == 0);
# Send the command.
if (scalar(@$options) > 0)
{
$this->{mtn_in}->print("o");
foreach $opt (@$options)
{
my ($key,
$key_ref,
$value,
$value_ref);
if ($out_as_utf8)
{
$key = encode_utf8($opt->{key});
$value = encode_utf8($opt->{value});
$key_ref = \$key;
$value_ref = \$value;
}
else
{
$key_ref = \$opt->{key};
$value_ref = \$opt->{value};
}
$this->{mtn_in}->printf("%d:%s%d:%s",
length($$key_ref),
$$key_ref,
length($$value_ref),
$$value_ref);
}
$this->{mtn_in}->print("e ");
}
$this->{mtn_in}->printf("l%d:%s", length($cmd), $cmd);
foreach $param (@parameters)
{
# Cater for passing by reference (useful when sending large lumps
# of data as in put_file). Also defend against undef being passed
# as the only parameter (which can happen when a mandatory argument
# is not passed by the caller).
if (defined $param)
{
my ($data,
$param_ref);
if (ref($param) ne "")
{
if ($out_as_utf8)
{
$data = encode_utf8($$param);
$param_ref = \$data;
}
else
{
$param_ref = $param;
}
}
else
{
if ($out_as_utf8)
{
$data = encode_utf8($param);
$param_ref = \$data;
}
else
{
$param_ref = \$param;
}
}
$this->{mtn_in}->printf("%d:%s",
length($$param_ref),
$$param_ref);
}
}
$this->{mtn_in}->print("e\n");
$this->{mtn_in}->flush();
# Attempt to read the output of the command, rethrowing any exception
# that does not relate to locked databases.
$db_locked_exception = $read_ok = $retry = undef;
eval
{
$read_ok = $self->mtn_read_output($buffer_ref);
};
if ($@)
{
if ($@ =~ m/$database_locked_re/)
{
# We need to properly closedown the mtn subprocess at this
# point because we are quietly handling the exception that
# caused it to exit but the calling application may reap the
# process and compare the reaped PID with the return value from
# the get_pid() method. At least by calling closedown() here
# get_pid() will return 0 and the caller can then distinguish
# between a handled exit and one that should be dealt with.
$self->closedown();
$db_locked_exception = 1;
}
else
{
&$croaker($@);
}
}
# If the data was read in ok then carry out any necessary character set
# conversions. Otherwise deal with locked database exceptions and any
# warning messages that appeared in the output.
if ($read_ok && $in_as_utf8)
{
local $@;
eval
{
$$buffer_ref = decode_utf8($$buffer_ref, Encode::FB_CROAK);
};
}
elsif (! $read_ok)
{
# See if we are to retry on database locked conditions.
if ($db_locked_exception
|| $this->{error_msg} =~ m/$database_locked_re/)
{
$this->{db_is_locked} = 1;
$retry = &$handler($self, $handler_data);
}
# If we are to retry then close down the subordinate mtn process,
# otherwise report the error to the caller.
if ($retry)
{
$self->closedown();
}
else
{
&$carper($this->{error_msg});
return;
}
}
}
while ($retry);
# Split the output up into lines if that is what is required.
@$ref = split(/\n/, $$buffer_ref) if (ref($ref) eq "ARRAY");
# Empty out any data on mtn's STDERR file descriptor. This should always be
# empty unless it exits in error, which is picked up elsewhere. However if
# a misbehaving mtn subprocess is outputting text on STDERR but not exiting
# then there is a possibility that the STDERR pipe will fill up causing mtn
# to block. Remember that anything wrong with a command that does not cause
# mtn to exit should be reported in the error stream on STDOUT, so we can
# just discard any STDERR data read here.
while ($this->{poll_err}->poll(0) > 0)
{
my $dummy;
if (! $this->{mtn_err}->sysread($dummy, 1024))
{
last;
}
}
return 1;
}
#
##############################################################################
#
# Routine - mtn_read_output_format_1
#
# Description - Reads the output from mtn as format 1, removing chunk
# headers.
#
# Data - $self : The object.
# $buffer : A reference to the buffer that is to contain
# the data.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub mtn_read_output_format_1($$)
{
my ($self, $buffer) = @_;
my ($bytes_read,
$char,
$chunk_start,
$cmd_nr,
$colons,
$err_code,
$err_occurred,
$handler,
$handler_data,
$handler_timeout,
$header,
$i,
$last,
$offset,
$size);
my $this = $class_records{$self->{$class_name}};
# Work out what I/O wait handler is to be used.
if (defined($this->{io_wait_handler}))
{
$handler = $this->{io_wait_handler};
$handler_data = $this->{io_wait_handler_data};
$handler_timeout = $this->{io_wait_handler_timeout};
}
else
{
$handler = $io_wait_handler;
$handler_data = $io_wait_handler_data;
$handler_timeout = $io_wait_handler_timeout;
}
# Read in the data.
$$buffer = "";
$chunk_start = 1;
$last = "m";
$offset = 0;
do
{
# Wait here for some data, calling the I/O wait handler every second
# whilst we wait.
while ($this->{poll_out}->poll($handler_timeout) == 0)
{
&$handler($self, $handler_data);
}
# If necessary, read in and process the chunk header, then we know how
# much to read in.
if ($chunk_start)
{
# Read header, one byte at a time until we have what we need or
# there is an error.
for ($header = "", $colons = $i = 0;
$colons < 4 && $this->{mtn_out}->sysread($header, 1, $i);
++ $i)
{
$char = substr($header, $i, 1);
if ($char eq ":")
{
++ $colons;
}
elsif ($colons == 2)
{
if ($char ne "m" && $char ne "l")
{
croak("Corrupt/missing mtn chunk header, mtn gave:\n"
. join("", $this->{mtn_err}->getlines()));
}
}
elsif ($char =~ m/\D$/)
{
croak("Corrupt/missing mtn chunk header, mtn gave:\n"
. join("", $this->{mtn_err}->getlines()));
}
}
# Break out the header into its separate fields.
if ($header =~ m/^(\d+):(\d+):([lm]):(\d+):$/)
{
($cmd_nr, $err_code, $last, $size) = ($1, $2, $3, $4);
if ($cmd_nr != $this->{cmd_cnt})
{
croak("Mtn command count is out of sequence");
}
if ($err_code != 0)
{
$err_occurred = 1;
}
}
else
{
croak("Corrupt/missing mtn chunk header, mtn gave:\n"
. join("", $this->{mtn_err}->getlines()));
}
$chunk_start = undef;
}
# Read in what we require.
if ($size > 0)
{
if (! defined($bytes_read = $this->{mtn_out}->sysread($$buffer,
$size,
$offset)))
{
croak("sysread failed: " . $!);
}
elsif ($bytes_read == 0)
{
croak("Short data read");
}
$size -= $bytes_read;
$offset += $bytes_read;
}
if ($size == 0 && $last eq "m")
{
$chunk_start = 1;
}
}
while ($size > 0 || $last eq "m");
++ $this->{cmd_cnt};
# Deal with errors (message is in $$buffer).
if ($err_occurred)
{
$this->{error_msg} = $$buffer;
$$buffer = "";
return;
}
return 1;
}
#
##############################################################################
#
# Routine - mtn_read_output_format_2
#
# Description - Reads the output from mtn as format 2, removing chunk
# headers.
#
# Data - $self : The object.
# $buffer : A reference to the buffer that is to contain
# the data.
# Return Value : True on success, otherwise false on failure.
#
##############################################################################
sub mtn_read_output_format_2($$)
{
my ($self, $buffer) = @_;
my ($bytes_read,
$buffer_ref,
$char,
$chunk_start,
$cmd_nr,
$colons,
$err_code,
$err_occurred,
$handler,
$handler_data,
$handler_timeout,
$header,
$i,
$offset_ref,
$size,
$stream);
my $this = $class_records{$self->{$class_name}};
my %details = (e => {buffer_ref => undef,
offset => 0},
l => {buffer_ref => undef,
offset => 0},
m => {buffer_ref => undef,
offset => 0},
p => {buffer_ref => undef,
offset => 0,
handle => $this->{p_stream_handle},
used => undef},
t => {buffer_ref => undef,
offset => 0,
handle => $this->{t_stream_handle},
used => undef},
w => {buffer_ref => undef,
offset => 0});
# Create the buffers.
foreach my $key (CORE::keys(%details))
{
if ($key eq "m")
{
$details{$key}->{buffer_ref} = $buffer;
}
else
{
my $ref_buf = "";
$details{$key}->{buffer_ref} = \$ref_buf;
}
}
# Work out what I/O wait handler is to be used.
if (defined($this->{io_wait_handler}))
{
$handler = $this->{io_wait_handler};
$handler_data = $this->{io_wait_handler_data};
$handler_timeout = $this->{io_wait_handler_timeout};
}
else
{
$handler = $io_wait_handler;
$handler_data = $io_wait_handler_data;
$handler_timeout = $io_wait_handler_timeout;
}
# Read in the data.
$$buffer = "";
$chunk_start = 1;
$buffer_ref = $details{m}->{buffer_ref};
$offset_ref = \$details{m}->{offset};
do
{
# Wait here for some data, calling the I/O wait handler every second
# whilst we wait.
while ($this->{poll_out}->poll($handler_timeout) == 0)
{
&$handler($self, $handler_data);
}
# If necessary, read in and process the chunk header, then we know how
# much to read in.
if ($chunk_start)
{
# Read header, one byte at a time until we have what we need or
# there is an error.
for ($header = "", $colons = $i = 0;
$colons < 3 && $this->{mtn_out}->sysread($header, 1, $i);
++ $i)
{
$char = substr($header, $i, 1);
if ($char eq ":")
{
++ $colons;
}
elsif ($colons == 1)
{
if ($char !~ m/^[elmptw]$/)
{
croak("Corrupt/missing mtn chunk header, mtn gave:\n"
. join("", $this->{mtn_err}->getlines()));
}
}
elsif ($char =~ m/\D$/)
{
croak("Corrupt/missing mtn chunk header, mtn gave:\n"
. join("", $this->{mtn_err}->getlines()));
}
}
# Break out the header into its separate fields.
if ($header =~ m/^(\d+):([elmptw]):(\d+):$/)
{
($cmd_nr, $stream, $size) = ($1, $2, $3);
if ($cmd_nr != $this->{cmd_cnt})
{
croak("Mtn command count is out of sequence");
}
}
else
{
croak("Corrupt/missing mtn chunk header, mtn gave:\n"
. join("", $this->{mtn_err}->getlines()));
}
# Set up the current buffer and offset details.
$buffer_ref = $details{$stream}->{buffer_ref};
$offset_ref = \$details{$stream}->{offset};
$chunk_start = undef;
}
# Read in what we require.
if ($stream ne "l")
{
# Process non-last messages.
if ($size > 0)
{
# Process the current data chunk.
if (! defined($bytes_read =
$this->{mtn_out}->sysread($$buffer_ref,
$size,
$$offset_ref)))
{
croak("sysread failed: " . $!);
}
elsif ($bytes_read == 0)
{
croak("Short data read");
}
$size -= $bytes_read;
$$offset_ref += $bytes_read;
}
if ($size <= 0)
{
# We have finished processing the current data chunk so if it
# belongs to a stream that is to be redirected to a file handle
# then send the data down it.
if ($stream =~ m/^[pt]$/
&& defined($details{$stream}->{handle}))
{
# Send the headers as well so as to help the reader.
if (! $details{$stream}->{handle}->print($header
. $$buffer_ref))
{
croak("print failed: " . $!);
}
$details{$stream}->{used} = 1;
$$buffer_ref = "";
$$offset_ref = 0;
}
$chunk_start = 1;
}
}
elsif ($size == 1)
{
my $last_msg;
# Process the last message.
if (! $this->{mtn_out}->sysread($err_code, 1))
{
croak("sysread failed: " . $!);
}
$size = 0;
if ($err_code != 0)
{
$err_occurred = 1;
}
# Send the terminating last message down any stream file handle
# that had data sent down it.
$last_msg = $header . $err_code;
foreach my $ostream ("p", "t")
{
if ($details{$ostream}->{used})
{
if (! $details{$ostream}->{handle}->print($last_msg))
{
croak("print failed: " . $!);
}
}
}
}
else
{
croak("Invalid message state");
}
}
while ($size > 0 || $stream ne "l");
++ $this->{cmd_cnt};
# Record any error or warning messages.
if (${$details{e}->{buffer_ref}} ne "")
{
$this->{error_msg} = ${$details{e}->{buffer_ref}};
}
elsif (${$details{w}->{buffer_ref}} ne "")
{
$this->{error_msg} = ${$details{w}->{buffer_ref}};
}
# If something has gone wrong then deal with it.
if ($err_occurred)
{
$$buffer = "";
return;
}
return 1;
}
#
##############################################################################
#
# Routine - startup
#
# Description - If necessary start up the mtn subprocess.
#
# Data - $self : The object.
#
##############################################################################
sub startup($)
{
my $self = $_[0];
my $this = $class_records{$self->{$class_name}};
if ($this->{mtn_pid} == 0)
{
my (@args,
$cwd,
$file,
$exception,
$header_err,
$line,
$my_pid,
$startup,
$version);
# Deep recursion guard.
$startup = $this->{startup};
local $this->{startup};
$this->{startup} = 1;
# Switch to the default locale. We only want to parse the output from
# Monotone in one language!
local $ENV{LC_ALL} = "C";
local $ENV{LANG} = "C";
# Don't allow SIGPIPE signals to terminate the calling program (any
# related errors are dealt with anyway).
$SIG{PIPE} = "IGNORE";
$this->{db_is_locked} = undef;
$this->{mtn_err} = gensym();
# If we have a disk based database name then convert it to an absolute
# path so that any subsequent chdir(2) call does not prevent opening
# the correct database.
$this->{db_name} = File::Spec->rel2abs($this->{db_name})
if (defined($this->{db_name})
&& ! defined($this->{network_service}));
# Build up a list of command line arguments to pass to the mtn
# subprocess.
@args = ("mtn");
push(@args, "--db=" . $this->{db_name}) if (defined($this->{db_name}));
push(@args, "--quiet") if (defined($this->{network_service}));
push(@args, "--ignore-suspend-certs")
if (! $this->{honour_suspend_certs});
push(@args, @{$this->{mtn_options}});
if (defined($this->{network_service}))
{
push(@args, "automate", "remote_stdio", $this->{network_service});
}
else
{
push(@args, "automate", "stdio");
}
# Actually start the mtn subprocess. If a database name has been
# provided then run the mtn subprocess in the system's root directory
# so as to avoid any database/workspace clash. Likewise if a workspace
# has been provided then run the mtn subprocess in the base directory
# of that workspace (although in this case the caller can override this
# feature if it wishes to do so).
$cwd = getcwd();
$my_pid = $$;
eval
{
if (defined($this->{db_name}) || defined($this->{network_service}))
{
die("chdir failed: " . $!)
unless (chdir(File::Spec->rootdir()));
}
elsif ($this->{cd_to_ws_root} && defined($this->{ws_path}))
{
die("chdir failed: " . $!) unless (chdir($this->{ws_path}));
}
$this->{mtn_pid} = open3($this->{mtn_in},
$this->{mtn_out},
$this->{mtn_err},
@args);
};
$exception = $@;
chdir($cwd);
# Check for errors (remember that open3() errors can happen in both the
# parent and child processes).
if ($exception)
{
if ($$ != $my_pid)
{
# In the child process so all we can do is complain and exit.
STDERR->print("open3 failed: " . $exception . "\n");
exit(1);
}
else
{
# In the parent process so deal with the error in the usual
# way.
&$croaker($exception);
}
}
# Ok so reset the command count and setup polling.
$this->{cmd_cnt} = 0;
$this->{poll_out} = IO::Poll->new();
$this->{poll_out}->mask($this->{mtn_out}, POLLIN | POLLPRI | POLLHUP);
$this->{poll_err} = IO::Poll->new();
$this->{poll_err}->mask($this->{mtn_err}, POLLIN | POLLPRI | POLLHUP);
# If necessary get the version of the actual application.
if (! defined($mtn_version))
{
&$croaker("Could not run command `mtn --version'")
unless (defined($file = IO::File->new("mtn --version |")));
while (defined($line = $file->getline()))
{
if ($line =~ m/^monotone (\d+\.\d+)(dev)? ./)
{
$mtn_version = $1;
}
elsif ($line =~ m/^monotone (\d+\.\d+)([\d.]+)(dev)? ./)
{
my ($first_part, $second_part) = ($1, $2);
$second_part =~ s/\.//g;
$mtn_version = $first_part . $second_part;
}
}
$file->close();
&$croaker("Could not determine the version of Monotone being used")
unless (defined($mtn_version));
}
# If the version is higher than 0.45 then we need to skip the header
# which is terminated by two blank lines (put any errors into
# $header_err as we need to defer any error reporting until later).
if ($mtn_version > 0.45)
{
my ($char,
$last_char);
# If we are connecting to a network service then make sure that it
# has sent us something before doing a blocking read.
if (defined($this->{network_service}))
{
my $poll_result;
for (my $i = 0;
$i < 10
&& ($poll_result =
$this->{poll_out}->poll($io_wait_handler_timeout))
== 0;
++ $i)
{
&$io_wait_handler($self, $io_wait_handler_data);
}
if ($poll_result == 0)
{
$self->closedown();
&$croaker("Cannot connect to service `" .
$this->{network_service} . "'");
}
}
# Skip the header.
$char = $last_char = "";
while ($char ne "\n" || $last_char ne "\n")
{
$last_char = $char;
if (! $this->{mtn_out}->sysread($char, 1))
{
$header_err = "Cannot get format header";
last;
}
}
}
# Set up the correct input handler depending upon the version of mtn.
if ($mtn_version > 0.45)
{
*mtn_read_output = *mtn_read_output_format_2;
}
else
{
*mtn_read_output = *mtn_read_output_format_1;
}
# Get the interface version (remember also that if something failed
# above then this method will throw an exception giving the cause). If
# the database is locked then this startup method will be called again
# by the method call below, so use the $startup boolean to stop
# unnecessary recursion.
if (! $startup)
{
if ($self->interface_version(\$version)
&& $version =~ m/^(\d+\.\d+)$/)
{
$this->{mtn_aif_version} = $1;
# We seem to be ok now despite any earlier failures so reset
# $header_err.
$header_err = undef;
}
else
{
if ($this->{db_is_locked})
{
&$croaker("Database is locked and there is either no "
. "registered retry handler or the handler "
. "returned false");
}
else
{
&$croaker("Cannot get automate stdio interface version "
. "number");
}
}
}
# This should never happen as getting the interface version would have
# reported the real issue, but handle any header read issues just in
# case.
&$croaker($header_err) if (! $startup && defined($header_err));
}
}
#
##############################################################################
#
# Routine - get_ws_details
#
# Description - Checks to see if the specified workspace is valid and, if
# it is, extracts the workspace root directory and the full
# path name of the associated database.
#
# Data - $ws_path : The path to the workspace or a subdirectory of
# it.
# $db_name : A reference to a buffer that is to contain the
# name of the database relating to the specified
# workspace.
# $ws_base : A reference to a buffer that is to contain the
# path of the workspace's base directory.
#
##############################################################################
sub get_ws_details($$$)
{
my ($ws_path, $db_name, $ws_base) = @_;
my ($i,
@lines,
$options_fh,
$options_file,
$path,
$record);
# Find the workspace's base directory.
&$croaker("`" . $ws_path . "' is not a directory") unless (-d $ws_path);
$path = abs_path($ws_path);
while (! -d File::Spec->catfile($path, "_MTN"))
{
&$croaker("Invalid workspace `" . $ws_path
. "', no _MTN directory found")
if ($path eq File::Spec->rootdir());
$path = dirname($path);
}
# Get the name of the related database out of the _MTN/options file.
$options_file = File::Spec->catfile($path, "_MTN", "options");
&$croaker("Could not open `" . $options_file . "' for reading")
unless (defined($options_fh = IO::File->new($options_file, "r")));
@lines = $options_fh->getlines();
$options_fh->close();
chomp(@lines);
$i = 0;
parse_kv_record(\@lines, \$i, \%options_file_keys, \$record, 1);
# Return what we have found.
$$db_name = $record->{database};
$$ws_base = $path;
}
#
##############################################################################
#
# Routine - validate_database
#
# Description - Checks to see if the specified file is a Monotone SQLite
# database. Please note that this does not verify that the
# schema of the database is compatible with the version of
# Monotone being used.
#
# Data - $db_name : The file name of the database to check.
#
##############################################################################
sub validate_database($)
{
my $db_name = $_[0];
my ($buffer,
$db);
# Open the database.
&$croaker("`" . $db_name . "' is not a file") unless (-f $db_name);
&$croaker("Could not open `" . $db_name . "' for reading")
unless (defined($db = IO::File->new($db_name, "r")));
&$croaker("binmode failed: " . $!) unless (binmode($db));
# Check that it is an SQLite version 3.x database.
&$croaker("File `" . $db_name . "' is not a SQLite 3 database")
if ($db->sysread($buffer, 15) != 15 || $buffer ne "SQLite format 3");
# Check that it is a Monotone database.
&$croaker("Database `" . $db_name . "' is not a monotone repository or an "
. "older unsupported version")
if (! $db->sysseek(60, 0)
|| $db->sysread($buffer, 4) != 4
|| $buffer ne "_MTN");
$db->close();
}
#
##############################################################################
#
# Routine - validate_mtn_options
#
# Description - Checks to see if the specified list of mtn command line
# options are valid.
#
# Data - $options : A reference to a list containing a list of
# options to use on the mtn subprocess.
#
##############################################################################
sub validate_mtn_options($)
{
my $options = $_[0];
# Parse the options (don't allow indiscriminate passing of command line
# options to the subprocess!).
for (my $i = 0; $i < scalar(@$options); ++ $i)
{
if (! exists($valid_mtn_options{$$options[$i]}))
{
&$croaker("Unrecognised option `" . $$options[$i]
. "'passed to constructor");
}
else
{
$i += $valid_mtn_options{$$options[$i]};
}
}
}
#
##############################################################################
#
# Routine - create_object
#
# Description - Actually creates a Monotone::AutomateStdio object.
#
# Data - $class : The name of the class that the new object
# should be blessed as.
# Return Value : A new Monotone::AutomateStdio object.
#
##############################################################################
sub create_object($)
{
my $class = $_[0];
my ($counter,
$id,
$self,
$this);
# Create the object's data record.
$this = {db_name => undef,
ws_path => undef,
network_service => undef,
ws_constructed => undef,
cd_to_ws_root => $cd_to_ws_root,
convert_to_utf8 => $convert_to_utf8,
startup => undef,
mtn_options => undef,
mtn_pid => 0,
mtn_in => undef,
mtn_out => undef,
mtn_err => undef,
poll_out => undef,
poll_err => undef,
error_msg => "",
honour_suspend_certs => 1,
mtn_aif_version => undef,
cmd_cnt => 0,
p_stream_handle => undef,
t_stream_handle => undef,
db_is_locked => undef,
db_locked_handler => undef,
db_locked_handler_data => undef,
io_wait_handler => undef,
io_wait_handler_data => undef,
io_wait_handler_timeout => 1};
# Create a unique key (using rand() and duplication detection) and the
# actual object, then store this unique key in the object in a field named
# after this class.
$counter = 0;
do
{
$id = int(rand(INT_MAX));
&$croaker("Exhausted unique object keys")
if ((++ $counter) == INT_MAX);
}
while (exists($class_records{$id}));
$self = bless({}, $class);
$self->{$class_name} = $id;
# Now file the object's record in the records store, filed under the
# object's unique key.
$class_records{$id} = $this;
return $self;
}
#
##############################################################################
#
# Routine - expand_options
#
# Description - Expands the specified list of options so that they all have
# values.
#
# Data - $options : A reference to a list containing the
# options to use.
# $expanded_options : A reference to a list that is to
# contain the list of expanded options in
# the form of key-value records.
#
##############################################################################
sub expand_options($$)
{
my ($options, $expanded_options) = @_;
# Process any options.
@$expanded_options = ();
if (defined($options))
{
for (my $i = 0; $i < scalar(@$options); ++ $i)
{
if (exists($non_arg_options{$$options[$i]}))
{
push(@$expanded_options, {key => $$options[$i], value => ""});
}
else
{
push(@$expanded_options,
{key => $$options[$i], value => $$options[++ $i]});
}
}
}
}
#
##############################################################################
#
# Routine - get_quoted_value
#
# Description - Get the contents of a quoted value that may span several
# lines and contain escaped quotes.
#
# Data - $list : A reference to the list that contains the quoted
# string.
# $index : A reference to a variable containing the index of
# the line in the array containing the opening
# quote (assumed to be the first quote
# encountered). It is updated with the index of the
# line containing the closing quote at the end of
# the line.
# $offset : The offset within the first line, specified by
# $index, where this routine should start searching
# for the opening quote.
# $buffer : A reference to a buffer that is to contain the
# contents of the quoted string.
#
##############################################################################
sub get_quoted_value($$$$)
{
my ($list, $index, $offset, $buffer) = @_;
# Deal with multiple lines.
$$buffer =
substr($$list[$$index], index($$list[$$index], "\"", $offset) + 1);
if ($$buffer !~ m/$closing_quote_re/)
{
do
{
$$buffer .= "\n" . $$list[++ $$index];
}
while ($$list[$$index] !~ m/$closing_quote_re/);
}
substr($$buffer, -1, 1, "");
}
#
##############################################################################
#
# Routine - unescape
#
# Description - Process mtn escape characters to get back the original
# data.
#
# Data - $data : The escaped data.
# Return Value : The unescaped data.
#
##############################################################################
sub unescape($)
{
my $data = $_[0];
return undef unless (defined($data));
$data =~ s/\\\\/\\/g;
$data =~ s/\\\"/\"/g;
return $data;
}
#
##############################################################################
#
# Routine - error_handler_wrapper
#
# Description - Error handler routine that wraps the user's error handler.
# Essentially this routine simply prepends the severity
# parameter and appends the client data parameter.
#
# Data - $message : The error message.
#
##############################################################################
sub error_handler_wrapper($)
{
my $message = $_[0];
&$error_handler(MTN_SEVERITY_ERROR, $message, $error_handler_data);
croak(__PACKAGE__ . ": Fatal error");
}
#
##############################################################################
#
# Routine - warning_handler_wrapper
#
# Description - Warning handler routine that wraps the user's warning
# handler. Essentially this routine simply prepends the
# severity parameter and appends the client data parameter.
#
# Data - $message : The error message.
#
##############################################################################
sub warning_handler_wrapper($)
{
my $message = $_[0];
&$warning_handler(MTN_SEVERITY_WARNING, $message, $warning_handler_data);
}
1;