toolbox/projtool.pl

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