Girocco/CLIUtil.pm

   1 # Girocco::CLIUtil.pm -- Command Line Interface Utility Functions
   2 # Copyright (C) 2016 Kyle J. McKay.  All rights reserved.
   3
   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.
   8 #
   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.
  13 #
  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.
  17
  18 #
  19 ## IMPORTANT
  20 ##
  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!
  24 #
  25
  26 package Girocco::CLIUtil;
  27
  28 use strict;
  29 use warnings;
  30
  31 use base qw(Exporter);
  32 our ($VERSION, @EXPORT, @EXPORT_OK);
  33
  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
  44                 get_full_users nice_me setup_pager setup_pager_stdout
  45                 pager_in_use get_project_harder
  46         );
  47         @EXPORT_OK = qw(
  48                 _parse_options _prompt_rl _prompt_rl_or_die
  49                 check_passwd_match _which
  50         );
  51         *VERSION = \'1.0';
  52 }
  53
  54 use File::Basename;
  55 use File::Spec;
  56 use Cwd qw(getcwd);
  57 use POSIX qw(:fcntl_h);
  58 use Girocco::Config;
  59 use Girocco::Util;
  60 use Girocco::HashUtil;
  61 use Girocco::CGI;
  62 BEGIN {noFatalsToBrowser}
  63
  64 my $have_rl;
  65 BEGIN {eval{
  66         require Term::ReadLine;
  67         $have_rl = 1;
  68 }}
  69
  70 {
  71         package Girocco::CLIUtil::NoEcho;
  72
  73         sub new {
  74                 my $class = shift; # ignored
  75                 my $self = bless {};
  76                 my $fd = shift || 0;
  77                 $self->{fd} = $fd;
  78                 $self->{ios} = POSIX::Termios->new;
  79                 $self->{ios}->getattr($self->{fd});
  80                 my $noecho = POSIX::Termios->new;
  81                 $noecho->getattr($fd);
  82                 $noecho->setlflag($noecho->getlflag & ~(&POSIX::ECHO));
  83                 $noecho->setattr($fd, &POSIX::TCSANOW);
  84                 $self;
  85         }
  86
  87         sub DESTROY {
  88                 my $self = shift;
  89                 $self->{ios}->setattr($self->{fd}, &POSIX::TCSANOW);
  90         }
  91 }
  92
  93 {
  94         package Girocco::CLIUtil::Progress;
  95
  96         use Scalar::Util qw(looks_like_number);
  97         use Time::HiRes qw(gettimeofday);
  98
  99         sub fractime() { return scalar(gettimeofday) }
 100
 101         my $_init;
 102         BEGIN { $_init = sub {
 103                 my $self = shift;
 104                 my $max = shift;
 105                 looks_like_number($max) && $max >= 0 or $max = 100;
 106                 my $title = shift;
 107                 defined($title) or $title = "";
 108                 $title =~ s/:+$//;
 109                 $title ne "" or $title = "Progress";
 110                 my $lastupd = $self->{lastupd};
 111                 my $shown1 = $self->{shown1};
 112                 looks_like_number($lastupd) or $lastupd = fractime + 2;
 113                 %$self = (
 114                         title => $title,
 115                         max => $max,
 116                         cur => 0,
 117                         len => 0,
 118                         lastupd => $lastupd
 119                 );
 120                 defined($shown1) and $self->{shown1} = $shown1;
 121                 $self;
 122         } }
 123
 124         sub new {
 125                 my $class = shift || __PACKAGE__;
 126                 my $self = bless {}, $class;
 127                 unshift(@_, $self);
 128                 select((select(STDERR),$|=1)[0]);
 129                 select((select(STDOUT),$|=1)[0]);
 130                 return &$_init;
 131         }
 132
 133         sub reset {
 134                 my $self = $_[0];
 135                 $self->clear;
 136                 my $wasvis = $self->{wasvis};
 137                 &$_init;
 138                 $wasvis and $self->show;
 139                 $self;
 140         }
 141
 142         sub val { $_[0]->{cur} }
 143         sub done { $_[0]->{cur} >= $_[0]->{max} }
 144
 145         sub update {
 146                 my $self = shift;
 147                 !$self->{max} and return;
 148                 my $last = $self->{cur};
 149                 my $newcur = shift;
 150                 looks_like_number($newcur) or $newcur = $last + 1;
 151                 $newcur >= $last or $newcur = $last;
 152                 $newcur > $self->{max} and $newcur = $self->{max};
 153                 $self->{cur} = $newcur unless $newcur == $last;
 154                 my $now = fractime;
 155                 if ($self->{shown1} && $newcur > $last && $newcur >= $self->{max} ||
 156                     $now >= $self->{lastupd} + 1) {
 157                         $self->{lastupd} = $now;
 158                         !$self->{len} || $newcur != $last and $self->show;
 159                 }
 160         }
 161
 162         sub show {
 163                 my $self = shift;
 164                 delete $self->{wasvis};
 165                 !$self->{max} and return;
 166                 my $p = int((100 * $self->{cur} / $self->{max}) + 0.5);
 167                 $p > 100 and $p = 100;
 168                 $p == 100 && $self->{cur} < $self->{max} and $p = 99;
 169                 my $status = sprintf("%s: %3d%% (%d/%d)", $self->{title},
 170                         $p, $self->{cur}, $self->{max});
 171                 my $newlen = length($status);
 172                 $self->{len} > $newlen and $status .= " " x ($self->{len} - $newlen);
 173                 printf STDERR "%s\r", $status;
 174                 $self->{len} = $newlen;
 175                 $self->{shown1} = 1;
 176         }
 177
 178         sub clear {
 179                 my $self = shift;
 180                 if ($self->{len}) {
 181                         printf STDERR "%s\r", " " x $self->{len};
 182                         $self->{len} = 0;
 183                         $self->{wasvis} = 1;
 184                 }
 185         }
 186
 187         sub restore {
 188                 my $self = shift;
 189                 $self->{wasvis} and $self->show;
 190         }
 191
 192         sub emitfh {
 193                 my $self = shift;
 194                 my $fh = shift;
 195                 my $msg = join(' ', @_);
 196                 defined($msg) or return;
 197                 chomp $msg;
 198                 $msg ne '' or return;
 199                 $self->clear;
 200                 printf $fh "%s\n", $msg;
 201                 $self->restore;
 202         }
 203
 204         sub emit {
 205                 my $self = shift;
 206                 $self->emitfh(\*STDOUT, @_);
 207         }
 208
 209         sub warn {
 210                 my $self = shift;
 211                 $self->emitfh(\*STDERR, @_);
 212         }
 213
 214         sub DESTROY {
 215                 my $self = shift;
 216                 $self->clear;
 217         }
 218
 219 }# END package Girocco::CLIUtil::Progress
 220
 221 my $diename;
 222 BEGIN {$diename = ""}
 223 sub diename {
 224         my $result = $diename;
 225         $diename = join(" ", @_) if @_;
 226         $result;
 227 }
 228
 229 # Parse Options
 230 #
 231 # Remove any leading options matching the given specs from the @ARGV array and
 232 # store them as indicated.  Parsing stops when an unknown option is encountered,
 233 # "--" is encountered (in which case it's removed) or a non-option is encountered.
 234 # Note that "-" by itself is considered a non-option argument.
 235 #
 236 # Option bundling for single-letter options is NOT supported.
 237 #
 238 # Optional first arg is CODE ref:
 239 #   sub {my ($err, $opt) = @_; ...}
 240 # with $err of '?' meaning $opt is unknown
 241 # with $err of ':' meaning $opt is missing its argument
 242 # $opt is the full option as given on the command line (including leading - etc.)
 243 # the default if omitted dies with an error
 244 # If the sub returns, _parse_options exits immediately with 0
 245 #
 246 # The rest of the arguments form pairs:
 247 #   "spec" => ref
 248 # where ref must be either a SCALAR ref or a CODE ref, if it's neither
 249 # then the "spec" => ref pair is silently ignored.
 250 # "spec" can be:
 251 #   "name"   -- an incrementing flag (matches -name and --name)
 252 #   ":name"  -- an option with a value (matches -name=val and --name=val)
 253 # Using option "--name" matches spec "name" if given otherwise matches spec
 254 # ":name" if given and there's at least one more argument (if not the ':' error
 255 # happens).
 256 # Using option "--name=val" only matches spec ":name" (but "val" can be "").
 257 # For flags, a SCALAR ref is incremented, a CODE ref is called with no arguments.
 258 # For values (":name" specs) a SCALAR ref is assigned the value a CODE ref is
 259 # called with the value as its single argument.
 260 #
 261 # _parse_options returns 1 as long as there were no errors
 262 sub _parse_options {
 263         local $_;
 264         my $failsub = sub {die((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")};
 265         $failsub = shift if @_ && ref($_[0]) eq "CODE";
 266         my %opts = ();
 267         while (@_ >= 2) {
 268                 if (defined($_[0]) && $_[0] =~ /^:?[^-:\s]/ &&
 269                     defined($_[1]) && (ref($_[1]) eq "SCALAR" || ref($_[1]) eq "CODE")) {
 270                         $opts{$_[0]} = $_[1];
 271                 }
 272                 shift;
 273                 shift;
 274         }
 275         while (@ARGV && $ARGV[0] =~ /^--?[^-:\s]/) {
 276                 my $opt = shift @ARGV;
 277                 my $sopt = $opt;
 278                 $sopt =~ s/^--?//;
 279                 if ($sopt =~ /^([^=]+)=(.*)$/) {
 280                         my ($name, $val) = ($1, $2);
 281                         if ($opts{":$name"}) {
 282                                 ${$opts{":$name"}} = $val if ref($opts{":$name"}) eq "SCALAR";
 283                                 &{$opts{":$name"}}($val) if ref($opts{":$name"}) eq "CODE";
 284                         } else {
 285                                 &$failsub('?', $opt);
 286                                 return 0;
 287                         }
 288                 } elsif ($opts{$sopt}) {
 289                         ++${$opts{$sopt}} if ref($opts{$sopt}) eq "SCALAR";
 290                         &{$opts{$sopt}}() if ref($opts{$sopt}) eq "CODE";
 291                 } elsif ($opts{":$sopt"}) {
 292                         &$failsub(':', $opt),return(0) unless @ARGV;
 293                         my $val = shift @ARGV;
 294                         ${$opts{":$sopt"}} = $val if ref($opts{":$sopt"} eq "SCALAR");
 295                         &{$opts{":$sopt"}}($val) if ref($opts{":$sopt"} eq "CODE");
 296                 } else {
 297                         &$failsub('?', $opt);
 298                         return 0;
 299                 }
 300         }
 301         if (@ARGV && $ARGV[0] eq "--") {
 302                 shift @ARGV;
 303                 return 1;
 304         }
 305         if (@ARGV && $ARGV[0] =~ /^-./) {
 306                 &$failsub('?', $ARGV[0]);
 307                 return 0;
 308         }
 309         return 1;
 310 }
 311
 312 sub recreate_file {
 313         open F, '>', $_[0] or die "failed to create $_[0]: $!\n";
 314         close F;
 315 }
 316
 317 sub is_yes {
 318         my $b = shift;
 319         my $strict = shift;
 320         defined ($b) or $b = "";
 321         return lc($b) eq "yes" || (!$strict && lc($b) eq "y");
 322 }
 323
 324 sub is_no {
 325         my $b = shift;
 326         my $strict = shift;
 327         defined ($b) or $b = "";
 328         return lc($b) eq "no" || (!$strict && lc($b) eq "n");
 329 }
 330
 331 sub is_yesno {
 332         return is_yes(@_) || is_no(@_);
 333 }
 334
 335 my %boolvals;
 336 BEGIN {
 337         %boolvals = (
 338                 true  => 1,
 339                 on    => 1,
 340                 yes   => 1,
 341                 y     => 1,
 342                 1     => 1,
 343
 344                 false => 0,
 345                 off   => 0,
 346                 no    => 0,
 347                 n     => 0,
 348                 0     => 0,
 349         );
 350 }
 351
 352 sub valid_bool {
 353         exists($boolvals{lc($_[0])});
 354 }
 355
 356 sub clean_bool {
 357         my $b = shift || 0;
 358         return $boolvals{lc($b)} || 0;
 359 }
 360
 361 sub _prompt_rl {
 362         my ($norl, $prompt, $default, $promptsfx) = @_;
 363         ! -t STDIN and $norl = 1;
 364         defined($promptsfx) or $promptsfx = ': ';
 365         defined($prompt) or $prompt = '';
 366         my $ds = '';
 367         $ds = " [" . $default . "]" if defined($default);
 368         if ($have_rl && !$norl) {
 369                 my $rl = Term::ReadLine->new(basename($0), \*STDIN, \*STDOUT);
 370                 $rl->ornaments(0);
 371                 $_ = $rl->readline($prompt . $ds . $promptsfx);
 372                 $rl->addhistory($_) if defined($_) && $_ =~ /\S/;
 373         } else {
 374                 print $prompt, $ds, $promptsfx;
 375                 $_ = <STDIN>;
 376         }
 377         return undef unless defined($_);
 378         chomp;
 379         return $_ eq '' && defined($default) ? $default : $_;
 380 }
 381
 382 sub prompt {
 383         return _prompt_rl(undef, @_);
 384 }
 385
 386 sub ynprompt {
 387         my $result;
 388         my @args = @_;
 389         $args[2] = "? " unless defined$args[2];
 390         {
 391                 $result = prompt(@args);
 392                 return undef unless defined($result);
 393                 redo unless is_yesno($result);
 394         }
 395         return clean_bool($result);
 396 }
 397
 398 sub _prompt_rl_or_die {
 399         my $result = _prompt_rl(@_);
 400         unless (defined($result)) {
 401                 my $nm = $diename;
 402                 defined($nm) or $nm = "";
 403                 $nm eq "" or $nm .= " ";
 404                 die "\n${nm}aborted\n";
 405         }
 406         $result;
 407 }
 408
 409 sub prompt_or_die {
 410         return _prompt_rl_or_die(undef, @_);
 411 }
 412
 413 sub ynprompt_or_die {
 414         my $result = ynprompt(@_);
 415         unless (defined($result)) {
 416                 my $nm = $diename;
 417                 defined($nm) or $nm = "";
 418                 $nm eq "" or $nm .= " ";
 419                 die "\n${nm}aborted\n";
 420         }
 421         $result;
 422 }
 423
 424 sub prompt_noecho {
 425         my $ne = Girocco::CLIUtil::NoEcho->new;
 426         _prompt_rl(1, @_);
 427 }
 428
 429 sub prompt_noecho_or_die {
 430         my $ne = Girocco::CLIUtil::NoEcho->new;
 431         _prompt_rl_or_die(1, @_);
 432 }
 433
 434 sub prompt_noecho_nl {
 435         my $result = prompt_noecho(@_);
 436         print "\n";
 437         $result;
 438 }
 439
 440 sub prompt_noecho_nl_or_die {
 441         my $result = prompt_noecho_or_die(@_);
 442         print "\n";
 443         $result;
 444 }
 445
 446 sub yes_to_continue {
 447         return !!ynprompt(($_[0]||"Continue (enter \"yes\" to continue)"), "no");
 448 }
 449
 450 sub yes_to_continue_or_die {
 451         unless (ynprompt_or_die(($_[0]||"Continue (enter \"yes\" to continue)"), "no")) {
 452                 my $nm = $diename;
 453                 defined($nm) or $nm = "";
 454                 $nm .= " " if $nm ne "";
 455                 die "${nm}aborted\n";
 456         }
 457         return 1;
 458 }
 459
 460 my @user_list;
 461 my $user_list_loaded;
 462 my @full_user_list;
 463 my $full_user_list_loaded;
 464
 465 # If single argument is true, return ALL passwd entries not just "...@..." ones
 466 sub _get_all_users_internal {
 467         my $full = shift || 0;
 468         if ($full) {
 469                 return @full_user_list if $full_user_list_loaded;
 470         } else {
 471                 return @user_list if $user_list_loaded;
 472         }
 473         my $passwd_file = jailed_file("/etc/passwd");
 474         open my $fd, '<', $passwd_file or die "could not open \"$passwd_file\": $!\n";
 475         my $line = 0;
 476         my @users;
 477         if ($full) {
 478                 @users = map {/^([^:\s#][^:\s]*):[^:]*:(-?\d+):(-?\d+)(:|$)/
 479                          ? [++$line,split(':',$_,-1)] : ()} <$fd>;
 480         } else {
 481                 @users = map {/^([^:_\s#][^:\s#]*):[^:]+:(\d{5,}):(\d+):([^:,][^:]*)/
 482                          ? [++$line,$1,$2,$3,split(',',$4)] : ()} <$fd>;
 483         }
 484         close $fd;
 485         if ($full) {
 486                 $$_[5] = [split(',', $$_[5])] foreach @users;
 487                 @full_user_list = @users;
 488                 $full_user_list_loaded = 1;
 489         } else {
 490                 @users = grep({$$_[4] =~ /\@/} @users);
 491                 @user_list = @users;
 492                 $user_list_loaded = 1;
 493         }
 494         @users;
 495 }
 496
 497 # Return array of arrayref where each arrayref has:
 498 #   [0] = ordering ordinal from $chroot/etc/passwd
 499 #   [1] = user name
 500 #   [2] = user id number
 501 #   [3] = user group number
 502 #   [4] = user email
 503 #   [5] = user UUID (text as 8x-4x-4x-4x-12x) or undef if none
 504 #   [6] = user creation date as YYYYMMDD_HHMMSS (UTC) or undef if none
 505 sub get_all_users { return _get_all_users_internal; }
 506
 507 # Return array of arrayref where each arrayref has:
 508 #   [0] = ordering ordinal from $chroot/etc/passwd
 509 #   [1] = user name
 510 #   [2] = user password field (usually "x")
 511 #   [3] = user id number
 512 #   [4] = user group number
 513 #   [5] = [info fields] from passwd line (usually email,uuid,creation)
 514 #   [6] = home dir field
 515 #   [7] = shell field
 516 #   [...] possibly more, but [7] is usually max
 517 sub get_full_users { return _get_all_users_internal(1); }
 518
 519 # Result of Girocco::User->load or fatal die if that fails
 520 # Returns undef if passed undef or ""
 521 sub get_user {
 522         my $username = shift;
 523         defined($username) && $username ne "" or return undef;
 524         Girocco::User::does_exist($username, 1) or die "No such user: \"$username\"\n";
 525         my $user;
 526         eval {
 527                 $user = Girocco::User->load($username);
 528                 1;
 529         } && $user->{uid} or die "Could not load user \"$username\"\n";
 530         $user;
 531 }
 532
 533 my @project_list;
 534 my $project_list_loaded;
 535
 536 # Return array of arrayref where each arrayref has:
 537 #   [0] = ordering ordinal from $chroot/etc/group
 538 #   [1] = group name
 539 #   [2] = group password hash
 540 #   [3] = group id number
 541 #   [4] = owner from gitproj.list
 542 #   [5] = list of comma-separated push user names (can be "") or ":" if mirror
 543 sub get_all_projects {
 544         return @project_list if $project_list_loaded;
 545         my $fd;
 546         my $projlist_file = $Girocco::Config::projlist_cache_dir."/gitproj.list";
 547         open $fd, '<', $projlist_file or die "could not open \"$projlist_file\": $!\n";
 548         my $chomper = sub {chomp(my $x = shift); $x;};
 549         my %owners = map {(split(/\s+/, &$chomper($_), 3))[0,2]} <$fd>;
 550         close $fd;
 551         my $group_file = jailed_file("/etc/group");
 552         open $fd, '<', $group_file or die "could not open \"$group_file\": $!\n";
 553         my $line = 0;
 554         my $trimu = sub {
 555                 my $list = shift;
 556                 return ':' if $list =~ /^:/;
 557                 $list =~ s/:.*$//;
 558                 $list;
 559         };
 560         my $defu = sub {defined($_[0])?$_[0]:""};
 561         my @projects = map {/^([^:_\s#][^:\s#]*):([^:]*):(\d{5,}):(.*)$/
 562                             ? [++$line,$1,$2,$3,&$defu($owners{$1}),&$trimu($4)] : ()} <$fd>;
 563         close $fd;
 564         @project_list = @projects;
 565         $project_list_loaded = 1;
 566         @project_list;
 567 }
 568
 569 # Result of Girocco::Project->load or fatal die if that fails, but
 570 # if the optional second argument is true and the initial
 571 # Girocco::Project->does_exist fails and the first argument names an
 572 # existing path, an attempt is made to translate that path into a Girocco
 573 # project name and if successful a Girocco::Project->load will be done on that.
 574 # Returns undef if passed undef or ""
 575 sub get_project {
 576         my ($projnameorpath, $tryharder) = @_;
 577         (my $projname = $projnameorpath) =~ s/\.git$//i if defined($projnameorpath);
 578         defined($projnameorpath) && defined($projname) or return undef;
 579         $projname ne "" && Girocco::Project::does_exist($projname, 1) or do {{
 580                 $projname = undef;
 581                 last unless $tryharder;
 582                 # attempt to translate a path into a project
 583                 my $pn = undef;
 584                 $pn = get_project_from_dir($projnameorpath) if $projnameorpath ne "";
 585                 defined($pn) && $pn eq "" and $pn = undef;
 586                 if (!defined($pn) && $projnameorpath ne "" && -d $projnameorpath) {
 587                         # see if Git can tell us a --git-dir for the directory
 588                         my $gd = undef;
 589                         my $oldcd = getcwd();
 590                         $oldcd = $1 if defined($oldcd) && $oldcd =~ m{^(/.+)$};
 591                         if (chdir($projnameorpath)) {
 592                                 $gd = get_git("rev-parse", "--git-dir");
 593                                 chdir($oldcd);
 594                                 defined($gd) and chomp($gd);
 595                         }
 596                         # could be ugly relative thing
 597                         defined($gd) && $gd ne "" && substr($gd,0,1) ne "/" and
 598                                 $gd = "$projnameorpath/$gd";
 599                         # try it again if we got something (could be a "gitdir" file)
 600                         defined($gd) && $gd ne "" && -e $gd and
 601                                 $pn = get_project_from_dir($gd);
 602                 }
 603                 defined($pn) && $pn ne "" and $projname = $pn;
 604         }};
 605         defined($projname) && $projname ne "" or die "No such project: \"$projnameorpath\"\n";
 606         my $project;
 607         eval {
 608                 $project = Girocco::Project->load($projname);
 609                 1;
 610         } && $project->{loaded} or die "Could not load project \"$projname\"\n";
 611         $project;
 612 }
 613
 614 # convenience/self-documenting function that calls get_project
 615 # with its first argument and passes true for the second
 616 sub get_project_harder {
 617         my $projnameorpath = shift;
 618         return get_project($projnameorpath, 1);
 619 }
 620
 621 # return true if $enc_passwd is a match for $plain_passwd
 622 sub check_passwd_match {
 623         my ($enc_passwd, $plain_passwd) = @_;
 624         defined($enc_passwd) or $enc_passwd = '';
 625         defined($plain_passwd) or $plain_passwd = '';
 626         # $enc_passwd may be crypt or crypt_sha1
 627         if ($enc_passwd =~ m(^\$sha1\$(\d+)\$([./0-9A-Za-z]{1,64})\$[./0-9A-Za-z]{28}$)) {
 628                 # It's using sha1-crypt
 629                 return $enc_passwd eq crypt_sha1($plain_passwd, $2, -(0+$1));
 630         } else {
 631                 # It's using crypt
 632                 return $enc_passwd eq crypt($plain_passwd, $enc_passwd);
 633         }
 634 };
 635
 636 sub _which {
 637         my $cmd = shift;
 638         foreach (File::Spec->path()) {
 639                 my $p = File::Spec->catfile($_, $cmd);
 640                 no warnings 'newline';
 641                 return $p if -x $p && -f _;
 642         }
 643         return undef;
 644 }
 645
 646 # apply maximum nice and ionice
 647 my $ionice;
 648 sub nice_me {
 649         my $niceval = shift;
 650         if (defined($niceval) && $niceval =~ /^\d+$/ && 0 + $niceval >= 1) {
 651                 my $oldval = POSIX::nice(0);
 652                 POSIX::nice($niceval - $oldval) if $oldval && $niceval > $oldval;
 653         } else {
 654                 POSIX::nice(20);
 655         }
 656         defined($ionice) or $ionice = _which("ionice");
 657         defined($ionice) or $ionice = "";
 658         if ($ionice ne "") {
 659                 my $devnullfd = POSIX::open(File::Spec->devnull, O_RDWR);
 660                 defined($devnullfd) && $devnullfd >= 0 or die "cannot open /dev/null: $!";
 661                 my ($dupin, $dupout, $duperr);
 662                 open $dupin, '<&0' or die "cannot dup STDIN_FILENO: $!";
 663                 open $dupout, '>&1' or die "cannot dup STDOUT_FILENO: $!";
 664                 open $duperr, '>&2' or die "cannot dup STDERR_FILENO: $!";
 665                 POSIX::dup2($devnullfd, 0) or die "cannot dup2 STDIN_FILENO: $!";
 666                 POSIX::dup2($devnullfd, 1) or die "cannot dup2 STDOUT_FILENO: $!";
 667                 POSIX::dup2($devnullfd, 2) or POSIX::dup2(fileno($duperr), 2), die "cannot dup2 STDERR_FILENO: $!";
 668                 POSIX::close($devnullfd);
 669                 system $ionice, "-c", "3", "-p", $$;
 670                 POSIX::dup2(fileno($duperr), 2) or die "cannot dup2 STDERR_FILENO: $!";
 671                 POSIX::dup2(fileno($dupout), 1) or die "cannot dup2 STDOUT_FILENO: $!";
 672                 POSIX::dup2(fileno($dupin), 0) or die "cannot dup2 STDIN_FILENO: $!";
 673                 close $duperr;
 674                 close $dupout;
 675                 close $dupin;
 676         }
 677 }
 678
 679 # spawn a pager and return the write side of
 680 # a pipe to its input.  Does not check to see
 681 # if STDOUT is a terminal or anything else like
 682 # that.  Caller is responsible for those checks.
 683 # Pager will be chosen as follows:
 684 #   1. $ENV{PAGER} if non-empty (eval'd by shell)
 685 #   2. less if found in $ENV{PATH}
 686 #   3. more if found in $ENV{PATH}
 687 # Returns undef if no pager can be found or
 688 # setup fails.  If return context is wantarray
 689 # and pager is created, will return list of
 690 # new output handle and pid of child.
 691 # As a special case to facilitate paging of STDOUT,
 692 # if the first argument is the string "become child",
 693 # then, if a pager is created, the child will return
 694 # to the caller and the parent will exec the pager!
 695 # (The returned pid in that case is the parent's pid
 696 # and the parent waits for the child to finish to propagate
 697 # its exit status as the final exit value.)
 698 sub setup_pager {
 699         my $magic = $_[0];
 700         defined($magic) && lc($magic) eq "become child" or
 701                 $magic = 0;
 702         my @cmd = ();
 703         if (defined($ENV{PAGER}) && $ENV{PAGER} ne "") {
 704                 my $cmd = $ENV{PAGER};
 705                 $cmd =~ /^(.+)$/ and $cmd = $1;
 706                 my $pgbin = undef;
 707                 {
 708                         no warnings 'newline';
 709                         -x $cmd && -f $cmd and $pgbin = $cmd;
 710                 }
 711                 defined($pgbin) && $pgbin ne "" or $pgbin = _which($cmd);
 712                 if (defined($pgbin) && $pgbin ne "") {
 713                         $pgbin =~ /^(.+)$/ and push(@cmd, $1);
 714                 } else {
 715                         $cmd =~ /\s/ || is_shellish($cmd) or
 716                                 return undef;
 717                         my $sh = $Girocco::Config::posix_sh_bin;
 718                         defined($sh) && $sh ne "" or $sh = '/bin/sh';
 719                         push(@cmd, $sh, "-c", $cmd, $sh);
 720                 }
 721         }
 722         if (!@cmd) {
 723                 my $pgbin = _which("less");
 724                 $pgbin or $pgbin = _which("more");
 725                 defined($pgbin) && $pgbin ne "" or return undef;
 726                 $pgbin =~ /^(.+)$/ and push(@cmd, $1);
 727         }
 728         local $ENV{LESS} = "-FRX" unless exists($ENV{LESS});
 729         local $ENV{LV} = "-c" unless exists($ENV{LV});
 730         my $pghnd;
 731         use POSIX ();
 732         my ($rfd, $wfd) = POSIX::pipe();
 733         defined($rfd) && defined($wfd) && $rfd >= 0 && $wfd >= 0 or
 734                 die "POSIX::pipe failed: $!\n";
 735         my $pid = fork();
 736         defined($pid) or
 737                 die "fork failed: $!\n";
 738         if (!$magic && !$pid || $magic && $pid) {
 739                 POSIX::close($wfd);
 740                 POSIX::dup2($rfd, 0);
 741                 POSIX::close($rfd);
 742                 if (!$magic) {
 743                         exec {$cmd[0]} @cmd or
 744                                 die "exec \"$cmd[0]\" failed: $!\n";
 745                 }
 746                 my $pagerpid = fork();
 747                 defined($pagerpid) or
 748                         die "fork failed: $!\n";
 749                 if (!$pagerpid) {
 750                         exec {$cmd[0]} @cmd or
 751                                 die "exec \"$cmd[0]\" failed: $!\n";
 752                 }
 753                 my $wc = undef;
 754                 for (;;) {
 755                         my $child = wait;
 756                         last if $child == -1;
 757                         $child == $pid and $wc = $?;
 758                 }
 759                 defined($wc) or exit 255;
 760                 my $ec = $wc >> 8;
 761                 $ec != ($ec & 0xff) and $ec = 255;
 762                 $ec |= 128 if $wc & 0xff;
 763                 exit $ec;
 764         }
 765         $magic and $pid = getppid();
 766         POSIX::close($rfd);
 767         open $pghnd, '>&=', $wfd or
 768                         die "fdopen of pipe write end failed: $!\n";
 769         defined($pid) && defined($pghnd) or return undef;
 770         return wantarray ? ($pghnd, $pid) : $pghnd;
 771 }
 772
 773 # return true if any of the known PAGER_IN_USE environment
 774 # variables are set
 775 sub pager_in_use {
 776         return $ENV{GIT_PAGER_IN_USE} || $ENV{TG_PAGER_IN_USE};
 777 }
 778
 779 # possibly set STDOUT to flow through a pager
 780 # $_[0]:
 781 #   defined and false  -> return without doing anything
 782 #   defined and true   -> set STDOUT to setup_pager result
 783 #   undefined:
 784 #     ! -t STDOUT      -> return without doing anything
 785 #     -t STDOUT:
 786 #       $_[1] is false -> set STDOUT to setup_pager result
 787 #       $_[1] is true  -> return without doing anything
 788 # $[1] means do NOT enable paging by default on -t STDOUT
 789 # Most clients can simply call this function without arguments
 790 # which will add a pager only if STDOUT is a terminal
 791 # If pager_in_use, returns without doing anything.
 792 # If pager is activated, sets known pager in use env vars.
 793 sub setup_pager_stdout {
 794         pager_in_use() and return;
 795         my $want_pager = $_[0];
 796         defined($want_pager) or
 797                 $want_pager = (-t STDOUT) ? !$_[1] : 0;
 798         return unless $want_pager;
 799         my $pghnd = setup_pager('become child');
 800         defined($pghnd) or return;
 801         if (open(STDOUT, '>&=', $pghnd)) {
 802                 $ENV{GIT_PAGER_IN_USE} = 1;
 803                 $ENV{TG_PAGER_IN_USE} = 1;
 804         } else {
 805                 die "failed to set STDOUT to pager: $!\n";
 806         }
 807 }
 808
 809 1;