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.01';
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 if (defined($db) && defined($workspace)) {
37 $self->{PID} = open2(\*READ, \*WRITE, "mtn --db=$db --root=$workspace automate stdio" );
38 } elsif (defined($workspace)) {
39 $self->{PID} = open2(\*READ, \*WRITE, "mtn --root=$workspace automate stdio" );
40 } else {
41 $self->{PID} = open2(\*READ, \*WRITE, "mtn automate stdio" );
42 }
43 $self->{In} = *READ;
44 $self->{Out} = *WRITE;
45 $self->{CmdNum} = 0;
46}
47
48sub call {
49 my $self = shift;
50
51 return if !defined($self->{PID});
52
53 my $read = $self->{In};
54 my $write = $self->{Out};
55
56 print $write "l";
57
58 my $arg;
59 while (defined($arg = shift)) {
60 my $arglen = length $arg;
61 # print "Arg: " . $arg . " with len: " . $arglen . "\n";
62 print $write $arglen;
63 print $write ":";
64 print $write $arg;
65 }
66 print $write "e";
67 my $count=0;
68 my @ret = ("", "");
69 my $last;
70
71 do {
72 my $numString = "";
73 my $ch;
74 while (($ch = getc($read)) ne ':') {
75 $numString = $numString . $ch;
76 }
77 die("Got wrong command number from monotone: ". $numString . ".") if ($numString != $self->{CmdNum});
78 my $err = getc($read);
79 die("Parser confused.") if ($err ne '0' && $err ne '1' && $err ne '2');
80 die("Parser confused.") if (getc($read) ne ':');
81 $last = getc($read);
82 die("Parser confused.") if ($last ne 'l' && $last ne 'm');
83 die("Parser confused.") if (getc($read) ne ':');
84 $numString = "";
85 while (($ch = getc($read)) ne ':') {
86 $numString = $numString . $ch;
87 }
88 my $input = "";
89 while ($numString > 0) {
90 $input = $input . getc($read);
91 $numString--;
92 }
93 # print "Got input: " . $input;
94 if ($err eq '1') {
95 die("Syntax error in Monotone stdio");
96 } elsif ($err eq '2') {
97 $ret[1] = $ret[1] . $input;
98 } elsif ($err eq '0') {
99 $ret[0] = $ret[0] . $input;
100 }
101 } while ($last eq 'm');
102
103 die("Parser confused.") if ($last ne 'l');
104
105 $self->{CmdNum} += 1;
106 return @ret;
107}
108
109sub close {
110 my $self = shift;
111
112 close $self->{Out} if defined($self->{Out});
113 $self->{Out} = undef;
114 close $self->{In} if defined($self->{In});
115 $self->{In} = undef;
116 waitpid($self->{PID}, 0);
117 $self->{PID} = undef;
118}
119
120# print "starting tests\n";
121#
122# my $test = Monotone->new();
123# $test->open("/Users/willu/src/monotone/mt.db","/Users/willu/src/monotone/monotone-source");
124#
125# my @revs = $test->call("get_base_revision_id");
126# print "got revisions: " . $revs[0] . "\n";
127#
128# my $rev = $revs[0];
129# chomp $rev; # remove the trailing \n that monotone leaves there.
130#
131# my @certs = $test->call("certs", $rev);
132# my $cert = $certs[0];
133#
134# print "Got certs:\n" . $cert . "\n";
135#
136# $test->close();
137#
138# print "done\n";

Archive Download this file

Branches

Tags

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