toolbox/projtool.pl

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