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