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 $stream = "";
114 my %input = (
115"m" => "",
116"e" => "",
117"w" => "",
118"p" => "",
119"t" => "",
120"l" => ""
121);
122 my $last;
123
124 do {
125 my $numString = "";
126 my $ch;
127my $firstchar = 1;
128 while (($ch = getc($read)) ne ':' && ! eof $read) {
129 if (($ch lt '0' || $ch gt '9') && $firstchar) {
130# Read through headers
131do {
132 while (($ch = getc($read)) ne "\n" && ! eof $read) {
133 }
134} while (($ch = getc($read)) ne "\n" && ! eof $read);
135$firstchar = 0;
136 } else {
137$numString = $numString . $ch;
138 }
139 }
140 die("Got wrong command number from monotone: ". $numString . ".") if ($numString != $self->{CmdNum});
141 $stream = getc($read);
142 die("Parser confused.") if ($stream ne 'm'
143 && $stream ne 'e' && $stream ne 'w'
144 && $stream ne 'p' && $stream ne 't'
145 && $stream ne 'l');
146 die("Parser confused.") if (getc($read) ne ':');
147 $numString = "";
148 while (($ch = getc($read)) ne ':' && ! eof $read) {
149 $numString = $numString . $ch;
150 }
151 while ($numString > 0 && ! eof $read) {
152 $input{$stream} = $input{$stream} . getc($read);
153 $numString--;
154 }
155 } while ($stream ne 'l' && ! eof $read);
156
157 die("Parser confused.") if ($stream ne 'l');
158
159 if ($input{l} eq '1') {
160die("Syntax error in Monotone stdio");
161 } elsif ($input{l} eq '2') {
162$ret[1] = $ret[1] . $input{e};
163 } elsif ($input{l} eq '0') {
164$ret[0] = $ret[0] . $input{m};
165 }
166
167 $self->{CmdNum} += 1;
168 return @ret;
169}
170
171sub close {
172 my $self = shift;
173
174 close $self->{Out} if defined($self->{Out});
175 $self->{Out} = undef;
176 close $self->{In} if defined($self->{In});
177 $self->{In} = undef;
178 waitpid($self->{PID}, 0) if defined($self->{PID});
179 $self->{PID} = undef;
180}
181
182# print "starting tests\n";
183#
184# my $test = Monotone->new();
185# $test->open("/Users/willu/src/monotone/mt.db","/Users/willu/src/monotone/monotone-source");
186#
187# my @revs = $test->call("get_base_revision_id");
188# print "got revisions: " . $revs[0] . "\n";
189#
190# my $rev = $revs[0];
191# chomp $rev; # remove the trailing \n that monotone leaves there.
192#
193# my @certs = $test->call("certs", $rev);
194# my $cert = $certs[0];
195#
196# print "Got certs:\n" . $cert . "\n";
197#
198# $test->close();
199#
200# print "done\n";

Archive Download this file

Branches

Tags

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