mail.sh: tolerate running in a linked working tree
[girocco.git] / Girocco / CLIUtil.pm
blob3b4685ee85685e983664f2dbd2ca77cd00392328
1 # Girocco::CLIUtil.pm -- Command Line Interface Utility Functions
2 # Copyright (C) 2016 Kyle J. McKay. All rights reserved.
4 # This program is free software; you can redistribute it and/or
5 # modify it under the terms of the GNU General Public License
6 # as published by the Free Software Foundation; either version 2
7 # of the License, or (at your option) any later version.
9 # This program is distributed in the hope that it will be useful,
10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 # GNU General Public License for more details.
14 # You should have received a copy of the GNU General Public License
15 # along with this program; if not, write to the Free Software
16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
19 ## IMPORTANT
21 ## This package MUST NOT be used by any CGI script as it cancels
22 ## the effect of CGI::Carp::fatalsToBrowser which could result in the
23 ## output of a CGI script becoming unparseable by the web server!
26 package Girocco::CLIUtil;
28 use strict;
29 use warnings;
31 use base qw(Exporter);
32 our ($VERSION, @EXPORT, @EXPORT_OK);
34 BEGIN {
35 @EXPORT = qw(
36 diename recreate_file strict_bool
37 is_yes is_no is_yesno valid_bool clean_bool
38 prompt prompt_or_die
39 ynprompt ynprompt_or_die
40 prompt_noecho prompt_noecho_or_die
41 prompt_noecho_nl prompt_noecho_nl_or_die
42 yes_to_continue yes_to_continue_or_die
43 get_all_users get_user get_all_projects get_project
45 @EXPORT_OK = qw(
46 _parse_options _prompt_rl _prompt_rl_or_die
47 check_passwd_match
49 *VERSION = \'1.0';
52 use File::Basename;
53 use Girocco::Config;
54 use Girocco::Util;
55 use Girocco::HashUtil;
56 use Girocco::CGI;
57 BEGIN {noFatalsToBrowser}
59 my $have_rl;
60 BEGIN {eval{
61 require Term::ReadLine;
62 $have_rl = 1;
66 package Girocco::CLIUtil::NoEcho;
67 use POSIX qw();
69 sub new {
70 my $class = shift; # ignored
71 my $self = bless {};
72 my $fd = shift || 0;
73 $self->{fd} = $fd;
74 $self->{ios} = POSIX::Termios->new;
75 $self->{ios}->getattr($self->{fd});
76 my $noecho = POSIX::Termios->new;
77 $noecho->getattr($fd);
78 $noecho->setlflag($noecho->getlflag & ~(&POSIX::ECHO));
79 $noecho->setattr($fd, &POSIX::TCSANOW);
80 $self;
83 sub DESTROY {
84 my $self = shift;
85 $self->{ios}->setattr($self->{fd}, &POSIX::TCSANOW);
89 my $diename;
90 BEGIN {$diename = ""}
91 sub diename {
92 my $result = $diename;
93 $diename = join(" ", @_) if @_;
94 $result;
97 # Parse Options
99 # Remove any leading options matching the given specs from the @ARGV array and
100 # store them as indicated. Parsing stops when an unknown option is encountered,
101 # "--" is encountered (in which case it's removed) or a non-option is encountered.
102 # Note that "-" by itself is considered a non-option argument.
104 # Option bundling for single-letter options is NOT supported.
106 # Optional first arg is CODE ref:
107 # sub {my ($err, $opt) = @_; ...}
108 # with $err of '?' meaning $opt is unknown
109 # with $err of ':' meaning $opt is missing its argument
110 # $opt is the full option as given on the command line (including leading - etc.)
111 # the default if omitted dies with an error
112 # If the sub returns, _parse_options exits immediately with 0
114 # The rest of the arguments form pairs:
115 # "spec" => ref
116 # where ref must be either a SCALAR ref or a CODE ref, if it's neither
117 # then the "spec" => ref pair is silently ignored.
118 # "spec" can be:
119 # "name" -- an incrementing flag (matches -name and --name)
120 # ":name" -- an option with a value (matches -name=val and --name=val)
121 # Using option "--name" matches spec "name" if given otherwise matches spec
122 # ":name" if given and there's at least one more argument (if not the ':' error
123 # happens).
124 # Using option "--name=val" only matches spec ":name" (but "val" can be "").
125 # For flags, a SCALAR ref is incremented, a CODE ref is called with no arguments.
126 # For values (":name" specs) a SCALAR ref is assigned the value a CODE ref is
127 # called with the value as its single argument.
129 # _parse_options returns 1 as long as there were no errors
130 sub _parse_options {
131 local $_;
132 my $failsub = sub {die((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")};
133 $failsub = shift if @_ && ref($_[0]) eq "CODE";
134 my %opts = ();
135 while (@_ >= 2) {
136 if (defined($_[0]) && $_[0] =~ /^:?[^-:\s]/ &&
137 defined($_[1]) && (ref($_[1]) eq "SCALAR" || ref($_[1]) eq "CODE")) {
138 $opts{$_[0]} = $_[1];
140 shift;
141 shift;
143 while (@ARGV && $ARGV[0] =~ /^--?[^-:\s]/) {
144 my $opt = shift @ARGV;
145 my $sopt = $opt;
146 $sopt =~ s/^--?//;
147 if ($sopt =~ /^([^=]+)=(.*)$/) {
148 my ($name, $val) = ($1, $2);
149 if ($opts{":$name"}) {
150 ${$opts{":$name"}} = $val if ref($opts{":$name"}) eq "SCALAR";
151 &{$opts{":$name"}}($val) if ref($opts{":$name"}) eq "CODE";
152 } else {
153 &$failsub('?', $opt);
154 return 0;
156 } elsif ($opts{$sopt}) {
157 ++${$opts{$sopt}} if ref($opts{$sopt}) eq "SCALAR";
158 &{$opts{$sopt}}() if ref($opts{$sopt}) eq "CODE";
159 } elsif ($opts{":$sopt"}) {
160 &$failsub(':', $opt),return(0) unless @ARGV;
161 my $val = shift @ARGV;
162 ${$opts{":$sopt"}} = $val if ref($opts{":$sopt"} eq "SCALAR");
163 &{$opts{":$sopt"}}($val) if ref($opts{":$sopt"} eq "CODE");
164 } else {
165 &$failsub('?', $opt);
166 return 0;
169 if (@ARGV && $ARGV[0] eq "--") {
170 shift @ARGV;
171 return 1;
173 if (@ARGV && $ARGV[0] =~ /^-./) {
174 &$failsub('?', $ARGV[0]);
175 return 0;
177 return 1;
180 sub recreate_file {
181 open F, '>', $_[0] or die "failed to create $_[0]: $!\n";
182 close F;
185 sub is_yes {
186 my $b = shift;
187 my $strict = shift;
188 defined ($b) or $b = "";
189 return lc($b) eq "yes" || (!$strict && lc($b) eq "y");
192 sub is_no {
193 my $b = shift;
194 my $strict = shift;
195 defined ($b) or $b = "";
196 return lc($b) eq "no" || (!$strict && lc($b) eq "n");
199 sub is_yesno {
200 return is_yes(@_) || is_no(@_);
203 my %boolvals;
204 BEGIN {
205 %boolvals = (
206 true => 1,
207 on => 1,
208 yes => 1,
209 y => 1,
210 1 => 1,
212 false => 0,
213 off => 0,
214 no => 0,
215 n => 0,
216 0 => 0,
220 sub valid_bool {
221 exists($boolvals{lc($_[0])});
224 sub clean_bool {
225 my $b = shift || 0;
226 return $boolvals{lc($b)} || 0;
229 sub _prompt_rl {
230 my ($norl, $prompt, $default, $promptsfx) = @_;
231 ! -t STDIN and $norl = 1;
232 defined($promptsfx) or $promptsfx = ': ';
233 defined($prompt) or $prompt = '';
234 my $ds = '';
235 $ds = " [" . $default . "]" if defined($default);
236 if ($have_rl && !$norl) {
237 my $rl = Term::ReadLine->new(basename($0), \*STDIN, \*STDOUT);
238 $rl->ornaments(0);
239 $_ = $rl->readline($prompt . $ds . $promptsfx);
240 $rl->addhistory($_) if defined($_) && $_ =~ /\S/;
241 } else {
242 print $prompt, $ds, $promptsfx;
243 $_ = <STDIN>;
245 return undef unless defined($_);
246 chomp;
247 return $_ eq '' && defined($default) ? $default : $_;
250 sub prompt {
251 return _prompt_rl(undef, @_);
254 sub ynprompt {
255 my $result;
256 my @args = @_;
257 $args[2] = "? " unless defined$args[2];
259 $result = prompt(@args);
260 return undef unless defined($result);
261 redo unless is_yesno($result);
263 return clean_bool($result);
266 sub _prompt_rl_or_die {
267 my $result = _prompt_rl(@_);
268 unless (defined($result)) {
269 my $nm = $diename;
270 defined($nm) or $nm = "";
271 $nm eq "" or $nm .= " ";
272 die "\n${nm}aborted\n";
274 $result;
277 sub prompt_or_die {
278 return _prompt_rl_or_die(undef, @_);
281 sub ynprompt_or_die {
282 my $result = ynprompt(@_);
283 unless (defined($result)) {
284 my $nm = $diename;
285 defined($nm) or $nm = "";
286 $nm eq "" or $nm .= " ";
287 die "\n${nm}aborted\n";
289 $result;
292 sub prompt_noecho {
293 my $ne = Girocco::CLIUtil::NoEcho->new;
294 _prompt_rl(1, @_);
297 sub prompt_noecho_or_die {
298 my $ne = Girocco::CLIUtil::NoEcho->new;
299 _prompt_rl_or_die(1, @_);
302 sub prompt_noecho_nl {
303 my $result = prompt_noecho(@_);
304 print "\n";
305 $result;
308 sub prompt_noecho_nl_or_die {
309 my $result = prompt_noecho_or_die(@_);
310 print "\n";
311 $result;
314 sub yes_to_continue {
315 return !!ynprompt(($_[0]||"Continue (enter \"yes\" to continue)"), "no");
318 sub yes_to_continue_or_die {
319 unless (ynprompt_or_die(($_[0]||"Continue (enter \"yes\" to continue)"), "no")) {
320 my $nm = $diename;
321 defined($nm) or $nm = "";
322 $nm .= " " if $nm ne "";
323 die "${nm}aborted\n";
325 return 1;
328 my @user_list;
329 my $user_list_loaded;
331 # Return array of arrayref where each arrayref has:
332 # [0] = ordering ordinal from $chroot/etc/passwd
333 # [1] = user name
334 # [2] = user id number
335 # [3] = user group number
336 # [4] = user email
337 # [5] = user UUID (text as 8x-4x-4x-4x-12x) or undef if none
338 # [6] = user creation date as YYYYMMDD_HHMMSS (UTC) or undef if none
339 sub get_all_users {
340 return @user_list if $user_list_loaded;
341 my $passwd_file = jailed_file("/etc/passwd");
342 open my $fd, '<', $passwd_file or die "could not open \"$passwd_file\": $!\n";
343 my $line = 0;
344 my @users = map {/^([^:_\s#][^:\s#]*):[^:]+:(\d{5,}):(\d+):([^:,][^:]*)/
345 ? [++$line,$1,$2,$3,split(',',$4)] : ()} <$fd>;
346 close $fd;
347 @user_list = grep({$$_[4] =~ /\@/} @users);
348 $user_list_loaded = 1;
349 @user_list;
352 # Result of Girocco::User->load or fatal die if that fails
353 # Returns undef if passed undef or ""
354 sub get_user {
355 my $username = shift;
356 defined($username) && $username ne "" or return undef;
357 Girocco::User::does_exist($username, 1) or die "No such user: \"$username\"\n";
358 my $user;
359 eval {
360 $user = Girocco::User->load($username);
362 } && $user->{uid} or die "Could not load user \"$username\"\n";
363 $user;
366 my @project_list;
367 my $project_list_loaded;
369 # Return array of arrayref where each arrayref has:
370 # [0] = ordering ordinal from $chroot/etc/group
371 # [1] = group name
372 # [2] = group password hash
373 # [3] = group id number
374 # [4] = owner from gitproj.list
375 # [5] = list of comma-separated push user names (can be "") or ":" if mirror
376 sub get_all_projects {
377 return @project_list if $project_list_loaded;
378 my $fd;
379 my $projlist_file = $Girocco::Config::projlist_cache_dir."/gitproj.list";
380 open $fd, '<', $projlist_file or die "could not open \"$projlist_file\": $!\n";
381 my $chomper = sub {chomp(my $x = shift); $x;};
382 my %owners = map {(split(/\s+/, &$chomper($_), 3))[0,2]} <$fd>;
383 close $fd;
384 my $group_file = jailed_file("/etc/group");
385 open $fd, '<', $group_file or die "could not open \"$group_file\": $!\n";
386 my $line = 0;
387 my $trimu = sub {
388 my $list = shift;
389 return ':' if $list =~ /^:/;
390 $list =~ s/:.*$//;
391 $list;
393 my $defu = sub {defined($_[0])?$_[0]:""};
394 my @projects = map {/^([^:_\s#][^:\s#]*):([^:]*):(\d{5,}):(.*)$/
395 ? [++$line,$1,$2,$3,&$defu($owners{$1}),&$trimu($4)] : ()} <$fd>;
396 close $fd;
397 @project_list = @projects;
398 $project_list_loaded = 1;
399 @project_list;
402 # Result of Girocco::Project->load or fatal die if that fails
403 # Returns undef if passed undef or ""
404 sub get_project {
405 my $projname = shift;
406 $projname =~ s/\.git$//i if defined($projname);
407 defined($projname) && $projname ne "" or return undef;
408 Girocco::Project::does_exist($projname, 1) or die "No such project: \"$projname\"\n";
409 my $project;
410 eval {
411 $project = Girocco::Project->load($projname);
413 } && $project->{loaded} or die "Could not load project \"$projname\"\n";
414 $project;
417 # return true if $enc_passwd is a match for $plain_passwd
418 sub check_passwd_match {
419 my ($enc_passwd, $plain_passwd) = @_;
420 defined($enc_passwd) or $enc_passwd = '';
421 defined($plain_passwd) or $plain_passwd = '';
422 # $enc_passwd may be crypt or crypt_sha1
423 if ($enc_passwd =~ m(^\$sha1\$(\d+)\$([./0-9A-Za-z]{1,64})\$[./0-9A-Za-z]{28}$)) {
424 # It's using sha1-crypt
425 return $enc_passwd eq crypt_sha1($plain_passwd, $2, -(0+$1));
426 } else {
427 # It's using crypt
428 return $enc_passwd eq crypt($plain_passwd, $enc_passwd);