monotone

monotone Mtn Source Tree

Root/contrib/Monotone.pm

1# This is a simple Perl module to start a monotone automate sub-process and then pass commands to it.
2# Written by Will Uther, but I'm not a PERL hacker and I'm hoping someone will come along and fix it
3# to make it right.
4
5package Monotone;
6
7use warnings;
8use strict;
9use FileHandle;
10use IPC::Open2;
11
12require Exporter;
13our @ISA = qw(Exporter);
14our %EXPORT_TAGS = ( 'all' => [ qw() ] );
15our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
16our @EXPORT = qw( );
17
18our $VERSION = '0.03';
19
20#constructor
21sub new {
22 my $class = shift;
23 my $self = {
24 In => undef,
25 Out => undef,
26 PID => undef,
27 CmdNum => undef,
28 };
29 bless ($self, $class);
30 return $self;
31}
32
33sub open ($$) {
34 my ( $self, $db, $workspace ) = @_;
35 local (*READ, *WRITE);
36 die("Monotone automate session already running!") if (defined($self->{PID}) && $self->{PID});
37 if (defined($db) && defined($workspace)) {
38 $self->{PID} = open2(\*READ, \*WRITE, "mtn --db=$db --root=$workspace automate stdio" );
39 } elsif (defined($workspace)) {
40 $self->{PID} = open2(\*READ, \*WRITE, "mtn --root=$workspace automate stdio" );
41 } else {
42 $self->{PID} = open2(\*READ, \*WRITE, "mtn automate stdio" );
43 }
44 die("Unable to start mtn automate stdio session") if (!(defined($self->{PID}) && $self->{PID}));
45 $self->{In} = *READ;
46 $self->{Out} = *WRITE;
47 $self->{CmdNum} = 0;
48
49 # my ($out, $err) = $self->call("interface_version");
50 # die("Wrong monotone interface version: $out") if ($out != 5.0 || $err ne "");
51}
52
53sub open_args ($) {
54 my $self=shift;
55 local (*READ, *WRITE);
56 die("Monotone automate session already running!") if (defined($self->{PID}) && $self->{PID});
57 my $cmd = "mtn automate stdio";
58 while (my $arg=shift) {
59 $cmd = $cmd." $arg";
60 }
61 $self->{PID} = open2(\*READ, \*WRITE, $cmd );
62 die("Unable to start mtn automate stdio session") if (!(defined($self->{PID}) && $self->{PID}));
63 $self->{In} = *READ;
64 $self->{Out} = *WRITE;
65 $self->{CmdNum} = 0;
66
67 # my ($out, $err) = $self->call("interface_version");
68 # die("Wrong monotone interface version: $out") if ($out != 5.0 || $err ne "");
69}
70
71sub setOpts {
72 my $self = shift;
73
74 die("mtn automate stdio session not running") if !defined($self->{PID});
75 my $numargs = @_;
76 die("No arguments in Monotone->setOpts() call!?!") if ($numargs == 0);
77 die("Uneven number of arguments to Monotone->setOpts()!") if ($numargs-2*int($numargs/2) == 1);
78
79 my $read = $self->{In};
80 my $write = $self->{Out};
81
82 print $write "o";
83
84 foreach my $arg (@_) {
85 my $arglen = length $arg;
86 print $write $arglen;
87 print $write ":";
88 print $write $arg;
89 }
90 print $write "e";
91}
92
93sub call {
94 my $self = shift;
95
96 die("mtn automate stdio session not running") if !defined($self->{PID});
97 die("No arguments in Monotone->call() call!?!") if (@_ == 0);
98
99 my $read = $self->{In};
100 my $write = $self->{Out};
101
102 print $write "l";
103
104 foreach my $arg (@_) {
105 my $arglen = length $arg;
106 print $write $arglen;
107 print $write ":";
108 print $write $arg;
109 }
110 print $write "e";
111
112 my @ret = ("", "");
113 my $last;
114
115 do {
116 my $numString = "";
117 my $ch;
118 while (($ch = getc($read)) ne ':' && ! eof $read) {
119 $numString = $numString . $ch;
120 }
121 die("Got wrong command number from monotone: ". $numString . ".") if ($numString != $self->{CmdNum});
122 my $err = getc($read);
123 die("Parser confused.") if ($err ne '0' && $err ne '1' && $err ne '2');
124 die("Parser confused.") if (getc($read) ne ':');
125 $last = getc($read);
126 die("Parser confused.") if ($last ne 'l' && $last ne 'm');
127 die("Parser confused.") if (getc($read) ne ':');
128 $numString = "";
129 while (($ch = getc($read)) ne ':' && ! eof $read) {
130 $numString = $numString . $ch;
131 }
132 my $input = "";
133 while ($numString > 0 && ! eof $read) {
134 $input = $input . getc($read);
135 $numString--;
136 }
137 if ($err eq '1') {
138 die("Syntax error in Monotone stdio");
139 } elsif ($err eq '2') {
140 $ret[1] = $ret[1] . $input;
141 } elsif ($err eq '0') {
142 $ret[0] = $ret[0] . $input;
143 }
144 } while ($last eq 'm' && ! eof $read);
145
146 die("Parser confused.") if ($last ne 'l');
147
148 $self->{CmdNum} += 1;
149 return @ret;
150}
151
152sub close {
153 my $self = shift;
154
155 close $self->{Out} if defined($self->{Out});
156 $self->{Out} = undef;
157 close $self->{In} if defined($self->{In});
158 $self->{In} = undef;
159 waitpid($self->{PID}, 0) if defined($self->{PID});
160 $self->{PID} = undef;
161}
162
163# print "starting tests\n";
164#
165# my $test = Monotone->new();
166# $test->open("/Users/willu/src/monotone/mt.db","/Users/willu/src/monotone/monotone-source");
167#
168# my @revs = $test->call("get_base_revision_id");
169# print "got revisions: " . $revs[0] . "\n";
170#
171# my $rev = $revs[0];
172# chomp $rev; # remove the trailing \n that monotone leaves there.
173#
174# my @certs = $test->call("certs", $rev);
175# my $cert = $certs[0];
176#
177# print "Got certs:\n" . $cert . "\n";
178#
179# $test->close();
180#
181# print "done\n";

Archive Download this file

Branches

Tags

Quick Links:     www.monotone.ca    -     Downloads    -     Documentation    -     Wiki    -     Code Forge    -     Build Status