1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
# class representing a one-liner management command. all the responses
# to a command should be done through this instance (out, err, ok, etc)
#
# Copyright 2005-2007, Six Apart, Ltd.
#
package Perlbal::ManageCommand;
use strict;
use warnings;
no warnings qw(deprecated);
use fields (
'base', # the base command name (like "proc")
'cmd',
'ok',
'err',
'out',
'orig',
'argn',
'ctx',
);
sub new {
my ($class, $base, $cmd, $out, $ok, $err, $orig, $ctx) = @_;
my $self = fields::new($class);
$self->{base} = $base;
$self->{cmd} = $cmd;
$self->{ok} = $ok;
$self->{err} = $err;
$self->{out} = $out;
$self->{orig} = $orig;
$self->{ctx} = $ctx;
$self->{argn} = [];
return $self;
}
# returns an managecommand object for functions that need one, but
# this does nothing but explode if there any problems.
sub loud_crasher {
use Carp qw(confess);
__PACKAGE__->new(undef, undef, sub {}, sub {}, sub { confess "MC:err: @_" }, "", Perlbal::CommandContext->new);
}
sub out { my $mc = shift; return @_ ? $mc->{out}->(@_) : $mc->{out}; }
sub ok { my $mc = shift; return $mc->{ok}->(@_); }
sub err {
my ($mc, $err) = @_;
$err =~ s/\n$//;
$mc->{err}->($err);
}
sub cmd { my $mc = shift; return $mc->{cmd}; }
sub orig { my $mc = shift; return $mc->{orig}; }
sub end { my $mc = shift; $mc->{out}->("."); 1; }
sub parse {
my $mc = shift;
my $regexp = shift;
my $usage = shift;
my @ret = ($mc->{cmd} =~ /$regexp/);
$mc->parse_error($usage) unless @ret;
my $i = 0;
foreach (@ret) {
$mc->{argn}[$i++] = $_;
}
return $mc;
}
sub arg {
my $mc = shift;
my $n = shift; # 1-based array, to correspond with $1, $2, $3
return $mc->{argn}[$n - 1];
}
sub args {
my $mc = shift;
return @{$mc->{argn}};
}
sub parse_error {
my $mc = shift;
my $usage = shift;
$usage .= "\n" if $usage && $usage !~ /\n$/;
die $usage || "Invalid syntax to '$mc->{base}' command\n"
}
sub no_opts {
my $mc = shift;
die "The '$mc->{base}' command takes no arguments\n"
unless $mc->{cmd} eq $mc->{base};
return $mc;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:
|
