toolbox/projtool.pl

   1 #!/usr/bin/perl
   2
   3 # projtool.pl - command line Girocco project maintenance tool
   4 # Copyright (C) 2016,2017,2020 Kyle J. McKay.  All rights reserved.
   5 # License GPLv2+: GNU GPL version 2 or later.
   6 # www.gnu.org/licenses/gpl-2.0.html
   7 # This is free software: you are free to change and redistribute it.
   8 # There is NO WARRANTY, to the extent permitted by law.
   9
  10 use strict;
  11 use warnings;
  12 use vars qw($VERSION);
  13 BEGIN {*VERSION = \'1.0.3'}
  14 use File::Basename;
  15 use Digest::MD5 qw(md5_hex);
  16 use IO::Socket;
  17 use Cwd qw(realpath);
  18 use POSIX qw(strftime);
  19 use lib "__BASEDIR__";
  20 use Girocco::Config;
  21 use Girocco::Util;
  22 use Girocco::HashUtil;
  23 use Girocco::CLIUtil;
  24 use Girocco::Project;
  25 use Girocco::User;
  26
  27 exit(&main(@ARGV)||0);
  28
  29 our $help;
  30 BEGIN {my @a; /^(.*)$/s && push(@a, $1) foreach @ARGV; @ARGV=@a;}
  31 BEGIN {$help = <<'HELP'}
  32 Usage: %s [<global option>...] <command> <options>
  33
  34        global options:
  35                   -q | --quiet    suppress warning messages
  36                   -p | --pager    force output to be paginated
  37                   --no-pager      never paginate output
  38
  39        help [<command>]
  40               show full help or just for <command> if given
  41
  42        list [--verbose] [--sort=lcname|name|owner|gid|no] [--owner] [<regexp>]
  43               list all projects (default is --sort=lcname)
  44               limit to project names matching <regex> if given
  45               match <regex> against owner instead of project name with --owner
  46
  47        create [--force] [--no-alternates] [--orphan] [<option>...] <project>
  48               create new project <project> (prompted)
  49               <option> can be:
  50                   --no-alternates skip setup of objects/info/alternates
  51                   --orphan        allow creation of subproject w/o a parent
  52                   -p              use mkdir -p during --orphan creation
  53                   --no-password   set password crypt to invalid value "unknown"
  54                   --no-owner      leave the gitweb.owner config unset
  55                   --mirror=<url>  create a mirror from <url>
  56                   --full-mirror   mirror all refs
  57                   --push[=<list>] create a push project
  58                   --desc=<string> specify project description w/o prompt
  59                   --homepage=<url> specify project homepage URL w/o prompt
  60                   --defaults      do no interactive prompting at all
  61               Using --no-password skips the prompts for password, using
  62               --no-owner skips the prompt for owner and using --mirror=<url>
  63               or --push[=<list>] skips the prompts for mirror URL and
  64               heads-only and push users.  With --defaults if neither
  65               --mirror=<url> nor --push[=<list>] is given then --push will
  66               be implied.  Using --desc=<string> will force a specific
  67               description (including an empty string) and skip the prompt for
  68               it.  Otherwise a non-empty default description will always be
  69               supplied in lieu of an empty or omitted description.
  70
  71        adopt [--force] [--type=mirror|push] [<option>...] <project> [<users>]
  72               adopt project <project>
  73               type of project is guessed if --type=<type> omitted
  74               <users> is same as <newuserslist> for setusers command
  75               <option> can be:
  76                   --dry-run     do all the checks but don't perform adoption
  77                   --verbose     show project info dump (useful with --dry-run)
  78                   --no-users    no push users at all (<users> must be omitted)
  79                   --no-owner    leave the gitweb.owner config totally unchanged
  80                   --owner=<val> set the gitweb.owner config to <val>
  81               Both --no-owner and --owner=<val> may NOT be given, with neither
  82               take owner from preexisting gitweb.owner else use admin setting.
  83               For mirrors <users> is ignored otherwise if no <users> and no
  84               --no-users option the push users list will consist of the single
  85               user name matching the owner or empty if none or more than one.
  86               With --dry-run <project> can be an absolute path to a git dir.
  87
  88        remove [--force] [--really-delete] [--keep-forks] <project>
  89               remove project <project>
  90               do not move to _recyclebin with --really-delete (just rm -rf)
  91               remove projects with forks (by keeping forks) using --keep-forks
  92
  93        prune [--quiet] (--force | --dry-run) [<project>...]
  94               check to see if any projects (default is all projects) are
  95               missing the associated project directory on disk.
  96               Requires either --force or --dry-run option to operate.
  97               With --dry-run only show what would be done.
  98               With --prune actually remove any extraneous project(s).
  99               With --dry-run exit code is non-zero if any action needed.
 100               With --quiet, suppress output message, if any.
 101
 102        show <project>
 103               show project <project>
 104
 105        listheads <project>
 106               list all available heads for <project> and indicate current head
 107
 108        listtags [--verbose] <project>
 109               list all ctags on project <project>
 110
 111        deltags <project> [-i] <tagstodel>
 112               remove any ctags on project <project> present in <tagstodel>
 113               <tagstodel> is space or comma separated list of tags to remove
 114               with -i match against <tagstodel> without regard to letter case
 115
 116        addtags <project> <tagstoadd>
 117               add ctags to project <project>
 118               <tagstoadd> is space or comma separated list of tags to add
 119
 120        chpass [--force] <project> [random | unknown]
 121               change project <project> password (prompted)
 122               with "random" set to random password
 123               with "unknown" set password hash to invalid value "unknown"
 124
 125        checkpw <project>
 126               check project <project> password for a match (prompted)
 127
 128        gc [--force | --auto] [--redelta | --recompress] <project>
 129               run the gc.sh script on project <project>
 130               with --auto let the gc.sh script decide what to do
 131               with --force cause a full gc to take place (force_gc=1)
 132               with neither --auto nor --force do a mini or if needed a full gc
 133               (in other words just touch .needsgc and run gc.sh)
 134               with --redelta a full gc will use pack-objects --no-reuse-delta
 135               with --recompress a full gc uses pack-objects --no-reuse-object
 136               (--no-reuse-delta and --no-reuse-object are accepted as aliases)
 137               unless the global --quiet option is given show_progress=1 is used
 138
 139        update [--force] [--quiet | --summary] <project>
 140               run the update.sh script on project <project>
 141               with --force cause a fetch to always take place (force_update=1)
 142               with --quiet only show errors (show_progress is left unset)
 143               with --summary show progress and ref summary (show_progress=1)
 144               with neither --quiet nor --summary show it all (show_progress=2)
 145
 146        remirror [--force] <project>
 147               initiate a remirror of project <project>
 148
 149        [set]owner [--force] <project> <newowner>
 150               set project <project> owner to <newowner>
 151               without "set" and only 1 arg, just show current project owner
 152
 153        [set]desc [--force] <project> <newdesc>
 154               set project <project> description to <newdesc>
 155               without "set" and only 1 arg, just show current project desc
 156
 157        [set]readme [--force] [--format=<readmetype>] <project> [<newsetting>]
 158               set project <project> readme to <newsetting>
 159               <readmetype> is markdown|plain|html (default is no change)
 160               <newsetting> is automatic|suppressed|-|[@]filename
 161               with "set" <readmetype> and/or <newsetting> is required
 162               without "set" and only 2 args, just show current readme setting
 163
 164        [set]head <project> <newhead>
 165               set project <project> HEAD symbolic ref to <newhead>
 166               without "set" and only 1 arg, just show current project HEAD
 167
 168        [set]bool [--force] <project> <flagname> <boolvalue>
 169               set project <project> boolean <flagname> to <boolvalue>
 170               <flagname> is cleanmirror|reverseorder|summaryonly|statusupdtaes
 171               without "set" and only 2 args, just show current flag value
 172
 173        [set]hooks [--force] <project> local | global | <path>
 174               set project <project> hookspath to local, global or <path>
 175               without "set" and only 1 arg, just show current hookspath
 176
 177        [set]autogchack <project> <boolvalue> | unset
 178               set project <project> autogchack to <boolvalue> or "unset" it
 179               without "set" just show current autogchack setting if enabled
 180               with "set" autogchack must be enabled in Config.pm for the
 181               type of project and maintain-auto-gc-hack.sh is always run
 182
 183        [set]url [--force] <project> <urlname> <newurlvalue>
 184               set project <project> url <urlname> to <newurlvalue>
 185               <urlname> is baseurl|homepage|notifyjson
 186               without "set" and only 2 args, just show current url value
 187
 188        [set]msgs [--force] <project> <msgsname> <eaddrlist>
 189               set project <project> msgs <msgsname> to <addrlist>
 190               <msgsname> is notifymail|notifytag
 191               <eaddrlist> is space or comma separated list of email addresses
 192               without "set" and only 2 args, just show current msgs value
 193
 194        [set]users [--force] <project> <newuserslist>
 195               set push project <project> users list to <newuserslist>
 196               <newuserslist> is space or comma separated list of user names
 197               without "set" and only 1 arg, just show current users list
 198
 199        [set]jsontype <project> <newjsontype>
 200               set project <project> JSON Content-Type to <newjsontype>
 201               <newjsontype> is x-www-form-urlencoded or json
 202               without "set" and only 1 arg, just show current jsontype
 203
 204        [set]jsonsecret <project> <newjsonsecret>
 205               set project <project> JSON secret to <newjsonsecret>
 206               <newjsonsecret> is a string (empty string disables signatures)
 207               without "set" and only 1 arg, just show current jsonsecret
 208
 209        get <project> <fieldname>
 210               show project <project> field <fieldname>
 211               <fieldname> is owner|desc|readme|head|hooks|users|jsontype
 212                       or jsonsecret|<flagname>|autogchack|<urlname>|<msgsname>
 213
 214        set [--force] <project> <fieldname> <newfieldvalue>
 215               set project <project> field <fieldname> to <newfieldvalue>
 216               <fieldname> same as for get
 217               <newfieldvalue> same as for corresponding set... command
 218 HELP
 219
 220 our $quiet;
 221 our $usepager;
 222 our $setopt;
 223 sub die_usage {
 224         my $sub = shift || diename;
 225         if ($sub) {
 226                 die "Invalid arguments to $sub command -- try \"help\"\n";
 227         } else {
 228                 die "Invalid arguments -- try \"help\"\n";
 229         }
 230 }
 231
 232 sub get_readme_len {
 233         my $rm = shift;
 234         defined($rm) or $rm = '';
 235         return "length " . length($rm);
 236 }
 237
 238 sub get_readme_desc {
 239         my $rm = shift;
 240         defined($rm) or $rm = '';
 241         if (length($rm)) {
 242                 my $test = $rm;
 243                 $test =~ s/<!--(?:[^-]|(?:-(?!-)))*-->//gs;
 244                 $test =~ s/\s+//s;
 245                 return $test eq '' ? "suppressed" : "length " . length($rm);
 246         } else {
 247                 return "automatic";
 248         }
 249 }
 250
 251 sub get_ctag_counts {
 252         my $project = shift;
 253         my $compact = shift;
 254         my @ctags = ();
 255         foreach ($project->get_ctag_names) {
 256                 my $val = 0;
 257                 my $ct;
 258                 if (open $ct, '<', $project->{path}."/ctags/$_") {
 259                         my $count = <$ct>;
 260                         close $ct;
 261                         defined $count or $count = '';
 262                         chomp $count;
 263                         $val = $count =~ /^[1-9]\d*$/ ? $count : 1;
 264                 }
 265                 if ($compact) {
 266                         if ($val == 1) {
 267                                 push(@ctags, $_);
 268                         } elsif ($val > 1) {
 269                                 push(@ctags, $_."(".$val.")");
 270                         }
 271                 } else {
 272                         push(@ctags, [$_, $val]) if $val;
 273                 }
 274         }
 275         @ctags;
 276 }
 277
 278 sub get_clean_project {
 279         my $project = get_project(@_);
 280         delete $project->{loaded};
 281         delete $project->{base_path};
 282         delete $project->{ccrypt};
 283         /^orig/i || !defined($project->{$_}) and delete $project->{$_} foreach keys %$project;
 284         $project->{owner} = $project->{email}; delete $project->{email};
 285         $project->{homepage} = $project->{hp}; delete $project->{hp};
 286         $project->{baseurl} = $project->{url}; delete $project->{url};
 287         if (defined($project->{path}) && $project->{path} ne "") {
 288                 my $rp = realpath($project->{path});
 289                 defined($rp) && $rp ne "" and $project->{realpath} = $rp;
 290                 if (-f "$rp/objects/info/packs") {
 291                         my $ipt = (stat _)[9];
 292                         defined($ipt) and $project->{infopackstime} =
 293                                 strftime("%Y-%m-%d %H:%M:%S %z", localtime($ipt));
 294                 }
 295         }
 296         my $owner = $project->{owner};
 297         if ($owner) {
 298                 $owner = lc($owner);
 299                 my @owner_users = map {$owner eq lc($$_[4]) ? $$_[1] : ()} get_all_users;
 300                 $project->{owner_users} = \@owner_users if @owner_users;
 301         }
 302         my $projname = $project->{name};
 303         my @forks = grep {$$_[1] =~ m,^$projname/,} get_all_projects;
 304         $project->{has_forks} = 1 if @forks;
 305         $project->{has_alternates} = 1 if $project->has_alternates;
 306         my @bundles = $project->bundles;
 307         for (my $i = 0; $i < @bundles; ++$i) {
 308                 my $secs = $bundles[$i]->[0];
 309                 $bundles[$i]->[0] = strftime("%Y-%m-%d %H:%M:%S %z", localtime($secs));
 310                 my $sz = $bundles[$i]->[2];
 311                 1 while $sz =~ s/(?<=\d)(\d{3})(?:,|$)/,$1/g;
 312                 $bundles[$i]->[2] = $sz;
 313         }
 314         delete $project->{bundles};
 315         $project->{bundles} = \@bundles if @bundles;
 316         $project->{mirror} = 0 unless $project->{mirror};
 317         $project->{is_empty} = 1 if $project->is_empty;
 318         delete $project->{showpush} unless $project->{showpush};
 319         delete $project->{users} if $project->{mirror};
 320         delete $project->{baseurl} unless $project->{mirror};
 321         delete $project->{banged} unless $project->{mirror};
 322         delete $project->{lastrefresh} unless $project->{mirror};
 323         delete $project->{cleanmirror} unless $project->{mirror};
 324         delete $project->{statusupdates} unless $project->{mirror};
 325         delete $project->{lastparentgc} unless $projname =~ m,/,;
 326         unless ($project->{banged}) {
 327                 delete $project->{bangcount};
 328                 delete $project->{bangfirstfail};
 329                 delete $project->{bangmessagesent};
 330         }
 331         my $projhook = $project->_has_notifyhook;
 332         if (defined($projhook) && $projhook ne "") {
 333                 $project->{notifyhook} = $projhook;
 334         } else {
 335                 delete $project->{notifyhook};
 336         }
 337         $project->{README} = get_readme_desc($project->{README}) if exists($project->{README});
 338         $project->{READMEDATA} = get_readme_len($project->{READMEDATA}) if exists($project->{READMEDATA});
 339         my @tags = get_ctag_counts($project, 1);
 340         $project->{tags} = \@tags if @tags;
 341         my $projconfig = read_config_file_hash($project->{path}."/config");
 342         if (defined($projconfig) && defined($projconfig->{"core.hookspath"})) {
 343                 my $ahp = $projconfig->{"core.hookspath"};
 344                 my $rahp = realpath($ahp);
 345                 my $lhp = $project->{path}."/hooks";
 346                 my $rlhp = realpath($lhp);
 347                 my $ghp = $Girocco::Config::reporoot."/_global/hooks";
 348                 my $rghp = realpath($ghp);
 349                 $project->{has_local_hooks} = 1 if
 350                         defined($rahp) && defined($rlhp) && $rahp eq $rlhp;
 351                 $project->{has_global_hooks} = 1 if
 352                         defined($rahp) && defined($rghp) && $rahp eq $rghp;
 353                 $project->{hookspath} = $ahp unless $ahp eq $lhp || $ahp eq $ghp;
 354         }
 355         $project;
 356 }
 357
 358 sub clean_addrlist {
 359         my %seen = ();
 360         my @newlist = ();
 361         foreach (split(/[,\s]+/, $_[0])) {
 362                 next unless $_;
 363                 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
 364         }
 365         return join(($_[1]||","), @newlist);
 366 }
 367
 368 sub valid_addrlist {
 369         my $cleaned = clean_addrlist(join(" ", @_));
 370         return 1 if $cleaned eq "";
 371         valid_email_multi($cleaned) && length($cleaned) <= 512;
 372 }
 373
 374 sub validate_users {
 375         my ($userlist, $force, $nodie) = @_;
 376         my @newusers = ();
 377         my $badlist = 0;
 378         my %seenuser = ();
 379         my $mobok = $Girocco::Config::mob && $Girocco::Config::mob eq "mob";
 380         my %users = map({($$_[1] => $_)} get_all_users);
 381         foreach (split(/[\s,]+/, $userlist)) {
 382                 if (exists($users{$_}) || $_ eq "everyone" || ($mobok && $_ eq "mob")) {
 383                         $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
 384                         next;
 385                 }
 386                 if (Girocco::User::does_exist($_, 1)) {
 387                         if ($force) {
 388                                 $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
 389                         } else {
 390                                 $badlist = 1;
 391                                 warn "refusing to allow questionable user \"$_\" without --force\n" unless $nodie && $quiet;
 392                         }
 393                         next;
 394                 }
 395                 $badlist = 1;
 396                 warn "invalid user: \"$_\"\n" unless $nodie && $quiet
 397         }
 398         die if $badlist && !$nodie;
 399         return @newusers;
 400 }
 401
 402 sub is_default_desc {
 403         # "Unnamed repository; edit this file 'description' to name the repository."
 404         # "Unnamed repository; edit this file to name it for gitweb."
 405         local $_ = shift;
 406         return 0 unless defined($_);
 407         /Unnamed\s+repository;/i && /\s+edit\s+this\s+file\s+/i && /\s+to\s+name\s+/i;
 408 }
 409
 410 sub valid_desc {
 411         my $test = shift;
 412         chomp $test;
 413         return 0 if $test =~ /[\r\n]/;
 414         $test =~ s/\s\s+/ /g;
 415         $test =~ s/^\s+//;
 416         $test =~ s/\s+$//;
 417         return $test ne '';
 418 }
 419
 420 sub clean_desc {
 421         my $desc = shift;
 422         defined($desc) or $desc = '';
 423         chomp $desc;
 424         $desc = to_utf8($desc, 1);
 425         $desc =~ s/\s\s+/ /g;
 426         $desc =~ s/^\s+//;
 427         $desc =~ s/\s+$//;
 428         return $desc;
 429 }
 430
 431 sub parse_options {
 432         Girocco::CLIUtil::_parse_options(
 433                 sub {
 434                         warn((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")
 435                                 unless $quiet;
 436                         die_usage;
 437                 }, @_);
 438 }
 439
 440 sub cmd_list {
 441         my %sortsub = (
 442                 lcname => sub {lc($$a[1]) cmp lc($$b[1])},
 443                 name => sub {$$a[1] cmp $$b[1]},
 444                 gid => sub {$$a[3] <=> $$b[3]},
 445                 owner => sub {lc($$a[4]) cmp lc($$b[4]) || lc($$a[1]) cmp lc($$b[1])},
 446                 no => sub {$$a[0] <=> $$b[0]},
 447         );
 448         my $sortopt = 'lcname';
 449         my ($verbose, $owner);
 450         parse_options(":sort" => \$sortopt, verbose => \$verbose, owner => \$owner);
 451         my $regex;
 452         if (@ARGV) {
 453                 my $val = shift @ARGV;
 454                 $regex = qr($val) or die "bad regex \"$val\"\n";
 455         }
 456         !@ARGV && exists($sortsub{$sortopt}) or die_usage;
 457         my $sortsub = $sortsub{$sortopt};
 458         my $grepsub = defined($regex) ? ($owner ? sub {$$_[4] =~ /$regex/} : sub {$$_[1] =~ /$regex/}) : sub {1};
 459         my @projects = sort($sortsub grep {&$grepsub} get_all_projects);
 460         if ($verbose) {
 461                 print map(sprintf("%s\n", join(":", (@$_)[1..5])), @projects);
 462         } else {
 463                 print map(sprintf("%s: %s\n", $$_[1], $$_[5] =~ /^:/ ? "<mirror>" : $$_[5]), @projects);
 464         }
 465         return 0;
 466 }
 467
 468 sub cmd_create {
 469         my ($force, $noalternates, $orphanok, $optp, $nopasswd, $noowner, $defaults, $ispush, $pushusers,
 470                 $ismirror, $desc, $fullmirror, $homepage);
 471         parse_options(
 472                 force => \$force, "no-alternates" => \$noalternates, orphan => \$orphanok, p => \$optp,
 473                 "no-password" => \$nopasswd, "no-owner" => \$noowner, defaults => \$defaults,
 474                 "push" => \$ispush, ":push" => \$pushusers, ":mirror" => \$ismirror, ":desc" => \$desc,
 475                 ":description" => \$desc, "full-mirror" => \$fullmirror, ":homepage" => \$homepage);
 476         @ARGV == 1 or die_usage;
 477         !defined($pushusers) || defined($ispush) or $ispush = 1;
 478         defined($ismirror) && $ismirror =~ /^\s*$/ and die "--mirror url must not be empty\n";
 479         die "--mirror and --push are mutually exclusive options\n" if $ismirror && $ispush;
 480         die "--full-mirror requires use of --mirror=<url> option\n" if $fullmirror && !$ismirror;
 481         !$defaults || defined($ispush) || defined($ismirror) or $ispush = 1;
 482         !$defaults || defined($nopasswd) or $nopasswd = 1;
 483         !$defaults || defined($noowner) or $noowner = 1;
 484         !defined($ispush) || defined($pushusers) or $pushusers = "";
 485         my $projname = $ARGV[0];
 486         $projname =~ s/\.git$//i;
 487         Girocco::Project::does_exist($projname, 1) and die "Project already exists: \"$projname\"\n";
 488         if (!Girocco::Project::valid_name($projname, $orphanok, $optp)) {
 489                 warn "Refusing to create orphan project without --orphan\n"
 490                         if !$quiet && !$orphanok && Girocco::Project::valid_name($projname, 1, 1);
 491                 warn "Required orphan parent directory does not exist (use -p): ",
 492                         $Girocco::Config::reporoot.'/'.Girocco::Project::get_forkee_name($projname), "\n"
 493                         if !$quiet && $orphanok && Girocco::Project::valid_name($projname, 1, 1);
 494                 die "Invalid project name: \"$projname\"\n";
 495         }
 496         my ($forkee, $project) = ($projname =~ m#^(.*/)?([^/]+)$#);
 497         my $newtype = $forkee ? 'fork' : 'project';
 498         if (length($project) > 64) {
 499                 die "The $newtype name is longer than 64 characters.  Do you really need that much?\n"
 500                         unless $force;
 501                 warn "Allowing $newtype name longer than 64 characters with --force\n" unless $quiet;
 502         }
 503         unless ($Girocco::Config::push || $Girocco::Config::mirror) {
 504                 die "Project creation disabled (no mirrors or push projects allowed)\n" unless $force;
 505                 warn "Continuing with --force even though both push and mirror projects are disabled\n" unless $quiet;
 506         }
 507         print "Enter settings for new project \"$projname\"\n" unless $defaults;
 508         my %settings = ();
 509         $settings{noalternates} = $noalternates;
 510         if ($nopasswd) {
 511                 $settings{crypt} = "unknown";
 512         } else {
 513                 my $np1 = prompt_noecho_nl_or_die("Admin password for project $projname (echo is off)");
 514                 $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
 515                 my $np2 = prompt_noecho_nl_or_die("Retype admin password for project $projname");
 516                 $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
 517                         "the admin passwords you have entered do not match each other.\n";
 518                 $settings{crypt} = scrypt_sha1($np1);
 519         }
 520         my $owner = "";
 521         unless ($noowner) {
 522                 $owner = prompt_or_die("Owner/email name for project $projname");
 523                 unless (valid_email($owner)) {
 524                         unless ($force) {
 525                                 warn "Your email sure looks weird...?\n";
 526                                 redo;
 527                         }
 528                         warn "Allowing invalid email with --force\n" unless $quiet;
 529                 }
 530                 if (length($owner) > 96) {
 531                         unless ($force) {
 532                                 warn "Your email is longer than 96 characters.  Do you really need that much?\n";
 533                                 redo;
 534                         }
 535                         warn "Allowing email longer than 96 characters with --force\n" unless $quiet;
 536                 }
 537         }
 538         $settings{email} = $owner;
 539         my $baseurl = "";
 540         my $checkmirror = sub {
 541                 my $checkurl = shift;
 542                 unless (valid_repo_url($checkurl)) {
 543                         unless ($force) {
 544                                 warn "Invalid mirror URL: \"$checkurl\"\n";
 545                                 return undef;
 546                         }
 547                         warn "Allowing invalid mirror URL with --force\n" unless $quiet;
 548                 }
 549                 if ($Girocco::Config::restrict_mirror_hosts) {
 550                         my $mh = extract_url_hostname($checkurl);
 551                         unless (is_dns_hostname($mh)) {
 552                                 unless ($force) {
 553                                         warn "Invalid non-DNS mirror URL: \"$checkurl\"\n";
 554                                         return undef;
 555                                 }
 556                                 warn "Allowing non-DNS mirror URL with --force\n" unless $quiet;
 557                         }
 558                         if (is_our_hostname($mh)) {
 559                                 unless ($force) {
 560                                         warn "Invalid same-host mirror URL: \"$checkurl\"\n";
 561                                         return undef;
 562                                 }
 563                                 warn "Allowing same-host mirror URL with --force\n" unless $quiet;
 564                         }
 565                 }
 566                 return $checkurl;
 567         };
 568         if ($ispush || $ismirror) {
 569                 !$ispush || $force || $Girocco::Config::push or
 570                         die "Push projects are disabled, create a mirror (or use --force)\n";
 571                 !$ismirror || $force || $Girocco::Config::mirror or
 572                         die "Mirror projects are disabled, create a push project (or use --force)\n";
 573                 if ($ismirror) {
 574                         &$checkmirror($ismirror) or die "Invalid --mirror URL\n";
 575                         $baseurl = $ismirror;
 576                         $settings{url} = $baseurl;
 577                         $settings{cleanmirror} = $fullmirror ? 0 : 1;
 578                 } else {
 579                         my @newusers = ();
 580                         if ($pushusers !~ /^[\s,]*$/) {
 581                                 eval {@newusers = validate_users($pushusers, $force); 1;} or
 582                                         die "Invalid --push user list\n";
 583                         }
 584                         $settings{users} = \@newusers;
 585                 }
 586         } elsif ($force || $Girocco::Config::mirror) {{
 587                 if ($force || $Girocco::Config::push) {
 588                         $baseurl = prompt_or_die("URL to mirror from (leave blank for push project)", "");
 589                 } else {{
 590                         $baseurl = prompt_or_die("URL to mirror from");
 591                         unless ($baseurl ne "") {
 592                                 warn "Push projects are disabled, you must enter a mirror URL (or use --force)\n";
 593                                 redo;
 594                         }
 595                 }}
 596                 if ($baseurl ne "") {
 597                         &$checkmirror($baseurl) or redo;
 598                         $settings{url} = $baseurl;
 599                         $settings{cleanmirror} =
 600                                 ynprompt_or_die("Mirror only heads, tags and notes (Y/n)", "Yes");
 601                 }
 602         }}
 603         my $mirror = ($baseurl eq "") ? 0 : 1;
 604         my $checkdesc = sub {
 605                 my $d = shift;
 606                 if (length($d) > 1024) {
 607                         unless ($force) {
 608                                 warn "Short description length greater than 1024 characters!\n";
 609                                 return undef;
 610                         }
 611                         warn "Allowing short description length greater than 1024 characters\n" unless $quiet;
 612                 }
 613                 return $d;
 614         };
 615         if (defined($desc)) {
 616                 $desc =~ s/^\s+//; $desc =~ s/\s+$//;
 617                 $desc eq "" || &$checkdesc($desc) or
 618                         die "Invalid --desc description\n";
 619         } elsif (!$defaults) {
 620                 $desc = prompt_or_die("Short description", "");
 621                 $desc =~ s/^\s+//; $desc =~ s/\s+$//;
 622                 $desc eq "" || &$checkdesc($desc) or redo;
 623                 $desc = undef if $desc eq "";
 624         }
 625         defined($desc) or $desc = $mirror ? "Mirror of $baseurl" : "Push project $projname";
 626         $settings{desc} = $desc;
 627         my $checkhp = sub {
 628                 my $hpurl = shift;
 629                 unless (valid_web_url($hpurl)) {
 630                         unless ($force) {
 631                                 warn "Invalid home page URL: \"$hpurl\"\n";
 632                                 return undef;
 633                         }
 634                         warn "Allowing invalid home page URL with --force\n" unless $quiet;
 635                 }
 636                 return $hpurl;
 637         };
 638         if (defined($homepage)) {
 639                 $homepage =~ s/^\s+//; $homepage =~ s/\s+$//;
 640                 $homepage eq "" || &$checkhp($homepage) or
 641                         die "Invalid --homepage URL\n";
 642         } elsif (!$defaults) {
 643                 $homepage = prompt_or_die("Home page URL", "");
 644                 $homepage =~ s/^\s+//; $homepage =~ s/\s+$//;
 645                 $homepage eq "" || &$checkhp($homepage) or redo;
 646                 $homepage = undef if $homepage eq "";
 647         }
 648         $settings{hp} = $homepage;
 649         my $jsonurl = "";
 650         if (!$defaults) {
 651                 $jsonurl = prompt_or_die("JSON notify POST URL", "");
 652                 if ($jsonurl ne "" && !valid_web_url($jsonurl)) {
 653                         unless ($force) {
 654                                 warn "Invalid JSON notify POST URL: \$jsonurl\"\n";
 655                                 redo;
 656                         }
 657                         warn "Allowing invalid JSON notify POST URL with --force\n" unless $quiet;
 658                 }
 659         }
 660         $settings{notifyjson} = $jsonurl;
 661         my $commitaddrs = "";
 662         if (!$defaults) {
 663                 $commitaddrs = clean_addrlist(prompt_or_die("Commit notify email addr(s)", ""));
 664                 if ($commitaddrs ne "" && !valid_addrlist($commitaddrs)) {
 665                         unless ($force) {
 666                                 warn"invalid commit notify email address list (use --force to accept): \"$commitaddrs\"\n";
 667                                 redo;
 668                         }
 669                         warn "using invalid commit notify email address list with --force\n" unless $quiet;
 670                 }
 671         }
 672         $settings{notifymail} = $commitaddrs;
 673         $settings{reverseorder} = 1;
 674         $settings{reverseorder} = ynprompt_or_die("Oldest-to-newest commit order in emails", "Yes")
 675                 if !$defaults && $commitaddrs ne "";
 676         $settings{summaryonly} = ynprompt_or_die("Summary only (no diff) in emails", "No")
 677                 if !$defaults && $commitaddrs ne "";
 678         my $tagaddrs = "";
 679         if (!$defaults) {
 680                 $tagaddrs = clean_addrlist(prompt_or_die("Tag notify email addr(s)", ""));
 681                 if ($tagaddrs ne "" && !valid_addrlist($tagaddrs)) {
 682                         unless ($force) {
 683                                 warn"invalid tag notify email address list (use --force to accept): \"$tagaddrs\"\n";
 684                                 redo;
 685                         }
 686                         warn "using invalid tag notify email address list with --force\n" unless $quiet;
 687                 }
 688         }
 689         $settings{notifytag} = $tagaddrs;
 690         if (!$mirror && !$ispush) {
 691                 my @newusers = ();
 692                 {
 693                         my $userlist = prompt_or_die("Push users", join(",", @newusers));
 694                         eval {@newusers = validate_users($userlist, $force); 1;} or redo;
 695                 }
 696                 $settings{users} = \@newusers;
 697         }
 698         my $newproj = Girocco::Project->ghost($projname, $mirror, $orphanok, $optp)
 699                 or die "Girocco::Project->ghost call failed\n";
 700         my ($k, $v);
 701         $newproj->{$k} = $v while ($k, $v) = each(%settings);
 702         my $killowner = sub {
 703                 system($Girocco::Config::git_bin, '--git-dir='.$newproj->{path},
 704                         'config', '--unset', "gitweb.owner");
 705         };
 706         if ($mirror) {
 707                 $newproj->premirror or die "Girocco::Project->premirror failed\n";
 708                 !$noowner or &$killowner;
 709                 $newproj->clone or die "Girocco::Project->clone failed\n";
 710                 warn "Project $projname created and cloning successfully initiated.\n"
 711                         unless $quiet;
 712         } else {
 713                 $newproj->conjure or die "Girocco::Project->conjure failed\n";
 714                 !$noowner or &$killowner;
 715                 warn "New push project fork is empty due to use of --no-alternates\n"
 716                         if !$quiet && $projname =~ m,/, && $noalternates;
 717                 warn "Project $projname successfully created.\n" unless $quiet;
 718         }
 719         return 0;
 720 }
 721
 722 sub git_config {
 723         my $gd = shift;
 724         system($Girocco::Config::git_bin, "--git-dir=$gd", 'config', @_) == 0
 725                 or die "\"git --git-dir='$gd' config ".join(" ", @_)."\" failed.\n";
 726 }
 727
 728 sub cmd_adopt {
 729         my ($force, $type, $nousers, $dryrun, $noowner, $owner, $users, $verbose);
 730         parse_options(force => \$force, ":type" => \$type, "no-users" => \$nousers, "dry-run" => \$dryrun,
 731                 "no-owner" => \$noowner,":owner" => \$owner, quiet => \$quiet, q =>\$quiet, verbose => \$verbose);
 732         @ARGV or die "Please give project name on command line.\n";
 733         my $projname = shift @ARGV;
 734         (!$noowner || !defined($owner)) && (!$nousers || !@ARGV) or die_usage;
 735         !defined($type) || $type eq "mirror" || $type eq "push" or die_usage;
 736         defined($type) or $type = "";
 737         my $projdir;
 738         if ($dryrun && $projname =~ m,^/[^.\s/\\:], && is_git_dir(realpath($projname))) {
 739                 $projdir = realpath($projname);
 740                 $projname = $projdir;
 741                 $projname =~ s/\.git$//i;
 742                 $projname =~ s,/+$,,;
 743                 $projname =~ s,^.*/,,;
 744                 $projname ne "" or $projname = $projdir;
 745         } else {
 746                 $projname =~ s/\.git$//i;
 747                 $projname ne "" or die "Invalid project name \"\".\n";
 748                 unless (Girocco::Project::does_exist($projname, 1)) {
 749                         Girocco::Project::valid_name($projname, 1, 1)
 750                                 or die "Invalid project name \"$projname\".\n";
 751                         die "No such project to adopt: $projname\n";
 752                 }
 753                 defined(Girocco::Project->load($projname))
 754                         and die "Project already known (no need to adopt): $projname\n";
 755                 $projdir = $Girocco::Config::reporoot . "/" . $projname . ".git";
 756                 is_git_dir($projdir) or die "Not a git directory: \"$projdir\"\n";
 757         }
 758         my $config = read_config_file($projdir . "/config");
 759         my %config = ();
 760         %config = map {($$_[0], defined($$_[1])?$$_[1]:"true")} @$config if defined($config);
 761         git_bool($config{"core.bare"}) or die "Not a bare git repository: \"$projdir\"\n";
 762         defined(read_HEAD_symref($projdir)) or die "Project with non-symbolic HEAD ref: \"$projdir\"\n";
 763         @ARGV and $users = [validate_users(join(" ", @ARGV), $force, 1)];
 764         my $desc = "";
 765         if (-e "$projdir/description") {
 766                 open my $fd, '<', "$projdir/description" or die "Cannot open \"$projdir/description\": $!\n";
 767                 {
 768                         local $/;
 769                         $desc = <$fd>;
 770                 }
 771                 close $fd;
 772                 defined $desc or $desc = "";
 773                 chomp $desc;
 774                 $desc = to_utf8($desc, 1);
 775                 is_default_desc($desc) and $desc = "";
 776                 if ($desc ne "" && !valid_desc($desc)) {
 777                         die "invalid 'description' file contents (use --force to accept): \"$desc\"\n"
 778                                 unless $force;
 779                         warn "using invalid 'description' file contents  with --force\n" unless $quiet;
 780                 }
 781                 $desc = clean_desc($desc);
 782                 if (length($desc) > 1024) {
 783                         die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
 784                                 unless $force;
 785                         warn "using longer than 1024 char description with --force\n" unless $quiet;
 786                 }
 787         }
 788         my $readme = "";
 789         my $origreadme = "";
 790         my $readmedata = "";
 791         my $origreadmedata = "";
 792         my $readmetype = Girocco::Project::_normalize_rmtype($config{"girocco.readmetype"},1);
 793         if (-e "$projdir/README.html") {
 794                 open my $fd, '<', "$projdir/README.html" or die "Cannot open \"$projdir/README.html\": $!\n";
 795                 {
 796                         local $/;
 797                         $readme = <$fd>;
 798                 }
 799                 close $fd;
 800                 defined $readme or $readme = "";
 801                 $readme = to_utf8($readme, 1);
 802                 $readme =~ s/\r\n?/\n/gs;
 803                 $readme =~ s/^\s+//s;
 804                 $readme =~ s/\s+$//s;
 805                 $readme eq "" or $readme .= "\n";
 806                 $origreadme = $readme;
 807                 if (-e "$projdir/README.dat") {
 808                         open my $fd2, '<', "$projdir/README.dat" or die "Cannot open \"$projdir/README.dat\": $!\n";
 809                         {
 810                                 local $/;
 811                                 $readmedata = <$fd2>;
 812                         }
 813                         close $fd2;
 814                         defined $readmedata or $readmedata = "";
 815                         $readmedata = to_utf8($readmedata, 1);
 816                         $readmedata =~ s/\r\n?/\n/gs;
 817                         $readmedata =~ s/^\s+//s;
 818                         $readmedata =~ s/\s+$//s;
 819                         $readmedata eq "" or $readmedata .= "\n";
 820                         $origreadmedata = $readmedata;
 821                 }
 822                 !$readmetype && length($readme) && !length($readmedata) and do {
 823                         # the old HTML format
 824                         $readmetype = 'HTML';
 825                         $readmedata = $readme;
 826                 };
 827                 if (length($readmedata) > 8192) {
 828                         die "readme greater than 8192 chars is too long (use --force to override)\n"
 829                                 unless $force;
 830                         warn "using readme greater than 8192 chars with --force\n" unless $quiet;
 831                 }
 832                 {
 833                         my $dummy = {READMEDATA => $readmedata, rmtype => $readmetype, name => $projname};
 834                         my ($cnt, $err) = Girocco::Project::_lint_readme($dummy, 0);
 835                         if ($cnt) {
 836                                 my $msg = "README: $cnt error";
 837                                 $msg .= "s" unless $cnt == 1;
 838                                 print STDERR "$msg\n", "-" x length($msg), "\n", $err
 839                                         unless $force && $quiet;
 840                                 exit(255) unless $force && $readmetype eq 'HTML';
 841                                 warn "$projname: using invalid raw HTML with --force\n" unless $quiet;
 842                         } else {
 843                                 $readme = $dummy->{README};
 844                         }
 845                 }
 846         }
 847         $readmetype or $readmetype = Girocco::Project::_normalize_rmtype(""); # use default type
 848         # Inspect any remotes now
 849         # Yes, Virginia, remote urls can be multi-valued
 850         my %remotes = ();
 851         foreach (@$config) {
 852                 my ($k,$v) = @$_;
 853                 next unless $k =~ /^remote\.([^\/].*?)\.([^.]+)$/; # remote name cannot start with "/"
 854                 my ($name, $subkey) = ($1, $2);
 855                 $remotes{$name}->{skip} = git_bool($v,1), next if $subkey eq "skipdefaultupdate" || $subkey eq "skipfetchall";
 856                 $remotes{$name}->{mirror} = git_bool($v,1), next if $subkey eq "mirror"; # we might want this
 857                 $remotes{$name}->{vcs} = $v, next if defined($v) && $v !~ /^\s*$/ && $subkey eq "vcs";
 858                 push(@{$remotes{$name}->{$subkey}}, $v), next if defined($v) && $v !~ /^\s*$/ &&
 859                         ($subkey eq "url" || $subkey eq "fetch" || $subkey eq "push" || $subkey eq "pushurl");
 860         }
 861         # remotes.default is the default remote group to fetch for "git remote update" otherwise --all
 862         # the remote names in a group are separated by runs of [ \t\n] characters
 863         # remote names "", ".", ".." and any name starting with "/" are invalid
 864         # a remote with no url or vcs setting is not considered valid
 865         my @check = ();
 866         my $usingall = 0;
 867         if (exists($config{"remotes.default"})) {
 868                 foreach (split(/[ \t\n]+/, $config{"remotes.default"})) {
 869                         next unless exists($remotes{$_});
 870                         my $rmt = $remotes{$_};
 871                         next if !exists($rmt->{url}) && !$rmt->{vcs};
 872                         push(@check, $_);
 873                 }
 874         } else {
 875                 $usingall = 1;
 876                 my %seenrmt = ();
 877                 foreach (@$config) {
 878                         my ($k,$v) = @$_;
 879                         next unless $k =~ /^remote\.([^\/].*?)\.[^.]+$/;
 880                         next if $seenrmt{$1};
 881                         $seenrmt{$1} = 1;
 882                         next unless exists($remotes{$1});
 883                         my $rmt = $remotes{$1};
 884                         next if $rmt->{skip} || (!exists($rmt->{url}) && !$rmt->{vcs});
 885                         push(@check, $1);
 886                 }
 887         }
 888         my @needskip = (); # remotes that need skipDefaultUpdate set to true
 889         my $foundvcs = 0;
 890         my $foundfetch = 0;
 891         my $foundfetchwithmirror = 0;
 892         foreach (@check) {
 893                 my $rmt = $remotes{$_};
 894                 push(@needskip, $_) if $usingall && !exists($rmt->{fetch});
 895                 next unless exists($rmt->{fetch});
 896                 ++$foundfetch;
 897                 ++$foundfetchwithmirror if $rmt->{mirror};
 898                 ++$foundvcs if $rmt->{vcs} || (exists($rmt->{url}) && $rmt->{url}->[0] =~ /^[a-zA-Z0-9][a-zA-Z0-9+.-]*::/);
 899         }
 900         # if we have $foundvcs then we need to explicitly set fetch.prune to false
 901         # if we have $foundfetch > 1 then we need to explicitly set fetch.prune to false
 902         my $neednoprune = !exists($config{"fetch.prune"}) && ($foundvcs || $foundfetch > 1);
 903         my $baseurl = "";
 904         my $needfakeorigin = 0; # if true we need to set remote.origin.skipDefaultUpdate = true
 905         # if remote "origin" exists we always pick up its first url or use ""
 906         if (exists($remotes{origin})) {
 907                 my $rmt = $remotes{origin};
 908                 $baseurl = exists($rmt->{url}) ? $rmt->{url}->[0] : "";
 909                 $needfakeorigin = !exists($rmt->{url}) && !$rmt->{vcs} && !$rmt->{skip};
 910         } else {
 911                 $needfakeorigin = 1;
 912                 # get the first url of the @check remotes
 913                 foreach (@check) {
 914                         my $rmt = $remotes{$_};
 915                         next unless exists($rmt->{url});
 916                         next unless defined($rmt->{url}->[0]) && $rmt->{url}->[0] ne "";
 917                         $baseurl = $rmt->{url}->[0];
 918                         last;
 919                 }
 920         }
 921         my $makemirror = $type eq "mirror" || ($type eq "" && $foundfetch);
 922
 923         # If we have $foundfetch we want to make a mirror but complain if
 924         # we $foundfetchwithmirror as well unless we have --type=mirror.
 925         # Warn if we have --type=push and $foundfetch and !$foundfetchwithmirror.
 926         # Warn if we need to set fetch.prune=false when making a mirror
 927         # Warn if we need to create remote.origin.skipDefaultUpdate when making a mirror
 928         # Complain if @needskip AND !$usingall (warn with --force but don't set skip)
 929         # Warn if $usingall and any @needskip (and set them) if making a mirror
 930         # Warn if making a mirror and $baseurl eq ""
 931         # Warn if we have --type=mirror and !$foundfetch
 932
 933         if ($makemirror) {
 934                 warn "No base URL to mirror from for adopted \"$projname\"\n" unless $quiet || $baseurl ne "";
 935                 warn "Adopting mirror \"$projname\" without any fetch remotes\n" unless $quiet || $foundfetch;
 936                 if ($foundfetchwithmirror) {
 937                         warn "Refusing to adopt mirror \"$projname\" with active remote.<name>.mirror=true remote(s)\n".
 938                             "(Use --type=mirror to override)\n"
 939                                 unless $type eq "mirror";
 940                         exit(255) unless $type eq "mirror" || $dryrun;
 941                         warn "Adopting mirror \"$projname\" with active remote.<name>.mirror=true remotes\n"
 942                                 unless $quiet || $type ne "mirror";
 943                 }
 944                 warn "Setting explicit fetch.prune=false for adoption of mirror \"$projname\"\n"
 945                         if !$quiet && $neednoprune;
 946                 warn "Setting remote.origin.skipDefaultUpdate=true for adoption of mirror \"$projname\"\n"
 947                         if !$quiet && $needfakeorigin;
 948                 if (!$usingall && @needskip) {
 949                         warn "Refusing to adopt mirror empty fetch remote(s) (override with --force)\n"
 950                                 unless $force;
 951                         exit(255) unless $force || $dryrun;
 952                         warn "Adopting mirror with empty fetch remote(s) with --force\n"
 953                                 unless $quiet || !$force;
 954                 }
 955                 warn "Will set skipDefaultUpdate=true on non-fetch remote(s)\n" if !$quiet && $usingall && @needskip;
 956                 warn "Adopting mirror with base URL \"$baseurl\"\n" unless $quiet || $baseurl eq "";
 957         } else {
 958                 warn "Adopting push \"$projname\" but active non-mirror remotes are present\n"
 959                         if !$quiet && $foundfetch && !$foundfetchwithmirror;
 960         }
 961
 962         if (!$noowner && !defined($owner)) {
 963                 # Select the owner
 964                 $owner = $config{"gitweb.owner"};
 965                 if (!defined($owner) || $owner eq "") {
 966                         $owner = $Girocco::Config::admin;
 967                         warn "Using owner \"$owner\" for adopted project\n" unless $quiet;
 968                 }
 969         }
 970         if (!$nousers && !$makemirror && !defined($users)) {
 971                 # select user list for push project
 972                 my $findowner = $owner;
 973                 defined($findowner) or $findowner = $config{"gitweb.owner"};
 974                 $findowner = lc($findowner) if defined($findowner);
 975                 my @owner_users = ();
 976                 @owner_users = map {$findowner eq lc($$_[4]) ? $$_[1] : ()} get_all_users
 977                         if defined($findowner) && $findowner ne "";
 978                 defined($findowner) or $findowner = "";
 979                 if (@owner_users <= 1) {
 980                         $users = \@owner_users;
 981                         warn "No users found that match owner \"$findowner\"\n" unless @owner_users || $quiet;
 982                 } else {
 983                         $users = [];
 984                         warn "Found ".scalar(@owner_users)." users for owner \"$findowner\" (" .
 985                                 join(" ", @owner_users) . ") not setting any\n" unless $quiet;
 986                 }
 987         }
 988         defined($users) or $users = [];
 989
 990         # Warn if we preserve an existing receive.denyNonFastForwards or receive.denyDeleteCurrent setting
 991         # Complain if core.logallrefupdates or logs subdir exists and contains any files (allow with --force
 992         # and warn about preserving the setting)
 993
 994         warn "Preserving existing receive.denyNonFastForwards=true\n"
 995                 if !$quiet && git_bool($config{"receive.denynonfastforwards"});
 996         warn "Preserving existing receive.denyDeleteCurrent=$config{'receive.denydeletecurrent'}\n"
 997                 if !$quiet && exists($config{"receive.denydeletecurrent"}) &&
 998                     $config{"receive.denydeletecurrent"} ne "warn";
 999
1000         my $reflogfiles = Girocco::Project::_contains_files("$projdir/logs");
1001         my $reflogactive = git_bool($config{"core.logallrefupdates"});
1002         if ($reflogactive || $reflogfiles) {
1003                 warn "Refusing to adopt \"$projname\" with active ref logs without --force\n" if $reflogfiles && !$force;
1004                 warn "Refusing to adopt \"$projname\" with core.logAllRefUpdates=true without --force\n" if $reflogactive && !$force;
1005                 exit(255) unless $force || $dryrun;
1006                 warn "Adopting \"$projname\" with active ref logs with --force\n" unless $quiet || ($reflogfiles && !$force);
1007                 warn "Adopting \"$projname\" with core.logAllRefUpdates=true with --force\n" unless $quiet || ($reflogactive && !$force);
1008         }
1009
1010         return 0 if $dryrun && !$verbose;
1011
1012         my $newproj = eval {Girocco::Project->ghost($projname, $makemirror, 1, $dryrun)};
1013         defined($newproj) or die "Girocco::Project::ghost failed: $@\n";
1014         $newproj->{desc} = $desc;
1015         $newproj->{README} = $readme;
1016         $newproj->{READMEDATA} = $readmedata;
1017         $newproj->{rmtype} = $readmetype;
1018         $newproj->{url} = $baseurl if $makemirror || exists($config{"gitweb.baseurl"});
1019         $newproj->{email} = $owner if defined($owner);
1020         $newproj->{users} = $users;
1021         $newproj->{crypt} = "unknown";
1022         $newproj->{reverseorder} = 1 unless exists($config{"hooks.reverseorder"});
1023         $newproj->{summaryonly} = 1 unless exists($config{"hooks.summaryonly"});
1024         my $dummy = bless {}, "Girocco::Project";
1025         $dummy->{path} = "$projdir";
1026         $dummy->{configfilehash} = \%config;
1027         $dummy->_properties_load;
1028         delete $dummy->{origurl};
1029         foreach my $k (keys(%$dummy)) {
1030                 $newproj->{$k} = $dummy->{$k}
1031                         if exists($dummy->{$k}) && !exists($newproj->{$k});
1032         }
1033
1034         if ($verbose) {
1035                 use Data::Dumper;
1036                 my %info = %$newproj;
1037                 $info{README} = get_readme_desc($info{README}) if exists($info{README});
1038                 my $d = Data::Dumper->new([\%info], ['*'.$newproj->{name}]);
1039                 $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
1040                 print $d->Dump([\%info], ['*'.$newproj->{name}]);
1041         }
1042         return 0 if $dryrun;
1043
1044         # Make any changes as needed for @needskip, $neednoprune and $needfakeorigin
1045         if ($makemirror) {
1046                 git_config($projdir, "fetch.prune", "false") if $neednoprune;
1047                 git_config($projdir, "remote.origin.skipDefaultUpdate", "true") if $needfakeorigin;
1048                 if ($usingall && @needskip) {
1049                         git_config($projdir, "remote.$_.skipDefaultUpdate", "true") foreach @needskip;
1050                 }
1051         }
1052
1053         # Write out any README.dat/README.html changes before the actual Adoption
1054         # Otherwise they will get stepped on.  The Girocco::Project::adopt function
1055         # does not know how to validate README.html during adoption like the above code does.
1056         if ($readmedata ne $origreadmedata) {
1057                 open my $fd, '>', "$projdir/README.dat" or die "Cannot write \"$projdir/README.dat\": $!\n";
1058                 print $fd $readmedata or die "Error writing \"$projdir/README.dat\": $!\n";
1059                 close $fd or die "Error closing \"$projdir/README.dat\": $!\n";
1060         }
1061         if ($readme ne $origreadme || ! -e "$projdir/README.html") {
1062                 open my $fd, '>', "$projdir/README.html" or die "Cannot write \"$projdir/README.html\": $!\n";
1063                 print $fd $readme or die "Error writing \"$projdir/README.html\": $!\n";
1064                 close $fd or die "Error closing \"$projdir/README.html\": $!\n";
1065         }
1066         git_config($projdir, "girocco.rmtype", $readmetype);
1067
1068         # Perform the actual adoption
1069         $newproj->adopt or die "Girocco::Project::adopt failed\n";
1070
1071         # Perhaps restore core.logAllRefUpdates, receive.denyNonFastForwards and receive.denyDeleteCurrent
1072         git_config($projdir, "receive.denyNonFastForwards", "true")
1073                 if git_bool($config{"receive.denynonfastforwards"});
1074         git_config($projdir, "receive.denyDeleteCurrent", $config{"receive.denydeletecurrent"})
1075                 if exists($config{"receive.denydeletecurrent"}) &&
1076                    $config{"receive.denydeletecurrent"} ne "warn";
1077         git_config($projdir, "core.logAllRefUpdates", "true")
1078                 if $reflogactive;
1079
1080         # Success
1081         if ($makemirror) {
1082                 warn "Mirror project \"$projname\" successfully adopted.\n" unless $quiet;
1083         } else {
1084                 warn "Push project \"$projname\" successfully adopted.\n" unless $quiet;
1085         }
1086         return 0;
1087 }
1088
1089 sub cmd_remove {
1090         my ($force, $reallydel, $keepforks);
1091         parse_options(force => \$force, "really-delete" => \$reallydel,
1092                 "keep-forks" => \$keepforks, quiet => \$quiet, q =>\$quiet);
1093         @ARGV or die "Please give project name on command line.\n";
1094         @ARGV == 1 or die_usage;
1095         my $project = get_project($ARGV[0]);
1096         my $projname = $project->{name};
1097         my $isempty = !$project->{mirror} && $project->is_empty;
1098         if (!$project->{mirror} && !$isempty && $reallydel) {
1099                 die "refusing to remove and delete non-empty push project without --force: $projname\n" unless $force;
1100                 warn "allowing removal and deletion of non-empty push project with --force\n" unless $quiet;
1101         }
1102         my $altwarn;
1103         my $removenogc;
1104         if ($project->has_forks) {
1105                 die "refusing to remove project with forks (use --keep-forks): $projname\n" unless $keepforks;
1106                 warn "allowing removal of forked project while preserving its forks with --keep-forks\n" unless $quiet;
1107                 # Run pseudo GC on that repository so that objects don't get lost within forks
1108                 my $basedir = $Girocco::Config::basedir;
1109                 my $projdir = $project->{path};
1110                 warn "We have to run pseudo GC on the repo so that the forks don't lose data. Hang on...\n" unless $quiet;
1111                 my $nogcrunning = sub {
1112                         die "Error: GC appears to be currently running on $projname\n"
1113                                 if -e "$projdir/gc.pid" || -e "$projdir/.gc_in_progress";
1114                 };
1115                 &$nogcrunning;
1116                 $removenogc = ! -e "$projdir/.nogc";
1117                 recreate_file("$projdir/.nogc") if $removenogc;
1118                 die "unable to create \"$projdir/.nogc\"\n" unless -e "$projdir/.nogc";
1119                 delete $ENV{show_progress};
1120                 $ENV{'show_progress'} = 1 unless $quiet;
1121                 sleep 2; # *cough*
1122                 &$nogcrunning;
1123                 system("$basedir/toolbox/perform-pre-gc-linking.sh", "--include-packs", $projname) == 0
1124                         or die "Running pseudo GC on project $projname failed\n";
1125                 $altwarn = 1;
1126         }
1127         my $archived;
1128         if (!$project->{mirror} && !$isempty && !$reallydel) {
1129                 $archived = $project->archive_and_delete;
1130                 unlink("$archived/.nogc") if $removenogc && defined($archived) && $archived ne "";
1131         } else {
1132                 $project->delete;
1133         }
1134         warn "Project '$projname' removed from $Girocco::Config::name" .
1135                 ($archived ? ", backup in '$archived'" : "") .".\n" unless $quiet;
1136         warn "Retained forks may now have unwanted objects/info/alternates lines\n" if $altwarn && !$quiet;
1137         return 0;
1138 }
1139
1140 sub cmd_prune {
1141         my ($force, $dryrun);
1142         parse_options(force => \$force, "dry-run" => \$dryrun, "quiet" => \$quiet);
1143         ($force && !$dryrun) || (!$force && $dryrun) or die_usage;
1144         my @projs = @ARGV;
1145         my %allprojs = map({($$_[0] => $_)} Girocco::Project::get_full_list_extended());
1146         my @allprojs = sort({lc($a) cmp lc($b) || $a cmp $b} keys(%allprojs));
1147         my %seen = ();
1148         @projs or @projs = @allprojs;
1149         my $bd = $Girocco::Config::reporoot.'/';
1150         my @remove = ();
1151         foreach (@projs) {
1152                 !$seen{$_} && $allprojs{$_} && ${$allprojs{$_}}[2] >= 65536 or next;
1153                 $seen{$_} = 1;
1154                 /^[a-zA-Z0-9]/ or next;
1155                 my $pd = $bd . $_ . '.git';
1156                 if (! -e $pd) {
1157                         warn "$_: no such directory: $pd\n" unless $quiet;
1158                         push(@remove, $_);
1159                 } elsif (! -d _) {
1160                         warn "$_: exists but not directory: $pd\n" unless $quiet;
1161                         push(@remove, $_);
1162                 }
1163         }
1164         warn "\n" if @remove && !$quiet;
1165         if ($dryrun) {
1166                 return 0 unless @remove;
1167                 my $msg = "Would remove ".scalar(@remove). " project entr";
1168                 $msg .= (@remove == 1 ? "y" : "ies");
1169                 $msg .= ":\n";
1170                 $msg .= join("", map("\t$_\n", @remove));
1171                 print $msg unless $quiet;
1172                 return 1;
1173         }
1174         my $msg = "Removed ".scalar(@remove). " project entr";
1175         $msg .= (@remove == 1 ? "y" : "ies");
1176         $msg .= ":\n";
1177         $msg .= join("", map("\t$_\n", @remove));
1178         my %remove = map({$_ => 1} @remove);
1179         filedb_atomic_edit(jailed_file('/etc/group'), sub {
1180                 my ($name,undef,$gid) = split /:/;
1181                 $gid =~ /^\d+$/ && $gid >= 65536 or return $_;
1182                 $name =~ /^[a-zA-Z0-9]/ or return $_;
1183                 !exists($remove{$name}) and return $_;
1184         });
1185         print $msg unless $quiet;
1186         return 0;
1187 }
1188
1189 sub cmd_show {
1190         use Data::Dumper;
1191         @ARGV == 1 or die_usage;
1192         my $project = get_clean_project($ARGV[0]);
1193         my %info = %$project;
1194         my $d = Data::Dumper->new([\%info], ['*'.$project->{name}]);
1195         $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
1196         print $d->Dump([\%info], ['*'.$project->{name}]);
1197         return 0;
1198 }
1199
1200 sub cmd_listheads {
1201         @ARGV == 1 or die_usage;
1202         my $project = get_project($ARGV[0]);
1203         my @heads = sort({lc($a) cmp lc($b)} $project->get_heads);
1204         my $cur = $project->{HEAD};
1205         defined($cur) or $cur = '';
1206         my $curmark = '*';
1207         my $headhash = get_git("--git-dir=$project->{path}", 'rev-parse', '--quiet', '--verify', 'HEAD');
1208         defined($headhash) or $headhash = '';
1209         chomp $headhash;
1210         $headhash or $curmark = '!';
1211         foreach (@heads) {
1212                 my $mark = $_ eq $cur ? $curmark : ' ';
1213                 print "$mark $_\n";
1214         }
1215         return 0;
1216 }
1217
1218 sub cmd_listtags {
1219         my $vcnt = 0;
1220         shift(@ARGV), $vcnt=1 if @ARGV && ($ARGV[0] eq '--verbose' || $ARGV[0] eq '-v');
1221         @ARGV == 1 or die_usage;
1222         my $project = get_project($ARGV[0]);
1223         if ($vcnt) {
1224                 print map("$$_[0]\t$$_[1]\n", get_ctag_counts($project));
1225         } else {
1226                 print map("$_\n", $project->get_ctag_names);
1227         }
1228         return 0;
1229 }
1230
1231 sub cmd_deltags {
1232         my $ic = 0;
1233         shift(@ARGV), $ic=1 if @ARGV && $ARGV[0] =~ /^(?:--?ignore-case|-i)$/i;
1234         @ARGV >= 2 or die_usage;
1235         my $project = get_project(shift @ARGV);
1236         my %curtags;
1237         if ($ic) {
1238                 push(@{$curtags{lc($_)}}, $_) foreach $project->get_ctag_names;
1239         } else {
1240                 push(@{$curtags{$_}}, $_) foreach $project->get_ctag_names;
1241         }
1242         my @deltags = ();
1243         my %seentag = ();
1244         my $ctags = join(" ", @ARGV);
1245         $ctags = lc($ctags) if $ic;
1246         foreach (split(/[\s,]+/, $ctags)) {
1247                 next unless exists($curtags{$_});
1248                 $seentag{$_}=1, push(@deltags, $_) unless $seentag{$_};
1249         }
1250         if (!@deltags) {
1251                 warn $project->{name}, ": skipping removal of only non-existent tags\n" unless $quiet;
1252         } else {
1253                 # Avoid touching anything other than the ctags
1254                 foreach my $tg (@deltags) {
1255                         $project->delete_ctag($_) foreach @{$curtags{$tg}};
1256                 }
1257                 $project->_set_changed;
1258                 $project->_set_forkchange;
1259                 warn $project->{name}, ": specified tags have been removed\n" unless $quiet;
1260         }
1261         return 0;
1262 }
1263
1264 sub cmd_addtags {
1265         @ARGV >= 2 or die_usage;
1266         my $project = get_project(shift @ARGV);
1267         my $ctags = join(" ", @ARGV);
1268         $ctags =~ /[^, a-zA-Z0-9:.+#_-]/ and
1269                 die "Content tag(s) \"$ctags\" contain(s) evil character(s).\n";
1270         my $oldmask = umask();
1271         umask($oldmask & ~0060);
1272         my $changed = 0;
1273         foreach (split(/[\s,]+/, $ctags)) {
1274                 ++$changed if $project->add_ctag($_, 1);
1275         }
1276         if ($changed) {
1277                 $project->_set_changed;
1278                 $project->_set_forkchange;
1279         }
1280         umask($oldmask);
1281         my $cnt = ($changed == 1) ? "1 content tag has" : $changed . " content tags have";
1282         warn $project->{name}, ": $cnt been added/updated\n" unless $quiet;
1283         return 0;
1284 }
1285
1286 sub _get_random_val {
1287         my $p = shift;
1288         my $md5;
1289         {
1290                 no warnings;
1291                 $md5 = md5_hex(time . $$ . rand() . join(':',%$p));
1292         }
1293         $md5;
1294 }
1295
1296 sub cmd_chpass {
1297         my $force = 0;
1298         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1299         my $random = undef;
1300         pop(@ARGV), $random=lc($ARGV[1]) if @ARGV==2 && $ARGV[1] =~ /^(?:random|unknown)$/i;
1301         @ARGV == 1 or die_usage;
1302         my $project = get_project($ARGV[0]);
1303         die "refusing to change locked password of project \"$ARGV[0]\" without --force\n"
1304                 if $project->is_password_locked;
1305         my ($newpw, $rmsg);
1306         if ($random) {
1307                 if ($random eq "random") {
1308                         die "refusing to set random password without --force\n" unless $force;
1309                         $rmsg = "set to random value";
1310                         $newpw = _get_random_val($project);
1311                 } else {
1312                         die "refusing to set password hash to '$random' without --force\n" unless $force;
1313                         $rmsg = "hash set to '$random'";
1314                         $newpw = $random;
1315                 }
1316         } else {
1317                 $rmsg = "updated";
1318                 if (-t STDIN) {
1319                         print "Changing admin password for project $ARGV[0]\n";
1320                         my $np1 = prompt_noecho_nl_or_die("New password for project $ARGV[0] (echo is off)");
1321                         $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1322                         my $np2 = prompt_noecho_nl_or_die("Retype new password for project $ARGV[0]");
1323                         $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
1324                                 "the admin passwords you have entered do not match each other.\n";
1325                         $newpw = $np1;
1326                 } else {
1327                         $newpw = <STDIN>;
1328                         defined($newpw) or die "missing new password on STDIN\n";
1329                         chomp($newpw);
1330                 }
1331         }
1332         $newpw ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1333         my $old = $project->{crypt};
1334         $project->{crypt} = (defined($random) && $random ne "random") ? $newpw : scrypt_sha1($newpw);
1335         if (defined($old) && $old eq $project->{crypt}) {
1336                 warn $project->{name}, ": skipping update of password hash to same value\n" unless $quiet;
1337         } else {
1338                 # Avoid touching anything other than the password hash
1339                 $project->_group_update;
1340                 warn $project->{name}, ": admin password $rmsg (new hash stored)\n" unless $quiet;
1341         }
1342         return 0;
1343 }
1344
1345 sub cmd_checkpw {
1346         @ARGV == 1 or die_usage;
1347         my $project = get_project($ARGV[0]);
1348         my $pwhash = $project->{crypt};
1349         defined($pwhash) or $pwhash = "";
1350         if ($pwhash eq "") {
1351                 warn $project->{name}, ": no password required\n" unless $quiet;
1352                 return 0;
1353         }
1354         if ($project->is_password_locked) {
1355                 warn $project->{name}, ": password is locked\n" unless $quiet;
1356                 exit 1;
1357         }
1358         my $checkpw;
1359         if (-t STDIN) {
1360                 $checkpw = prompt_noecho_nl_or_die("Admin password for project $ARGV[0] (echo is off)");
1361                 $checkpw ne "" or warn "checking for empty password as hash (very unlikely)\n" unless $quiet;
1362         } else {
1363                 $checkpw = <STDIN>;
1364                 defined($checkpw) or die "missing admin password on STDIN\n";
1365                 chomp($checkpw);
1366         }
1367         unless (Girocco::CLIUtil::check_passwd_match($pwhash, $checkpw)) {
1368                 warn "password check failure\n" unless $quiet;
1369                 exit 1;
1370         }
1371         warn "admin password match\n" unless $quiet;
1372         return 0;
1373 }
1374
1375 sub cmd_gc {
1376         my ($force, $auto, $redelta, $recompress);
1377         parse_options(force => \$force, quiet => \$quiet, q => \$quiet, auto => \$auto,
1378                 redelta => \$redelta, "no-reuse-delta" => \$redelta, aggressive => \$force,
1379                 recompress => \$recompress, "no-reuse-object" => $recompress);
1380         $force && $auto and die "--force and --auto are mutually exclusive options\n";
1381         @ARGV or die "Please give project name on command line.\n";
1382         @ARGV == 1 or die_usage;
1383         my $project = get_project($ARGV[0]);
1384         delete $ENV{show_progress};
1385         delete $ENV{force_gc};
1386         $quiet or $ENV{"show_progress"} = 1;
1387         $force and $ENV{"force_gc"} = 1;
1388         if (!$auto && !$force && ! -e $project->{path}."/.needsgc") {
1389                 open NEEDSGC, '>', $project->{path}."/.needsgc" and close NEEDSGC;
1390         }
1391         my @args = ($Girocco::Config::basedir . "/jobd/gc.sh", $project->{name});
1392         $redelta && !$recompress and push(@args, "-f");
1393         $recompress and push(@args, "-F");
1394         my $lastgc = $project->{lastgc};
1395         system({$args[0]} @args) != 0 and return 1;
1396         # Do it again Sam, but only if lastgc was set, gc.sh succeeded and now it's not set
1397         if ($lastgc) {
1398                 my $newlastgc = get_git("--git-dir=$project->{path}", 'config', '--get', 'gitweb.lastgc');
1399                 if (!$newlastgc) {
1400                         system({$args[0]} @args) != 0 and return 1;
1401                 }
1402         }
1403         return 0;
1404 }
1405
1406 sub cmd_update {
1407         my ($force, $summary);
1408         parse_options(force => \$force, quiet => \$quiet, q => \$quiet, summary => \$summary);
1409         $quiet && $summary and die "--quiet and --summary are mutually exclusive options\n";
1410         @ARGV or die "Please give project name on command line.\n";
1411         @ARGV == 1 or die_usage;
1412         my $project = get_project($ARGV[0]);
1413         $project->{mirror} or die "Project \"$ARGV[0]\" is a push project, not a mirror project.\n";
1414         delete $ENV{show_progress};
1415         delete $ENV{force_update};
1416         if ($quiet) {
1417                 $ENV{"show_progress"} = 0;
1418         } else {
1419                 $ENV{"show_progress"} = ($summary ? 1 : 2);
1420         }
1421         $force and $ENV{"force_update"} = 1;
1422         system($Girocco::Config::basedir . "/jobd/update.sh", $project->{name}) != 0 and return 1;
1423         return 0;
1424 }
1425
1426 sub cmd_remirror {
1427         my $force = 0;
1428         parse_options(force => \$force, quiet => \$quiet, q => \$quiet);
1429         @ARGV or die "Please give project name on command line.\n";
1430         @ARGV == 1 or die_usage;
1431         my $project = get_project($ARGV[0]);
1432         $project->{mirror} or die "Project \"$ARGV[0]\" is a push project, not a mirror project.\n";
1433         if ($project->{clone_in_progress} && !$project->{clone_failed}) {
1434                 warn "Project \"$ARGV[0]\" already seems to have a clone underway at this moment.\n" unless $quiet && $force;
1435                 exit(255) unless $force;
1436                 yes_to_continue_or_die("Are you sure you want to force a remirror");
1437         }
1438         unlink($project->_clonefail_path);
1439         unlink($project->_clonelog_path);
1440         recreate_file($project->_clonep_path);
1441         my $sock = IO::Socket::UNIX->new($Girocco::Config::chroot.'/etc/taskd.socket') or
1442                 die "cannot connect to taskd.socket: $!\n";
1443         select((select($sock),$|=1)[0]);
1444         $sock->print("clone ".$project->{name}."\n");
1445         # Just ignore reply, we are going to succeed anyway and the I/O
1446         # would apparently get quite hairy.
1447         $sock->flush();
1448         sleep 2; # *cough*
1449         $sock->close();
1450         warn "Project \"$ARGV[0]\" remirror initiated.\n" unless $quiet;
1451         return 0;
1452 }
1453
1454 sub cmd_setowner {
1455         my $force = 0;
1456         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1457         @ARGV == 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1458         my $project = get_project($ARGV[0]);
1459         if (@ARGV == 2 && !valid_email($ARGV[1])) {
1460                 die "invalid owner/email (use --force to accept): \"$ARGV[1]\"\n"
1461                         unless $force;
1462                 warn "using invalid owner/email with --force\n" unless $quiet;
1463         }
1464         if (@ARGV == 2 && length($ARGV[1]) > 96) {
1465                 die "owner/email longer than 96 chars (use --force to accept): \"$ARGV[1]\"\n"
1466                         unless $force;
1467                 warn "using longer than 96 char owner/email with --force\n" unless $quiet;
1468         }
1469         my $old = $project->{email};
1470         if (@ARGV == 1) {
1471                 print "$old\n" if defined($old);
1472                 return 0;
1473         }
1474         if (defined($old) && $old eq $ARGV[1]) {
1475                 warn $project->{name}, ": skipping update of owner/email to same value\n" unless $quiet;
1476         } else {
1477                 # Avoid touching anything other than "gitweb.owner"
1478                 $project->_property_fput("email", $ARGV[1]);
1479                 $project->_update_index;
1480                 $project->_set_changed;
1481                 warn $project->{name}, ": owner/email updated to \"$ARGV[1]\"\n" unless $quiet;
1482         }
1483         return 0;
1484 }
1485
1486 sub cmd_setdesc {
1487         my $force = 0;
1488         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1489         @ARGV >= 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1490         my $project = get_project(shift @ARGV);
1491         if (@ARGV && !valid_desc(join(" ", @ARGV))) {
1492                 die "invalid description (use --force to accept): \"".join(" ", @ARGV)."\"\n"
1493                         unless $force;
1494                 warn "using invalid description with --force\n" unless $quiet;
1495         }
1496         my $desc = clean_desc(join(" ", @ARGV));
1497         if (@ARGV && length($desc) > 1024) {
1498                 die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
1499                         unless $force;
1500                 warn "using longer than 1024 char description with --force\n" unless $quiet;
1501         }
1502         my $old = $project->{desc};
1503         if (!@ARGV) {
1504                 print "$old\n" if defined($old);
1505                 return 0;
1506         }
1507         if (defined($old) && $old eq $desc) {
1508                 warn $project->{name}, ": skipping update of description to same value\n" unless $quiet;
1509         } else {
1510                 # Avoid touching anything other than description file
1511                 $project->_property_fput("desc", $desc);
1512                 $project->_set_changed;
1513                 warn $project->{name}, ": description updated to \"$desc\"\n" unless $quiet;
1514         }
1515         return 0;
1516 }
1517
1518 sub cmd_setreadme {
1519         my ($force, $readmetype) = (0, undef);
1520         parse_options(force => \$force, ":type" => \$readmetype, ":format" => \$readmetype);
1521         @ARGV == 1 && defined($readmetype) and push(@ARGV, undef);
1522         @ARGV == 2 || (@ARGV == 1 && !$force && !defined($readmetype) && !$setopt) or die_usage;
1523         defined($readmetype) and $readmetype = Girocco::Project::_normalize_rmtype($readmetype,1);
1524         defined($readmetype) && !$readmetype and die_usage;
1525         my $project = get_project($ARGV[0]);
1526         my $old = $project->{READMEDATA};
1527         if (@ARGV == 1) {
1528                 chomp $old if defined($old);
1529                 print "$old\n" if defined($old) && $old ne "";
1530                 return 0;
1531         }
1532         $readmetype or $readmetype = $project->{rmtype};
1533         my ($new, $raw, $newname);
1534         $newname = '';
1535         if (!defined($ARGV[1])) {
1536                 $new = $old;
1537                 $newname = "original README data";
1538                 $readmetype ne $project->{rmtype} && $new ne "" and $raw = 1;
1539         } elsif ($ARGV[1] eq "-") {
1540                 local $/;
1541                 $new = <STDIN>;
1542                 $raw = 1;
1543                 $newname = "contents of <STDIN>";
1544         } elsif (lc($ARGV[1]) eq "automatic" || lc($ARGV[1]) eq "auto") {
1545                 $new = "";
1546         } elsif (lc($ARGV[1]) eq "suppressed" || lc($ARGV[1]) eq "suppress") {
1547                 $new = "<!-- suppress -->";
1548         } else {
1549                 my $fn = $ARGV[1];
1550                 $fn =~ s/^\@//;
1551                 die "missing filename for README\n" unless $fn ne "";
1552                 die "no such file: \"$fn\"\n" unless -f $fn && -r $fn;
1553                 open F, '<', $fn or die "cannot open \"$fn\" for reading: $!\n";
1554                 local $/;
1555                 $new = <F>;
1556                 close F;
1557                 $raw = 1;
1558                 $newname = "contents of \"$fn\"";
1559         }
1560         defined($new) or $new = '';
1561         my $origrmtype = $project->{rmtype};
1562         $project->{rmtype} = $readmetype;
1563         $project->{READMEDATA} = to_utf8($new, 1);
1564         $project->_cleanup_readme;
1565         if (length($project->{READMEDATA}) > 8192) {
1566                 die "readme greater than 8192 chars is too long (use --force to override)\n"
1567                         unless $force;
1568                 warn "using readme greater than 8192 chars with --force\n" unless $quiet;
1569         }
1570         if ($raw) {
1571                 my ($cnt, $err) = $project->_lint_readme(0);
1572                 if ($cnt) {
1573                         my $msg = "README: $cnt error";
1574                         $msg .= "s" unless $cnt == 1;
1575                         print STDERR "$msg\n", "-" x length($msg), "\n", $err
1576                                 unless $force && $quiet;
1577                         exit(255) unless $force && $project->{rmtype} eq 'HTML';
1578                         warn $project->{name} . ": using invalid raw HTML with --force\n" unless $quiet;
1579                         $project->{README} = $project->{READMEDATA};
1580                 }
1581         }
1582         if (defined($old) && $old eq $project->{READMEDATA} && $readmetype eq $origrmtype && !$force) {
1583                 warn $project->{name}, ": skipping update of README to same value\n" unless $quiet;
1584         } else {
1585                 # Avoid touching anything other than README.html file
1586                 $project->_property_fput("READMEDATA", $project->{READMEDATA}, 1);
1587                 $project->_property_fput("README", $project->{README});
1588                 $project->_property_fput("rmtype", $readmetype) if $readmetype ne $origrmtype;
1589                 $project->_set_changed;
1590                 my $desc = get_readme_desc($project->{README});
1591                 if ($newname) {
1592                         $newname .= " ($desc)";
1593                 } else {
1594                         $newname = $desc;
1595                 }
1596                 warn $project->{name}, ": README $readmetype format updated to $newname\n" unless $quiet;
1597         }
1598         return 0;
1599 }
1600
1601 sub valid_head {
1602         my ($proj, $newhead) = @_;
1603         my %okheads = map({($_ => 1)} $proj->get_heads);
1604         exists($okheads{$newhead});
1605 }
1606
1607 sub cmd_sethead {
1608         @ARGV == 2 || (@ARGV == 1 && !$setopt) or die_usage;
1609         my $project = get_project($ARGV[0]);
1610         if (@ARGV == 2 && !valid_head($project, $ARGV[1])) {
1611                 die "invalid head (try \"@{[basename($0)]} listheads $ARGV[0]\"): \"$ARGV[1]\"\n";
1612         }
1613         my $old = $project->{HEAD};
1614         if (@ARGV == 1) {
1615                 print "$old\n" if defined($old);
1616                 return 0;
1617         }
1618         if (defined($old) && $old eq $ARGV[1]) {
1619                 warn $project->{name}, ": skipping update of HEAD symref to same value\n" unless $quiet;
1620         } else {
1621                 # Avoid touching anything other than the HEAD symref
1622                 $project->set_HEAD($ARGV[1]);
1623                 $project->_set_changed;
1624                 warn $project->{name}, ": HEAD symref updated to \"refs/heads/$ARGV[1]\"\n" unless $quiet;
1625         }
1626         return 0;
1627 }
1628
1629 sub cmd_sethooks {
1630         my $force = 0;
1631         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1632         @ARGV == 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1633         my $project = get_project($ARGV[0]);
1634         my $projconfig = read_config_file_hash($project->{path}."/config");
1635         my $ghp = $Girocco::Config::reporoot."/_global/hooks";
1636         my $rghp = realpath($ghp);
1637         my $lhp = $project->{path}."/hooks";
1638         my $rlhp = realpath($lhp);
1639         my $ahp = "";
1640         my $rahp = undef;
1641         if (defined($projconfig) && defined($projconfig->{"core.hookspath"})) {
1642                 $ahp = $projconfig->{"core.hookspath"};
1643                 $rahp = realpath($ahp);
1644         }
1645         if (@ARGV == 1) {
1646                 if (defined($rahp) && $rahp ne "") {
1647                         if ($rahp eq $rghp) {
1648                                 my $nc = ($ahp eq $ghp ? "" : " non-canonical");
1649                                 printf "%s \t(global%s)\n", $ahp, $nc;
1650                         } elsif ($rahp eq $rlhp) {
1651                                 my $nc = ($ahp eq $lhp ? "" : " non-canonical");
1652                                 printf "%s \t(local%s)\n", $ahp, $nc;
1653                         } elsif ($rahp ne $ahp) {
1654                                 print "$ahp \t($rahp)\n";
1655                         } else {
1656                                 print "$ahp\n";
1657                         }
1658                 } elsif ($ahp ne "") {
1659                         print "$ahp \t(non-existent)\n";
1660                 }
1661                 return 0;
1662         }
1663         my $shp = $ARGV[1];
1664         if (lc($shp) eq "global") {
1665                 $shp = $ghp;
1666         } elsif (lc($shp) eq "local") {
1667                 $shp = $lhp;
1668         } elsif (substr($shp, 0, 2) eq "~/") {
1669                 $shp = $ENV{"HOME"}.substr($shp,1);
1670         } elsif ($shp =~ m,^~([a-zA-Z_][a-zA-Z_0-9]*)((?:/.*)?)$,) {
1671                 my $sfx = $2;
1672                 my $hd = (getpwnam($1))[7];
1673                 $shp = $hd . $sfx if defined($hd) && $hd ne "" && $hd ne "/" && -d $hd;
1674         }
1675         $shp ne "" && -d $shp or die "no such directory: $ARGV[1]\n";
1676         my $rshp = realpath($shp);
1677         defined($rshp) && $rshp ne "" or die "could not realpath: $ARGV[1]\n";
1678         $rshp =~ m,^/[^/], or die "invalid hookspath: $rshp\n";
1679         die "refusing to switch from current non-global hookspath without --force\n"
1680                 if !$force && defined($rahp) && $rahp ne "" && $rahp ne $rghp && $rshp ne $rahp;
1681         if (!$force && defined($rahp) && $rahp ne "") {
1682                 if ($rshp eq $rahp && ($ahp eq $ghp || $ahp eq $lhp)) {
1683                         warn $project->{name}, ": skipping update of hookspath to same effective value\n" unless $quiet;
1684                         return 0;
1685                 }
1686         }
1687         $rshp = $ghp if $rshp eq $rghp;
1688         $rshp = $lhp if $rshp eq $rlhp;
1689         if ($rshp eq $ahp) {
1690                 warn $project->{name}, ": skipping update of hookspath to same value\n" unless $quiet;
1691                 return 0;
1692         }
1693         die "refusing to set neither local nor global hookspath without --force\n"
1694                 if !$force && $rshp ne $ghp && $rshp ne $lhp;
1695         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
1696                 'config', "core.hookspath", $rshp);
1697         my $newval = '"'.$rshp.'"';
1698         $newval = "global" if $rshp eq $ghp;
1699         $newval = "local" if $rshp eq $lhp;
1700         warn $project->{name}, ": hookspath set to $newval\n" unless $quiet;
1701         return 0;
1702 }
1703
1704 our %boolfields;
1705 BEGIN {
1706         %boolfields = (
1707                 cleanmirror   => 1,
1708                 reverseorder  => 0,
1709                 summaryonly   => 0,
1710                 statusupdates => 1,
1711         );
1712 }
1713
1714 sub cmd_setbool {
1715         my $force = 0;
1716         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1717         @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1718         my $project = get_project($ARGV[0]);
1719         if (!exists($boolfields{$ARGV[1]})) {
1720                 die "invalid boolean field name: \"$ARGV[1]\" -- try \"help\"\n";
1721         }
1722         if (@ARGV == 3 && $boolfields{$ARGV[1]} && !$project->{mirror}) {
1723                 die "invalid boolean field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
1724                         unless $force;
1725                 warn "using mirror field on non-mirror with --force\n" unless $quiet;
1726         }
1727         if (@ARGV == 3 && !valid_bool($ARGV[2])) {
1728                 die "invalid boolean value: \"$ARGV[2]\"\n";
1729         }
1730         my $bool = clean_bool($ARGV[2]);
1731         my $old = $project->{$ARGV[1]};
1732         if (@ARGV == 2) {
1733                 print "$old\n" if defined($old);
1734                 return 0;
1735         }
1736         if (defined($old) && $old eq $bool) {
1737                 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
1738         } else {
1739                 # Avoid touching anything other than $ARGV[1] field
1740                 $project->_property_fput($ARGV[1], $bool);
1741                 warn $project->{name}, ": $ARGV[1] updated to $bool\n" unless $quiet;
1742         }
1743         return 0;
1744 }
1745
1746 sub cmd_setjsontype {
1747         @ARGV == 2 || (@ARGV == 1 && !$setopt) or die_usage;
1748         my $project = get_project($ARGV[0]);
1749         my $jsontype;
1750         if (@ARGV == 2) {
1751                 my $jt = lc($ARGV[1]);
1752                 index($jt, "/") >= 0 or $jt = "application/".$jt;
1753                 $jt eq 'application/x-www-form-urlencoded' ||
1754                 $jt eq 'application/json' or
1755                         die "invalid jsontype value: \"$ARGV[1]\"\n";
1756                 $jsontype = $jt;
1757         }
1758         my $old = $project->{jsontype};
1759         if (@ARGV == 1) {
1760                 print "$old\n" if defined($old);
1761                 return 0;
1762         }
1763         if (defined($old) && $old eq $jsontype) {
1764                 warn $project->{name}, ": skipping update of jsontype to same value\n" unless $quiet;
1765         } else {
1766                 # Avoid touching anything other than jsontype field
1767                 $project->_property_fput('jsontype', $jsontype);
1768                 warn $project->{name}, ": jsontype updated to $jsontype\n" unless $quiet;
1769         }
1770         return 0;
1771 }
1772
1773 sub cmd_setjsonsecret {
1774         @ARGV == 2 || (@ARGV == 1 && !$setopt) or die_usage;
1775         my $project = get_project($ARGV[0]);
1776         my $jsonsecret;
1777         if (@ARGV == 2) {
1778                 my $js = $ARGV[1];
1779                 $js =~ s/^\s+//; $js =~ s/\s+$//;
1780                 $jsonsecret = $js;
1781         }
1782         my $old = $project->{jsonsecret};
1783         if (@ARGV == 1) {
1784                 print "$old\n" if defined($old);
1785                 return 0;
1786         }
1787         if (defined($old) && $old eq $jsonsecret) {
1788                 warn $project->{name}, ": skipping update of jsonsecret to same value\n" unless $quiet;
1789         } else {
1790                 # Avoid touching anything other than jsonsecret field
1791                 $project->_property_fput('jsonsecret', $jsonsecret);
1792                 warn $project->{name}, ": jsonsecret updated to \"$jsonsecret\"\n" unless $quiet;
1793         }
1794         return 0;
1795 }
1796
1797 sub cmd_setautogchack {
1798         @ARGV == 2 || (@ARGV == 1 && !$setopt) or die_usage;
1799         my $project = get_project($ARGV[0]);
1800         my $aghok = $Girocco::Config::autogchack &&
1801                 ($project->{mirror} || $Girocco::Config::autogchack ne "mirror");
1802         my $old = defined($project->{autogchack}) ? clean_bool($project->{autogchack}) : "unset";
1803         if (@ARGV == 1) {
1804                 print "$old\n" if $aghok;
1805                 return 0;
1806         }
1807         my $bool;
1808         if (lc($ARGV[1]) eq "unset") {
1809                 $bool = "unset";
1810         } else {
1811                 valid_bool($ARGV[1]) or die "invalid boolean value: \"$ARGV[1]\"\n";
1812                 $bool = clean_bool($ARGV[1]);
1813         }
1814         if (!$aghok) {
1815                 die "\$Girocco::Config::autogchack is false\n" unless $Girocco::Config::autogchack;
1816                 die "\$Girocco::Config::autogchack is only enabled for mirrors\n";
1817         }
1818         if ($old eq $bool) {
1819                 warn $project->{name}, ": autogchack value unchanged\n" unless $quiet;
1820         } else {
1821                 if ($bool eq "unset") {
1822                         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
1823                                 'config', '--unset', "girocco.autogchack");
1824                 } else {
1825                         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
1826                                 'config', '--bool', "girocco.autogchack", $bool);
1827                 }
1828         }
1829         return system($Girocco::Config::basedir . "/jobd/maintain-auto-gc-hack.sh", $project->{name}) == 0
1830                 ? 0 : 1;
1831 }
1832
1833 sub valid_url {
1834         my ($url, $type) = @_;
1835         $type ne 'baseurl' and return valid_web_url($url);
1836         valid_repo_url($url) or return 0;
1837         if ($Girocco::Config::restrict_mirror_hosts) {
1838                 my $mh = extract_url_hostname($url);
1839                 is_dns_hostname($mh) or return 0;
1840                 !is_our_hostname($mh) or return 0;
1841         }
1842         return 1;
1843 }
1844
1845 our %urlfields;
1846 BEGIN {
1847         %urlfields = (
1848                 baseurl    => ["url"       , 1],
1849                 homepage   => ["hp"        , 0],
1850                 notifyjson => ["notifyjson", 0],
1851         );
1852 }
1853
1854 sub cmd_seturl {
1855         my $force = 0;
1856         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1857         @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1858         my $project = get_project($ARGV[0]);
1859         if (!exists($urlfields{$ARGV[1]})) {
1860                 die "invalid URL field name: \"$ARGV[1]\" -- try \"help\"\n";
1861         }
1862         if (@ARGV == 3 && ${$urlfields{$ARGV[1]}}[1] && !$project->{mirror}) {
1863                 die "invalid URL field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
1864                         unless $force;
1865                 warn "using mirror field on non-mirror with --force\n" unless $quiet;
1866         }
1867         if (@ARGV == 3 && !valid_url($ARGV[2], $ARGV[1])) {
1868                 die "invalid URL (use --force to accept): \"$ARGV[2]\"\n"
1869                         unless $force;
1870                 warn "using invalid URL with --force\n" unless $quiet;
1871         }
1872         my $old = $project->{${$urlfields{$ARGV[1]}}[0]};
1873         if (@ARGV == 2) {
1874                 print "$old\n" if defined($old);
1875                 return 0;
1876         }
1877         if (defined($old) && $old eq $ARGV[2]) {
1878                 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
1879         } else {
1880                 # Avoid touching anything other than $ARGV[1]'s field
1881                 $project->_property_fput(${$urlfields{$ARGV[1]}}[0], $ARGV[2]);
1882                 if ($ARGV[1] eq "baseurl") {
1883                         $project->{url} = $ARGV[2];
1884                         $project->_set_bangagain;
1885                 }
1886                 $project->_set_changed unless $ARGV[1] eq "notifyjson";
1887                 warn $project->{name}, ": $ARGV[1] updated to $ARGV[2]\n" unless $quiet;
1888         }
1889         return 0;
1890 }
1891
1892 our %msgsfields;
1893 BEGIN {
1894         %msgsfields = (
1895                 notifymail => 1,
1896                 notifytag  => 1,
1897         );
1898 }
1899
1900 sub cmd_setmsgs {
1901         my $force = 0;
1902         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1903         @ARGV >= 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1904         my $project = get_project(shift @ARGV);
1905         my $field = shift @ARGV;
1906         if (!exists($msgsfields{$field})) {
1907                 die "invalid msgs field name: \"$field\" -- try \"help\"\n";
1908         }
1909         if (@ARGV && !valid_addrlist(@ARGV)) {
1910                 die "invalid email address list (use --force to accept): \"".join(" ",@ARGV)."\"\n"
1911                         unless $force;
1912                 warn "using invalid email address list with --force\n" unless $quiet;
1913         }
1914         my $old = $project->{$field};
1915         if (!@ARGV) {
1916                 printf "%s\n", clean_addrlist($old, " ") if defined($old);
1917                 return 0;
1918         }
1919         my $newlist = clean_addrlist(join(" ",@ARGV));
1920         if (defined($old) && $old eq $newlist) {
1921                 warn $project->{name}, ": skipping update of $field to same value\n" unless $quiet;
1922         } else {
1923                 # Avoid touching anything other than $field's field
1924                 $project->_property_fput($field, $newlist);
1925                 warn $project->{name}, ": $field updated to \"$newlist\"\n" unless $quiet;
1926         }
1927         return 0;
1928 }
1929
1930 sub cmd_setusers {
1931         my $force = 0;
1932         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1933         @ARGV >= 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1934         my $project = get_project(shift @ARGV);
1935         my $projname = $project->{name};
1936         !@ARGV || !$project->{mirror} or die "cannot set users list for mirror project: \"$projname\"\n";
1937         my @newusers = ();
1938         if (@ARGV) {
1939                 eval {@newusers = validate_users(join(" ", @ARGV), $force); 1;} or exit 255;
1940                 die "refusing to set empty users list without --force\n" unless @newusers || $force;
1941         }
1942         return 0 if !@ARGV && $project->{mirror};
1943         my $oldusers = $project->{users};
1944         if ($oldusers && ref($oldusers) eq "ARRAY") {
1945                 $oldusers = join("\n", @$oldusers);
1946         } else {
1947                 $oldusers = "";
1948         }
1949         if (!@ARGV) {
1950                 print "$oldusers\n" if $oldusers ne "";
1951                 return 0;
1952         }
1953         if ($oldusers eq join("\n", @newusers)) {
1954                 warn "$projname: skipping update of users list to same value\n" unless $quiet;
1955         } else {
1956                 # Avoid touching anything other than the users list
1957                 $project->{users} = \@newusers;
1958                 $project->_update_users;
1959                 warn "$projname: users list updated to \"@{[join(',',@newusers)]}\"\n" unless $quiet;
1960         }
1961         return 0;
1962 }
1963
1964 our %fieldnames;
1965 BEGIN {
1966         %fieldnames = (
1967                 owner         => [\&cmd_setowner,      0],
1968                 desc          => [\&cmd_setdesc,       0],
1969                 description   => [\&cmd_setdesc,       0],
1970                 readme        => [\&cmd_setreadme,     0],
1971                 head          => [\&cmd_sethead,       0],
1972                 HEAD          => [\&cmd_sethead,       0],
1973                 hooks         => [\&cmd_sethooks,      0],
1974                 hookspath     => [\&cmd_sethooks,      0],
1975                 cleanmirror   => [\&cmd_setbool,       1],
1976                 reverseorder  => [\&cmd_setbool,       1],
1977                 summaryonly   => [\&cmd_setbool,       1],
1978                 statusupdates => [\&cmd_setbool,       1],
1979                 autogchack    => [\&cmd_setautogchack, 0],
1980                 baseurl       => [\&cmd_seturl,        1],
1981                 homepage      => [\&cmd_seturl,        1],
1982                 notifyjson    => [\&cmd_seturl,        1],
1983                 jsontype      => [\&cmd_setjsontype,   0],
1984                 jsonsecret    => [\&cmd_setjsonsecret, 0],
1985                 notifymail    => [\&cmd_setmsgs,       1],
1986                 notifytag     => [\&cmd_setmsgs,       1],
1987                 users         => [\&cmd_setusers,      0],
1988         );
1989 }
1990
1991 sub do_getset {
1992         $setopt = shift;
1993         my @newargs = ();
1994         push(@newargs, shift) if @_ && $_[0] eq '--force';
1995         my $field = $_[1];
1996         (($setopt && @_ >= 3) || @_ == 2) && exists($fieldnames{$field}) or die_usage;
1997         push(@newargs, shift);
1998         shift unless ${$fieldnames{$field}}[1];
1999         push(@newargs, @_);
2000         diename(($setopt ? "set " : "get ") . $field);
2001         @ARGV = @newargs;
2002         &{${$fieldnames{$field}}[0]}(@ARGV);
2003 }
2004
2005 sub cmd_get {
2006         do_getset(0, @_);
2007 }
2008
2009 sub cmd_set {
2010         do_getset(1, @_);
2011 }
2012
2013 our %commands;
2014 BEGIN {
2015         %commands = (
2016                 list => \&cmd_list,
2017                 create => \&cmd_create,
2018                 adopt => \&cmd_adopt,
2019                 remove => \&cmd_remove,
2020                 trash => \&cmd_remove,
2021                 delete => \&cmd_remove,
2022                 prune => \&cmd_prune,
2023                 show => \&cmd_show,
2024                 listheads => \&cmd_listheads,
2025                 listtags => \&cmd_listtags,
2026                 listctags => \&cmd_listtags,
2027                 deltags => \&cmd_deltags,
2028                 delctags => \&cmd_deltags,
2029                 addtags => \&cmd_addtags,
2030                 addctags => \&cmd_addtags,
2031                 chpass => \&cmd_chpass,
2032                 checkpw => \&cmd_checkpw,
2033                 gc => \&cmd_gc,
2034                 update => \&cmd_update,
2035                 remirror => \&cmd_remirror,
2036                 setowner => \&cmd_setowner,
2037                 setdesc => \&cmd_setdesc,
2038                 setdescription => \&cmd_setdesc,
2039                 setreadme => \&cmd_setreadme,
2040                 sethead => \&cmd_sethead,
2041                 sethooks => \&cmd_sethooks,
2042                 sethookspath => \&cmd_sethooks,
2043                 setbool => \&cmd_setbool,
2044                 setboolean => \&cmd_setbool,
2045                 setflag => \&cmd_setbool,
2046                 setautogchack => \&cmd_setautogchack,
2047                 seturl => \&cmd_seturl,
2048                 setjsontype => \&cmd_setjsontype,
2049                 setjsonsecret => \&cmd_setjsonsecret,
2050                 setmsgs => \&cmd_setmsgs,
2051                 setusers => \&cmd_setusers,
2052                 get => \&cmd_get,
2053                 set => \&cmd_set,
2054         );
2055 }
2056 our %nopager;
2057 BEGIN { %nopager = (
2058         # 1 => pager never allowed
2059         # -1 => pager defaults to off instead of on
2060         create          => 1,
2061         adopt           => -1,
2062         remove          => -1,
2063         trash           => -1,
2064         delete          => -1,
2065         prune           => -1,
2066         deltags         => -1,
2067         delctags        => -1,
2068         addtags         => -1,
2069         addctags        => -1,
2070         chpass          => 1,
2071         checkpw         => 1,
2072         gc              => -1,
2073         update          => -1,
2074         remirror        => -1,
2075         setowner        => -1,
2076         setdesc         => -1,
2077         setdescription  => -1,
2078         setreadme       => -1,
2079         sethead         => -1,
2080         sethooks        => -1,
2081         sethookspath    => -1,
2082         setbool         => -1,
2083         setboolean      => -1,
2084         setflag         => -1,
2085         setautogchack   => -1,
2086         seturl          => -1,
2087         setjsontype     => -1,
2088         setjsonsecret   => -1,
2089         setmsgs         => -1,
2090         setusers        => -1,
2091         set             => -1,
2092 )}
2093
2094 sub dohelp {
2095         my $cmd = shift;
2096         my $bn = basename($0);
2097         setup_pager_stdout($usepager);
2098         printf "%s version %s\n\n", $bn, $VERSION;
2099         if (defined($cmd) && $cmd ne '') {
2100                 $cmd =~ s/^set(?=[a-zA-Z])//i;
2101                 my $cmdhelp = '';
2102                 my ($lastmt, $incmd);
2103                 foreach (split('\n', sprintf($help, $bn))) {
2104                         $lastmt || $incmd or $lastmt = /^\s*$/, next;
2105                         $incmd = 1 if $lastmt && /^\s*(?:\[?set\]?)?$cmd\s/;
2106                         last if $incmd && /^\s*$/;
2107                         $incmd and $cmdhelp .= $_ . "\n";
2108                         $lastmt = /^\s*$/;
2109                 }
2110                 print $cmdhelp and exit 0 if $cmdhelp;
2111         }
2112         printf $help, $bn;
2113         exit 0;
2114 }
2115
2116 sub main {
2117         local *ARGV = \@_;
2118         {
2119                 shift, $quiet=1, redo if @ARGV && $ARGV[0] =~ /^(?:-q|--quiet)$/i;
2120                 shift, $usepager=1, redo if @ARGV && $ARGV[0] =~ /^(?:-p|--pager|--paginate)$/i;
2121                 shift, $usepager=0, redo if @ARGV && $ARGV[0] =~ /^(?:--no-pager|--no-paginate)$/i;
2122         }
2123         dohelp($ARGV[1]) if !@ARGV || @ARGV && $ARGV[0] =~ /^(?:-h|-?-help|help)$/i;
2124         my $command = shift;
2125         diename($command);
2126         $setopt = 1;
2127         if (!exists($commands{$command}) && exists($commands{"set".$command})) {
2128                 $setopt = 0;
2129                 $command = "set" . $command;
2130         }
2131         exists($commands{$command}) or die "Unknown command \"$command\" -- try \"help\"\n";
2132         dohelp($command) if @ARGV && ($ARGV[0] =~ /^(?:-h|-?-help)$/i ||
2133                 $ARGV[0] =~ /^help$/i && !Girocco::Project::does_exist("help",1));
2134         $nopager{$command} && $nopager{$command} > 0 and $usepager = 0;
2135         my $pgdfltoff = $nopager{$command} && $nopager{$command} < 0 ? 1 : 0;
2136         setup_pager_stdout($usepager, $pgdfltoff);
2137         &{$commands{$command}}(@ARGV);
2138 }