Commit | Line | Data |
---|---|---|
5bbf9627 MW |
1 | #! /usr/bin/perl |
2 | ||
3 | use autodie qw(:all); | |
4 | ||
5 | use File::Find; | |
6 | use File::Path qw(make_path remove_tree); | |
7 | use POSIX qw(:errno_h); | |
8 | ||
9 | use Data::Dumper; | |
10 | ||
11 | ## Set up Gitolite's various things. | |
12 | BEGIN { | |
13 | die "GL_RC unset" unless exists $ENV{GL_RC}; | |
14 | die "GL_BINDIR unset" unless exists $ENV{GL_BINDIR}; | |
15 | unshift @INC, $ENV{GL_BINDIR}; | |
16 | } | |
17 | use gitolite_rc; | |
18 | use gitolite; | |
19 | ||
20 | ###-------------------------------------------------------------------------- | |
21 | ### Utility functions. | |
22 | ||
23 | sub indent_length ($) { | |
24 | my ($s) = @_; | |
25 | ## Return the width of the initial indent of S, in columns, counting tabs | |
26 | ## as an indent to the next multiple of eight. | |
27 | ||
28 | my ($ind) = $s =~ /^(\s+)/; | |
29 | my $n = length $ind; | |
30 | my $x = 0; | |
31 | ||
32 | for (my $i = 0; $i < $n; $i++) { | |
33 | if (substr($ind, $i, 1) eq "\t") { $x = ($x + 8)&~7; } | |
34 | else { $x++; } | |
35 | } | |
36 | return $x; | |
37 | } | |
38 | ||
39 | sub trim_indent ($$) { | |
40 | my ($s, $n) = @_; | |
41 | ## Return the string S, minus initial characters as far as (but in no case | |
42 | ## exceeding) column N, counting tabs as an indent to the next multiple of | |
43 | ## eight. | |
44 | ||
45 | my $x = 0; | |
46 | my ($y, $i); | |
47 | ||
48 | for ($i = 0; $i < length $s; $i++) { | |
49 | if (substr($s, $i, 1) eq "\t") { $y = ($x + 8)&~7; } | |
50 | else { $y = $x + 1; } | |
51 | last if $y >= $n; | |
52 | $x = $y; | |
53 | } | |
54 | return substr $s, $y == $n ? $i + 1 : $i; | |
55 | } | |
56 | ||
57 | sub arg (\@$) { | |
58 | my ($a, $what) = @_; | |
59 | ## Fetch the next argument from A; report an error that we don't have WHAT | |
60 | ## if we run out. | |
61 | ||
62 | die "missing $what\n" unless @$a; | |
63 | return shift @$a; | |
64 | } | |
65 | ||
66 | ###-------------------------------------------------------------------------- | |
67 | ### Configuration file. | |
68 | ||
69 | sub commit_confkey ($$@) { | |
70 | my ($h, $k, @lines) = @_; | |
71 | ## Store the configuration value LINES in the hash H, under key K. | |
72 | ## | |
73 | ## The longest common sequence of whitespace is trimmed from the LINES (as | |
74 | ## measured using `indent_length'), and then they're concatenated with | |
75 | ## newlines between. | |
76 | ||
77 | return unless defined $k; | |
78 | ||
79 | shift @lines if $lines[0] eq ""; | |
80 | pop @lines while @lines && $lines[-1] eq ""; | |
81 | ||
82 | my $ind = undef; | |
83 | for my $l (@lines) { | |
84 | next if $l =~ /^\s*$/; | |
85 | my $n = indent_length $l; | |
86 | if (!defined($ind) || $n < $ind) { $ind = $n; } | |
87 | } | |
88 | $h->{$k} = join "\n", map { trim_indent $_, $ind } @lines; | |
89 | } | |
90 | ||
91 | sub read_config ($) { | |
92 | my ($conf) = @_; | |
93 | ## Read configuration from the file CONF, and return a two-level hash | |
94 | ## %conf{GROUP}{KEY} representing it. | |
95 | ||
96 | my %c; | |
97 | ||
98 | open my $fh, "<", $conf; | |
99 | my $line = <$fh>; | |
100 | my $n = 0; | |
101 | my ($h, $k); | |
102 | my @acc; | |
103 | ||
104 | $h = \%{$c{""}}; | |
105 | while (defined $line) { | |
106 | chomp $line; $n++; | |
107 | if ($line =~ /^([;\#])/) { } | |
108 | elsif ($line =~ /^\s*\[\s*([-_:\w]+)\s*\]\s*$/) { | |
109 | commit_confkey $h, $k, @acc; | |
110 | $h = \%{$c{$1}}; | |
111 | undef $k; | |
112 | } elsif ($line =~ /^\s/) { | |
113 | defined $k or die "$conf:$n: no line to continue\n"; | |
114 | push @acc, $line; | |
115 | } elsif ($line =~ /^\s*$/) { | |
116 | push @acc, $line if defined $k; | |
117 | } elsif ($line =~ /^([-\/.%\w]+)\s*[:=]\s*(\S.*|)$/) { | |
118 | commit_confkey $h, $k, @acc; | |
119 | $k = $1; | |
120 | @acc = ($2); | |
121 | } else { | |
122 | die "$conf:$n: invalid config line\n"; | |
123 | } | |
124 | $line = <$fh>; | |
125 | } | |
126 | commit_confkey $h, $k, @acc; | |
127 | return %c; | |
128 | } | |
129 | ||
130 | sub conf_var ($$;$) { | |
131 | my ($g, $v, $d) = @_; | |
132 | ## Return the value for V in config group G, or return D by default. | |
133 | ## If D is omitted then report an error. | |
134 | ||
135 | my $r = $C{$g}{$v}; | |
136 | $r = $C{""}{$v} unless defined $r || $g eq ""; | |
137 | $r = $d unless defined $r; | |
138 | die "missing config variable `$g/$v'" unless defined $r; | |
139 | return $r; | |
140 | } | |
141 | ||
142 | ###-------------------------------------------------------------------------- | |
143 | ### Updating a configuration repository. | |
144 | ||
145 | our (%G, %U); | |
146 | ||
147 | sub subst_user ($$$) { | |
148 | my ($g, $u, $s) = @_; | |
149 | ## Return S, with appropriate substitutions made. | |
150 | ||
151 | my %map = ( "G" => $g, | |
152 | "U" => $u, | |
153 | "%" => "%" ); | |
154 | $s =~ s/\%(.)/$map{$1} || "\%$1"/eg; | |
155 | return $s; | |
156 | } | |
157 | ||
158 | sub check_user_name ($$) { | |
159 | my ($g, $u) = @_; | |
160 | ## Complain if U isn't a valid user name for group G. | |
161 | ||
162 | my $pat = conf_var "conf:$g", "userpat", "[-_0-9a-z]+"; | |
163 | die "bad user name `$u'\n" unless $u =~ /^$pat$/; | |
164 | } | |
165 | ||
166 | sub write_conffiles ($$) { | |
167 | my ($g, $u) = @_; | |
168 | ## Write the necessary files for a user U in group G. | |
169 | ||
170 | my $ff = $C{"files:$g"}; | |
171 | die "unknown group `$g'\n" unless $ff; | |
172 | ||
173 | for my $f (keys %$ff) { | |
174 | my $fn = subst_user $g, $u, $f; | |
175 | if ((my $d = $fn) =~ s:/[^/]+$::) { make_path $d; } | |
176 | open my $fh, ">", "$fn.new"; | |
177 | print $fh subst_user($g, $u, $ff->{$f}), "\n"; | |
178 | close $fh; | |
179 | rename "$fn.new", $fn; | |
180 | } | |
181 | } | |
182 | ||
183 | sub delete_conffiles ($$) { | |
184 | my ($g, $u) = @_; | |
185 | ## Delete configuration files for a user U in group G. | |
186 | ||
187 | my $ff = $C{"files:$g"}; | |
188 | die "unknown group `$g'\n" unless $ff; | |
189 | ||
190 | for my $f (keys %$ff) { | |
191 | my $fn = subst_user $g, $u, $f; | |
192 | unlink $fn; | |
193 | } | |
194 | } | |
195 | ||
196 | sub parse_userinfo_word ($@) { | |
197 | my ($k, @a) = @_; | |
198 | ## Helper for `read_userinfo_file': return the only word from its argument | |
199 | ## list. | |
200 | ||
201 | die "`$k' wants a single argument\n" unless @a == 1; | |
202 | return $a[0]; | |
203 | } | |
204 | ||
205 | sub parse_userinfo_list ($@) { | |
206 | my ($k, @a) = @_; | |
207 | ## Helper for `read_userinfo_file': return the remaining arguments as an | |
208 | ## arrayref. | |
209 | ||
210 | return \@a; | |
211 | } | |
212 | ||
213 | ## Mapping userinfo file tags to helper functions which parse their | |
214 | ## arguments. The helpers take arguments TAG, ARGS ... and are expected to | |
215 | ## return a properly Perlish value to be stored in the userinfo hash. | |
216 | our %USERINFO = ( user => \&parse_userinfo_word, | |
217 | group => \&parse_userinfo_word, | |
218 | path => \&parse_userinfo_list ); | |
219 | ||
220 | sub read_userinfo_file ($) { | |
221 | my ($fn) = @_; | |
222 | ## Parse a userinfo file, returning the results as a hashref. | |
223 | ||
224 | my $fh; | |
225 | eval { open $fh, "<", "glau.info/$fn"; }; | |
226 | if (!$@) { } | |
227 | elsif ($@->isa("autodie::exception") && $@->errno == ENOENT) { | |
228 | return undef; | |
229 | } else { | |
230 | die; | |
231 | } | |
232 | ||
233 | my %i; | |
234 | while (<$fh>) { | |
235 | my @w = split; | |
236 | next unless @w; | |
237 | my $k = shift @w; | |
238 | die "INTERNAL: unknown userinfo tag `$k'" unless $USERINFO{$k}; | |
239 | $i{$k} = &{$USERINFO{$k}}($k, @w); | |
240 | } | |
241 | for my $k (keys %USERINFO) { | |
242 | die "INTERNAL: missing userinfo tag `$k'" unless exists $i{$k}; | |
243 | } | |
244 | return \%i; | |
245 | } | |
246 | ||
247 | sub decorated_user_name ($$) { | |
248 | my ($g, $u) = @_; | |
249 | ## Take a raw group G and user name U, and return the Gitolite-facing | |
250 | ## decorated user name. | |
251 | ||
252 | die "unknown group `$g'\n" unless $C{"conf:$g"}; | |
253 | return subst_user $g, $u, conf_var "conf:$g", "decorate", "%U"; | |
254 | } | |
255 | ||
256 | sub read_userinfo ($$) { | |
257 | my ($g, $u) = @_; | |
258 | ## Read and return a userinfo hash for the given group/user combination. | |
259 | ||
260 | my $fn = decorated_user_name $g, $u; | |
261 | return read_userinfo_file $fn; | |
262 | } | |
263 | ||
264 | sub check_userinfo_tags ($@) { | |
265 | my ($i, @must) = @_; | |
266 | ## Check that the userinfo I has all of the necessary tags, and nothing | |
267 | ## else. | |
268 | ||
269 | @must = keys %USERINFO unless @must; | |
270 | for my $k (@must) | |
271 | { die "INTERNAL: missing userinfo tag `$k'" unless exists $i->{$k}; } | |
272 | for my $k (keys %$i) | |
273 | { die "INTERNAL: unexpected userinfo tag `$k'" unless $USERINFO{$k}; } | |
274 | } | |
275 | ||
276 | sub write_userinfo (+;$) { | |
277 | my ($i, $dir) = @_; | |
278 | ## Create a new userinfo file for the information I, writing it to DIR. | |
279 | ||
280 | $dir //= "glau.info"; | |
281 | check_userinfo_tags $i; | |
282 | ||
283 | make_path $dir; | |
284 | my $fn = "$dir/" . decorated_user_name $i->{group}, $i->{user}; | |
285 | open my $fh, ">", $fn; | |
286 | for my $k (keys %$i) { | |
287 | my $x = $i->{$k}; | |
288 | my $t = ref $x; | |
289 | if ($t eq "ARRAY") { printf $fh "%s %s\n", $k, join " ", @$x; } | |
290 | elsif ($t eq "") { printf $fh "%s %s\n", $k, $x; } | |
291 | else { die "INTERNAL: unexpected ref type `$t' in user info"; } | |
292 | } | |
293 | close $fh; | |
294 | } | |
295 | ||
296 | sub delete_userinfo (+) { | |
297 | my ($i) = @_; | |
298 | ## Create a new userinfo file for the information I. | |
299 | ||
300 | check_userinfo_tags $i, "user", "group"; | |
301 | unlink "glau.info/" . decorated_user_name $i->{group}, $i->{user}; | |
302 | } | |
303 | ||
304 | sub map_allusers (&) { | |
305 | my ($proc) = @_; | |
306 | ## Call PROC(I) for each userinfo known to the system. | |
307 | ||
308 | opendir my $d, "glau.info"; | |
309 | while (my $f = readdir $d) { | |
310 | next if $f eq "." || $f eq ".."; | |
311 | &$proc(read_userinfo_file $f); | |
312 | } | |
313 | } | |
314 | ||
315 | sub map_userkeys (&$$) { | |
316 | my ($proc, $g, $u) = @_; | |
317 | ## Call PROC(KI) for each key known for the user U in group G. | |
318 | ## | |
319 | ## The KI argument is a hashref: | |
320 | ## | |
321 | ## keyid The keyid, with initial `@'. | |
322 | ## fn The leaf filename, relative to the current directory. | |
323 | ## path The full filename, from the top of the admin tree. | |
324 | ||
325 | my $fn = decorated_user_name $g, $u; | |
326 | find sub { | |
327 | &$proc({ fn => $_, path => File::Find::name, | |
328 | keyid => $3 }) | |
329 | if -f $_ && /^(zzz-marked-for-(add|del)-|)\Q$fn\E(\@[^.]+|)\.pub$/; | |
330 | }, "keydir"; | |
331 | } | |
332 | ||
333 | sub existing_keyids ($$) { | |
334 | my ($g, $u) = @_; | |
335 | ## Return the existing keyids for a user U in group G. | |
336 | ||
337 | my @k; | |
338 | map_userkeys { push @k, $_[0]->{keyid} } $g, $u; | |
339 | return @k; | |
340 | } | |
341 | ||
342 | sub write_userkey ($$$$) { | |
343 | my ($g, $u, $keyid, $k) = @_; | |
344 | ## Write the key K for a user U in group G, with a given KEYID. | |
345 | ## The key should be a literal string, including trailing newline. | |
346 | ||
347 | make_path "keydir"; | |
348 | open my $fh, ">", | |
349 | sprintf "keydir/%s%s.pub", decorated_user_name($g, $u), $keyid; | |
350 | print $fh $k; | |
351 | close $fh; | |
352 | } | |
353 | ||
354 | sub delete_userkeys ($$) { | |
355 | my ($g, $u) = @_; | |
356 | ## Delete all of a user's keys. | |
357 | ||
358 | map_userkeys { unlink $_[0]->{fn} } $g, $u; | |
359 | } | |
360 | ||
361 | sub refresh_conffiles () { | |
362 | ## Rewrite all of the configuration files we're responsible for. | |
363 | ||
364 | for my $d (split " ", conf_var "", "confdirs") { remove_tree $d; } | |
365 | make_path "glau.info-new"; | |
366 | map_allusers { | |
367 | my ($i) = @_; | |
368 | my ($g, $u) = @{$i}{"group", "user"}; | |
369 | write_conffiles $g, $u; | |
370 | write_userinfo $i, "glau.info-new"; | |
371 | }; | |
372 | remove_tree "glau.info"; | |
373 | rename "glau.info-new", "glau.info"; | |
374 | } | |
375 | ||
376 | ###-------------------------------------------------------------------------- | |
377 | ### Git things. | |
378 | ||
379 | our $TMPDIR; | |
380 | ||
381 | sub create_tmpdir () { | |
382 | ## Create a temporary directory and set `$TMPDIR'. | |
383 | ||
384 | ## Maybe we did this already. | |
385 | return if defined $TMPDIR; | |
386 | ||
387 | ## We use `~/tmp/glau.PID' as our temporary directory. We decree that | |
388 | ## no other hosts are allowed to use this space at the same time. | |
389 | make_path "$GL_ADMINDIR/tmp"; | |
390 | $TMPDIR = "$GL_ADMINDIR/tmp/glau.$$"; | |
391 | remove_tree $TMPDIR; | |
392 | mkdir $TMPDIR, 0700; | |
393 | } | |
394 | ||
395 | END { chdir $ENV{HOME}; remove_tree $TMPDIR if defined $TMPDIR; } | |
396 | ||
397 | sub setup_admin_dir ($) { | |
398 | my ($who) = @_; | |
399 | ## Set up a working tree for the admin repository, on behalf of WHO. | |
400 | ||
401 | create_tmpdir; | |
402 | ||
403 | chdir $TMPDIR; | |
404 | system "git", "clone", "-q", "$REPO_BASE/gitolite-admin.git", "admin"; | |
405 | chdir "admin"; | |
406 | system "git", "config", "user.name", "$who/gitolite-adduser"; | |
407 | } | |
408 | ||
409 | sub commit_admin_dir ($) { | |
410 | my ($msg) = @_; | |
411 | ## Commit changes to the admin repository, using MSG as the commit message. | |
412 | ||
413 | system "git", "add", "-A", "."; | |
414 | ##system "git", "diff", "--cached"; | |
415 | system "git", "commit", "-aq", "-m$msg"; | |
416 | system "git", "push", "-q"; | |
417 | } | |
418 | ||
419 | ###-------------------------------------------------------------------------- | |
420 | ### Permission checks. | |
421 | ||
422 | sub check_adc_access ($$) { | |
423 | my ($g, $u) = @_; | |
424 | ## Check that the caller has permission to modify user U in group G. | |
425 | ## | |
426 | ## This has two parts. Firstly, the caller must have permission to write | |
427 | ## to the fake `EXTCMD/adduser' repository's `NAME/G/U' branch. Secondly, | |
428 | ## we insist that the user isn't already `established'. | |
429 | ||
430 | die "GL_USER unset\n" unless exists $ENV{GL_USER}; | |
431 | ||
432 | ## Check that we have permission. | |
433 | my $rc = check_access "EXTCMD/adduser", "NAME/$g/$u", "W", 1; | |
434 | die "permission $rc\n" if $rc =~ /DENIED/; | |
435 | ||
436 | ## Check that the subject user isn't established: i.e., either doesn't | |
437 | ## exist yet, or still has the key that we set up. This allows us to | |
438 | ## modify the key until the subject user declares independence. | |
439 | my $fn = decorated_user_name $g, $u; | |
440 | my @k = existing_keyids $g, $u; | |
441 | die "user `$u' in group `$g' already established\n" | |
442 | if @k && !grep /^\@zzz-glau-\Q$ENV{GL_USER}\E$/, @k; | |
443 | } | |
444 | ||
445 | ###-------------------------------------------------------------------------- | |
446 | ### Commands. | |
447 | ||
448 | package BaseOperation; | |
449 | ## A base class for operations, implements the minimal protocol. | |
450 | ## | |
451 | ## This consists of three methods. | |
452 | ## | |
453 | ## CLASS->userv(\@ARG) Construct and return an object to perform the | |
454 | ## operation given a Userv command-line argument list. | |
455 | ## | |
456 | ## CLASS->parse(\@ARG) Construct and return an object to perform the | |
457 | ## operation given an SSH (ADC) command-line argument | |
458 | ## list. | |
459 | ## | |
460 | ## OP->run() Perform the actual operation. | |
461 | ||
462 | sub userv { die "not available via userv\n"; } | |
463 | sub parse { die "not available as adc\n"; } | |
464 | ||
465 | package SetOperation; | |
466 | use base qw(BaseOperation); | |
467 | ## Set a user's key. Userv callers can only configure their own `@userv' | |
468 | ## key. ADC callers can set a key for another user, subject to | |
469 | ## `check_adc_access'. Reads the `authorized_keys' line from stdin. | |
470 | ||
471 | sub new { | |
472 | my ($cls, $who, $g, $u, $keyid, $path) = @_; | |
473 | ## Common constructor. | |
474 | ||
475 | return bless { who => $who, | |
476 | group => $g, | |
477 | user => $u, | |
478 | keyid => $keyid, | |
479 | path => $path }, $cls; | |
480 | } | |
481 | ||
482 | sub userv { | |
483 | my ($cls, $arg) = @_; | |
484 | ||
485 | my $u = $ENV{"USERV_USER"}; | |
486 | my $g = ::conf_var "", "uservgroup", "local"; | |
487 | return $cls->new($u, $g, $u, "\@userv", []); | |
488 | } | |
489 | ||
490 | sub parse { | |
491 | my ($cls, $arg) = @_; | |
492 | ||
493 | my $g = ::arg @$arg, "group name"; | |
494 | my $u = ::arg @$arg, "user name"; | |
495 | my $who = $ENV{GL_USER}; | |
496 | my $i = ::read_userinfo_file $who; | |
497 | die "who are you?\n" unless $i; | |
498 | ::check_adc_access $g, $u; | |
499 | return $cls->new($who, $g, $u, "\@zzz-glau-$who", $i->{path}); | |
500 | } | |
501 | ||
502 | sub run { | |
503 | my ($me) = @_; | |
504 | ||
505 | my $k; | |
506 | ::check_user_name $me->{group}, $me->{user}; | |
507 | my $n = read STDIN, $k, 4096; | |
508 | my @f = split " ", $k; | |
509 | die "malformed public key\n" unless | |
510 | defined $k && $n && | |
511 | @f == 3 && $k =~ /^[^\n]*\n\z/ && | |
512 | $f[0] =~ /^(ssh-|ecdsa-)/; | |
513 | ||
514 | my $g = $me->{group}; | |
515 | my $u = $me->{user}; | |
516 | ||
517 | ::write_userinfo { group => $g, | |
518 | user => $u, | |
519 | path => [@{$me->{path}}, "$g/$u"] }; | |
520 | ::write_conffiles $g, $u; | |
521 | ::write_userkey $g, $u, $me->{keyid}, $k; | |
522 | ::commit_admin_dir "gitolite-adduser for $me->{who}: set key for $g/$u"; | |
523 | } | |
524 | ||
525 | package DeleteOperation; | |
526 | use base qw(BaseOperation); | |
527 | ## Only available as an ADC operation: delete an existing unestablished user | |
528 | ## (subject to `check_adc_access'). | |
529 | ||
530 | sub parse { | |
531 | my ($cls, $arg) = @_; | |
532 | ||
533 | my $g = ::arg @$arg, "group name"; | |
534 | my $u = ::arg @$arg, "user name"; | |
535 | ::check_adc_access $g, $u; | |
536 | return bless { who => $ENV{GL_USER}, | |
537 | group => $g, | |
538 | user => $u }, $cls; | |
539 | } | |
540 | ||
541 | sub run { | |
542 | my ($me) = @_; | |
543 | ||
544 | my $g = $me->{group}; | |
545 | my $u = $me->{user}; | |
546 | ||
547 | ::delete_userinfo { group => $g, user => $u }; | |
548 | ::delete_conffiles $g, $u; | |
549 | ::delete_userkeys $g, $u; | |
550 | ::commit_admin_dir "gitolite-adduser for $me->{who}: delete $g/$u"; | |
551 | } | |
552 | ||
553 | package RewriteOperation; | |
554 | use base qw(BaseOperation); | |
555 | ## Rewrite all of the configuration files. This is only available via Userv | |
556 | ## (and should be restricted to administrators). | |
557 | ||
558 | sub userv { | |
559 | my ($cls) = @_; | |
560 | return bless { who => $ENV{USERV_USER} }, $cls; | |
561 | } | |
562 | ||
563 | sub run { | |
564 | my ($me) = @_; | |
565 | ::refresh_conffiles; | |
566 | ::commit_admin_dir "gitolite-adduser for $me->{who}: rewrite"; | |
567 | } | |
568 | ||
569 | package main; | |
570 | ||
571 | ###-------------------------------------------------------------------------- | |
572 | ### Main dispatch. | |
573 | ||
574 | (my $prog = $0) =~ s:^.*/::; | |
575 | ||
576 | eval { | |
577 | our %C = read_config "$GL_ADMINDIR/conf/adduser.conf"; | |
578 | ||
579 | our %OPMAP = ( set => 'SetOperation', | |
580 | del => 'DeleteOperation', | |
581 | rewrite => 'RewriteOperation' ); | |
582 | ||
583 | my @a = @ARGV; | |
584 | my $op; | |
585 | ||
586 | $ENV{GL_BYPASS_UPDATE_HOOK} = "t"; | |
587 | $ENV{GL_ADMINDIR} = $GL_ADMINDIR; | |
588 | ||
589 | if (exists $ENV{USERV_USER}) { | |
590 | my $opname = $ENV{USERV_SERVICE}; | |
591 | my $opcls = $OPMAP{$opname} or die "unknown operation `$opname'\n"; | |
592 | setup_admin_dir $ENV{USERV_USER}; | |
593 | $op = $opcls->userv(\@a); | |
594 | } elsif (exists $ENV{GL_USER}) { | |
595 | my $opname = arg @a, "operation"; | |
596 | my $opcls = $OPMAP{$opname} or die "unknown operation `$opname'\n"; | |
597 | setup_admin_dir $ENV{GL_USER}; | |
598 | $op = $opcls->parse(\@a); | |
599 | } else { | |
600 | die "unknown service framework\n"; | |
601 | } | |
602 | ||
603 | die "excess arguments\n" if @a; | |
604 | ||
605 | $op->run(); | |
606 | }; | |
607 | if ($@) { | |
608 | print STDERR "$prog: $@"; | |
609 | exit 1; | |
610 | } | |
611 | ||
612 | ###----- That's all, folks -------------------------------------------------- |