3 # projtool.pl - command line Girocco project maintenance tool
4 # Copyright (C) 2016 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.
12 use vars
qw($VERSION);
13 BEGIN {*VERSION = \'1.0'}
15 use Digest::MD5 qw(md5_hex);
21 use Girocco
::HashUtil
;
26 exit(&main
(@ARGV)||0);
29 BEGIN {$help = <<'HELP'}
30 Usage: %s [--quiet] <command> <options>
32 list [--verbose] [--sort=lcname|name|owner|gid|no] [--owner] [<regexp>]
33 list all projects (default is --sort=lcname)
35 create [--force] [--no-alternates] [--orphan] [-p] <project>
36 create new project <project>
38 adopt [--force] [--type=mirror|push] [<option>...] <project> [<users>]
39 adopt project <project>
40 type of project is guessed if --type=<type> omitted
41 <users> is same as <newuserslist> for setusers command
43 --dry-run do all the checks but don't perform adoption
44 --verbose show project info dump (useful with --dry-run)
45 --no-users no push users at all (<users> must be omitted)
46 --no-owner leave the gitweb.owner config totally unchanged
47 --owner=<val> set the gitweb.owner config to <val>
48 Both --no-owner and --owner=<val> may NOT be given, with neither
49 take owner from preexisting gitweb.owner else use admin setting.
50 For mirrors <users> is ignored otherwise if no <users> and no
51 --no-users option the push users list will consist of the single
52 user name matching the owner or empty if none or more than one.
53 With --dry-run <project> can be an absolute path to a git dir.
55 remove [--force] [--really-delete] [--keep-forks] <project>
56 remove project <project>
59 show project <project>
62 list all available heads for <project> and indicate current head
64 listtags [--verbose] <project>
65 list all ctags on project <project>
67 deltags <project> [-i] <tagstodel>
68 remove any ctags on project <project> present in <tagstodel>
69 <tagstodel> is space or comma separated list of tags to remove
70 (with -i match against <tagstodel> without regard to letter case)
72 addtags <project> <tagstoadd>
73 add ctags to project <project>
74 <tagstoadd> is space or comma separated list of tags to add
76 chpass [--force] <project> [random | unknown]
77 change project <project> password
78 (with "random" set to random password)
79 (with "unknown" set password hash to invalid value "unknown")
82 check project <project> password for a match
84 remirror [--force] <project>
85 initiate a remirror of project <project>
87 [set]owner [--force] <project> <newowner>
88 set project <project> owner to <newowner>
89 (without "set" and only 1 arg, just show current project owner)
91 [set]desc [--force] <project> <newdesc>
92 set project <project> description to <newdesc>
93 (without "set" and only 1 arg, just show current project desc)
95 [set]readme [--force] <project> <newsetting>
96 set project <project> readme to <newsetting>
97 <newsetting> is automatic|suppressed|-|[@]filename
98 (without "set" and only 2 args, just show current readme setting)
100 [set]head <project> <newhead>
101 set project <project> HEAD symbolic ref to <newhead>
102 (without "set" and only 1 arg, just show current project HEAD)
104 [set]bool [--force] <project> <flagname> <boolvalue>
105 set project <project> boolean <flagname> to <boolvalue>
106 <flagname> is cleanmirror|reverseorder|summaryonly|statusupdtaes
107 (without "set" and only 2 args, just show current flag value)
109 [set]url [--force] <project> <urlname> <newurlvalue>
110 set project <project> url <urlname> to <newurlvalue>
111 <urlname> is baseurl|homepage|notifyjson
112 (without "set" and only 2 args, just show current url value)
114 [set]msgs [--force] <project> <msgsname> <eaddrlist>
115 set project <project> msgs <msgsname> to <addrlist>
116 <msgsname> is notifymail|notifytag
117 <eaddrlist> is space or comma separated list of email addresses
118 (without "set" and only 2 args, just show current msgs value)
120 [set]users [--force] <project> <newuserslist>
121 set push project <project> users list to <newuserslist>
122 <newuserslist> is space or comma separated list of user names
123 (without "set" and only 1 arg, just show current users list)
125 get <project> <fieldname>
126 show project <project> field <fieldname>
127 <fieldname> is owner|desc|readme|head|users
128 or <flagname>|<urlname>|<msgsname>
130 set [--force] <project> <fieldname> <newfieldvalue>
131 set project <project> field <fieldname> to <newfieldvalue>
132 <fieldname> same as for get
133 <newfieldvalue> same as for corresponding set... command
139 my $sub = shift || diename
;
141 die "Invalid arguments to $sub command -- try \"help\"\n";
143 die "Invalid arguments -- try \"help\"\n";
147 sub get_readme_desc
{
149 defined($rm) or $rm = '';
152 $test =~ s/<!--(?:[^-]|(?:-(?!-)))*-->//gs;
154 return $test eq '' ?
"suppressed" : "length " . length($rm);
160 sub get_ctag_counts
{
164 foreach ($project->get_ctag_names) {
167 if (open $ct, '<', $project->{path
}."/ctags/$_") {
170 defined $count or $count = '';
172 $val = $count =~ /^[1-9]\d*$/ ?
$count : 1;
178 push(@ctags, $_."(".$val.")");
181 push(@ctags, [$_, $val]) if $val;
187 sub get_clean_project
{
188 my $project = get_project
(@_);
189 delete $project->{loaded
};
190 delete $project->{base_path
};
191 delete $project->{ccrypt
};
192 /^orig/i || !defined($project->{$_}) and delete $project->{$_} foreach keys %$project;
193 $project->{owner
} = $project->{email
}; delete $project->{email
};
194 $project->{homepage
} = $project->{hp
}; delete $project->{hp
};
195 $project->{baseurl
} = $project->{url
}; delete $project->{url
};
196 my $owner = $project->{owner
};
199 my @owner_users = map {$owner eq lc($$_[4]) ?
$$_[1] : ()} get_all_users
;
200 $project->{owner_users
} = \
@owner_users if @owner_users;
202 my $projname = $project->{name
};
203 my @forks = grep {$$_[1] =~ m
,^$projname/,} get_all_projects
;
204 $project->{has_forks
} = 1 if @forks;
205 $project->{has_alternates
} = 1 if $project->has_alternates;
206 my @bundles = $project->bundles;
207 delete $project->{bundles
};
208 $project->{bundles
} = \
@bundles if @bundles;
209 $project->{mirror
} = 0 unless $project->{mirror
};
210 $project->{is_empty
} = 1 if $project->is_empty;
211 delete $project->{showpush
} unless $project->{showpush
};
212 delete $project->{users
} if $project->{mirror
};
213 delete $project->{baseurl
} unless $project->{mirror
};
214 delete $project->{banged
} unless $project->{mirror
};
215 delete $project->{lastrefresh
} unless $project->{mirror
};
216 delete $project->{cleanmirror
} unless $project->{mirror
};
217 delete $project->{statusupdates
} unless $project->{mirror
};
218 delete $project->{lastparentgc
} unless $projname =~ m
,/,;
219 unless ($project->{banged
}) {
220 delete $project->{bangcount
};
221 delete $project->{bangfirstfail
};
222 delete $project->{bangmessagesent
};
224 $project->{README
} = get_readme_desc
($project->{README
}) if exists($project->{README
});
225 my @tags = get_ctag_counts
($project, 1);
226 $project->{tags
} = \
@tags if @tags;
233 foreach (split(/[,\s]+/, $_[0])) {
235 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
237 return join(($_[1]||","), @newlist);
241 my $cleaned = clean_addrlist
(join(" ", @_));
242 return 1 if $cleaned eq "";
243 valid_email_multi
($cleaned) && length($cleaned) <= 512;
247 my ($userlist, $force, $nodie, $quiet) = @_;
251 my $mobok = $Girocco::Config
::mob
&& $Girocco::Config
::mob
eq "mob";
252 my %users = map({($$_[1] => $_)} get_all_users
);
253 foreach (split(/[\s,]+/, $userlist)) {
254 if (exists($users{$_}) || $_ eq "everyone" || ($mobok && $_ eq "mob")) {
255 $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
258 if (Girocco
::User
::does_exist
($_, 1)) {
260 $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
263 warn "refusing to allow questionable user \"$_\" without --force\n" unless $nodie && $quiet;
268 warn "invalid user: \"$_\"\n" unless $nodie && $quiet
270 die if $badlist && !$nodie;
274 sub is_default_desc
{
275 # "Unnamed repository; edit this file 'description' to name the repository."
276 # "Unnamed repository; edit this file to name it for gitweb."
278 return 0 unless defined($_);
279 /Unnamed\s+repository;/i && /\s+edit\s+this\s+file\s+/i && /\s+to\s+name\s+/i;
285 return 0 if $test =~ /[\r\n]/;
286 $test =~ s/\s\s+/ /g;
294 defined($desc) or $desc = '';
296 $desc = to_utf8
($desc, 1);
297 $desc =~ s/\s\s+/ /g;
304 Girocco
::CLIUtil
::_parse_options
(
306 warn((($_[0]eq'?')?
"unrecognized":"missing argument for")." option \"$_[1]\"\n")
314 lcname
=> sub {lc($$a[1]) cmp lc($$b[1])},
315 name
=> sub {$$a[1] cmp $$b[1]},
316 gid
=> sub {$$a[3] <=> $$b[3]},
317 owner
=> sub {lc($$a[4]) cmp lc($$b[4]) || lc($$a[1]) cmp lc($$b[1])},
318 no => sub {$$a[0] <=> $$b[0]},
320 my $sortopt = 'lcname';
321 my ($verbose, $owner);
322 parse_options
(":sort" => \
$sortopt, verbose
=> \
$verbose, owner
=> \
$owner);
325 my $val = shift @ARGV;
326 $regex = qr
($val) or die "bad regex \"$val\"\n";
328 !@ARGV && exists($sortsub{$sortopt}) or die_usage
;
329 my $sortsub = $sortsub{$sortopt};
330 my $grepsub = defined($regex) ?
($owner ?
sub {$$_[4] =~ /$regex/} : sub {$$_[1] =~ /$regex/}) : sub {1};
331 my @projects = sort($sortsub grep {&$grepsub} get_all_projects
);
333 print map(sprintf("%s\n", join(":", (@
$_)[1..5])), @projects);
335 print map(sprintf("%s: %s\n", $$_[1], $$_[5] =~ /^:/ ?
"<mirror>" : $$_[5]), @projects);
341 my ($force, $noalternates, $orphanok, $optp);
342 parse_options
(force
=> \
$force, "no-alternates" => \
$noalternates, orphan
=> \
$orphanok, p
=> \
$optp);
343 @ARGV == 1 or die_usage
;
344 my $projname = $ARGV[0];
345 $projname =~ s/\.git$//i;
346 Girocco
::Project
::does_exist
($projname, 1) and die "Project already exists: \"$projname\"\n";
347 if (!Girocco
::Project
::valid_name
($projname, $orphanok, $optp)) {
348 warn "Refusing to create orphan project without --orphan\n"
349 if !$quiet && !$orphanok && Girocco
::Project
::valid_name
($projname, 1, 1);
350 warn "Required orphan parent directory does not exist (use -p): ",
351 $Girocco::Config
::reporoot
.'/'.Girocco
::Project
::get_forkee_name
($projname), "\n"
352 if !$quiet && $orphanok && Girocco
::Project
::valid_name
($projname, 1, 1);
353 die "Invalid project name: \"$projname\"\n";
355 my ($forkee, $project) = ($projname =~ m
#^(.*/)?([^/]+)$#);
356 my $newtype = $forkee ?
'fork' : 'project';
357 if (length($project) > 64) {
358 die "The $newtype name is longer than 64 characters. Do you really need that much?\n"
360 warn "Allowing $newtype name longer than 64 characters with --force\n" unless $quiet;
362 unless ($Girocco::Config
::push || $Girocco::Config
::mirror
) {
363 die "Project creation disabled (no mirrors or push projects allowed)\n" unless $force;
364 warn "Continuing with --force even though both push and mirror projects are disabled\n" unless $quiet;
366 print "Enter settings for new project \"$projname\"\n";
368 $settings{noalternates
} = $noalternates;
369 my $np1 = prompt_noecho_nl_or_die
("Admin password for project $projname (echo is off)");
370 $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
371 my $np2 = prompt_noecho_nl_or_die
("Retype admin password for project $projname");
372 $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
373 "the admin passwords you have entered do not match each other.\n";
374 $settings{crypt} = scrypt_sha1
($np1);
377 $owner = prompt_or_die
("Owner/email name for project $projname");
378 unless (valid_email
($owner)) {
380 warn "Your email sure looks weird...?\n";
383 warn "Allowing invalid email with --force\n" unless $quiet;
385 if (length($owner) > 96) {
387 warn "Your email is longer than 96 characters. Do you really need that much?\n";
390 warn "Allowing email longer than 96 characters with --force\n" unless $quiet;
393 $settings{email
} = $owner;
395 if ($force || $Girocco::Config
::mirror
) {{
396 if ($force || $Girocco::Config
::push) {
397 $baseurl = prompt_or_die
("URL to mirror from (leave blank for push project)", "");
399 $baseurl = prompt_or_die
("URL to mirror from");
400 unless ($baseurl ne "") {
401 warn "Push projects are disabled, you must enter a mirror URL (or use --force)\n";
405 if ($baseurl ne "") {
406 unless (valid_repo_url
($baseurl)) {
408 warn"Invalid mirror URL: \"$baseurl\"\n";
411 warn "Allowing invalid mirror URL with --force\n" unless $quiet;
413 if ($Girocco::Config
::restrict_mirror_hosts
) {
414 my $mh = extract_url_hostname
($baseurl);
415 unless (is_dns_hostname
($mh)) {
417 warn"Invalid non-DNS mirror URL: \"$baseurl\"\n";
420 warn "Allowing non-DNS mirror URL with --force\n" unless $quiet;
422 if (is_our_hostname
($mh)) {
424 warn "Invalid same-host mirror URL: \"$baseurl\"\n";
427 warn "Allowing same-host mirror URL with --force\n" unless $quiet;
430 $settings{url
} = $baseurl;
431 $settings{cleanmirror
} =
432 ynprompt_or_die
("Mirror only heads, tags and notes (Y/n)", "Yes");
435 my $mirror = ($baseurl eq "") ?
0 : 1;
438 $desc = prompt_or_die
("Short description", "");
439 if (length($desc) > 1024) {
441 warn "Short description length greater than 1024 characters!\n";
444 warn "Allowing short description length greater than 1024 characters\n" unless $quiet;
447 $settings{desc
} = $desc;
450 $homepage = prompt_or_die
("Home page URL", "");
451 if ($homepage ne "" && !valid_web_url
($homepage)) {
453 warn "Invalid home page URL: \$homepage\"\n";
456 warn "Allowing invalid home page URL with --force\n" unless $quiet;
459 $settings{hp
} = $homepage;
462 $jsonurl = prompt_or_die
("JSON notify POST URL", "");
463 if ($jsonurl ne "" && !valid_web_url
($jsonurl)) {
465 warn "Invalid JSON notify POST URL: \$jsonurl\"\n";
468 warn "Allowing invalid JSON notify POST URL with --force\n" unless $quiet;
471 $settings{notifyjson
} = $jsonurl;
474 $commitaddrs = clean_addrlist
(prompt_or_die
("Commit notify email addr(s)", ""));
475 if ($commitaddrs ne "" && !valid_addrlist
($commitaddrs)) {
477 warn"invalid commit notify email address list (use --force to accept): \"$commitaddrs\"\n";
480 warn "using invalid commit notify email address list with --force\n" unless $quiet;
483 $settings{notifymail
} = $commitaddrs;
484 $settings{reverseorder
} = 1;
485 $settings{reverseorder
} = ynprompt_or_die
("Oldest-to-newest commit order in emails", "Yes")
486 if $commitaddrs ne "";
487 $settings{summaryonly
} = ynprompt_or_die
("Summary only (no diff) in emails", "No")
488 if $commitaddrs ne "";
491 $tagaddrs = clean_addrlist
(prompt_or_die
("Tag notify email addr(s)", ""));
492 if ($tagaddrs ne "" && !valid_addrlist
($tagaddrs)) {
494 warn"invalid tag notify email address list (use --force to accept): \"$tagaddrs\"\n";
497 warn "using invalid tag notify email address list with --force\n" unless $quiet;
500 $settings{notifytag
} = $tagaddrs;
504 my $userlist = prompt_or_die
("Push users", join(",", @newusers));
505 eval {@newusers = validate_users
($userlist, $force); 1;} or redo;
507 $settings{users
} = \
@newusers;
509 my $newproj = Girocco
::Project
->ghost($projname, $mirror, $orphanok, $optp)
510 or die "Girocco::Project->ghost call failed\n";
512 $newproj->{$k} = $v while ($k, $v) = each(%settings);
514 $newproj->premirror or die "Girocco::Project->premirror failed\n";
515 $newproj->clone or die "Girocco::Project->clone failed\n";
516 warn "Project $projname created and cloning successfully initiated.\n"
519 $newproj->conjure or die "Girocco::Project->conjure failed\n";
520 warn "New push project fork is empty due to use of --no-alternates\n"
521 if !$quiet && $projname =~ m
,/, && $noalternates;
522 warn "Project $projname successfully created.\n" unless $quiet;
529 system($Girocco::Config
::git_bin
, "--git-dir=$gd", 'config', @_) == 0
530 or die "\"git --git-dir='$gd' config ".join(" ", @_)."\" failed.\n";
534 my ($force, $type, $nousers, $dryrun, $noowner, $owner, $users, $verbose);
535 parse_options
(force
=> \
$force, ":type" => \
$type, "no-users" => \
$nousers, "dry-run" => \
$dryrun,
536 "no-owner" => \
$noowner,":owner" => \
$owner, quiet
=> \
$quiet, q
=>\
$quiet, verbose
=> \
$verbose);
537 @ARGV or die "Please give project name on command line.\n";
538 my $projname = shift @ARGV;
539 (!$noowner || !defined($owner)) && (!$nousers || !@ARGV) or die_usage
;
540 !defined($type) || $type eq "mirror" || $type eq "push" or die_usage
;
541 defined($type) or $type = "";
543 if ($dryrun && $projname =~ m
,^/[^.\s/\\:], && is_git_dir
(realpath
($projname))) {
544 $projdir = realpath
($projname);
545 $projname = $projdir;
546 $projname =~ s/\.git$//i;
547 $projname =~ s
,/+$,,;
548 $projname =~ s
,^.*/,,;
549 $projname ne "" or $projname = $projdir;
551 $projname =~ s/\.git$//i;
552 $projname ne "" or die "Invalid project name \"\".\n";
553 unless (Girocco
::Project
::does_exist
($projname, 1)) {
554 Girocco
::Project
::valid_name
($projname, 1, 1)
555 or die "Invalid project name \"$projname\".\n";
556 die "No such project to adopt: $projname\n";
558 defined(girocco
::Project
->load($projname))
559 and die "Project already known (no need to adopt): $projname\n";
560 $projdir = $Girocco::Config
::reporoot
. "/" . $projname . ".git";
561 is_git_dir
($projdir) or die "Not a git directory: \"$projdir\"\n";
563 my $config = read_config_file
($projdir . "/config");
565 %config = map {($$_[0], defined($$_[1])?
$$_[1]:"true")} @
$config if defined($config);
566 git_bool
($config{"core.bare"}) or die "Not a bare git repository: \"$projdir\"\n";
567 defined(read_HEAD_symref
($projdir)) or die "Project with non-symbolic HEAD ref: \"$projdir\"\n";
568 @ARGV and $users = [validate_users
(join(" ", @ARGV), $force, 1, $quiet)];
570 if (-e
"$projdir/description") {
571 open my $fd, '<', "$projdir/description" or die "Cannot open \"$projdir/description\": $!\n";
577 defined $desc or $desc = "";
579 $desc = to_utf8
($desc, 1);
580 is_default_desc
($desc) and $desc = "";
581 if ($desc ne "" && !valid_desc
($desc)) {
582 die "invalid 'description' file contents (use --force to accept): \"$desc\"\n"
584 warn "using invalid 'description' file contents with --force\n" unless $quiet;
586 $desc = clean_desc
($desc);
587 if (length($desc) > 1024) {
588 die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
590 warn "using longer than 1024 char description with --force\n" unless $quiet;
594 if (-e
"$projdir/README.html") {
595 open my $fd, '<', "$projdir/README.html" or die "Cannot open \"$projdir/README.html\": $!\n";
601 defined $readme or $readme = "";
602 $readme = to_utf8
($readme, 1);
603 $readme =~ s/\r\n?/\n/gs;
604 $readme =~ s/^\s+//s;
605 $readme =~ s/\s+$//s;
606 $readme eq "" or $readme .= "\n";
607 if (length($readme) > 8192) {
608 die "readme greater than 8192 chars is too long (use --force to override)\n"
610 warn "using readme greater than 8192 chars with --force\n" unless $quiet;
612 my $rd = get_readme_desc
($readme);
613 if ($rd ne "automatic" && $rd ne "suppressed") {
614 my $xmllint = qx(command
-v xmllint
); chomp $xmllint;
615 if (-f
$xmllint && -x
$xmllint) {
616 my $dummy = {README
=> $readme};
617 my ($cnt, $err) = Girocco
::Project
::_lint_readme
($dummy, 0);
619 my $msg = "xmllint: $cnt error";
620 $msg .= "s" unless $cnt == 1;
621 print STDERR
"$msg\n", "-" x
length($msg), "\n", $err
622 unless $force && $quiet;
623 exit(255) unless $force;
624 warn "$projname: using invalid raw HTML with --force\n" unless $quiet;
627 die "xmllint not available, refusing to use raw HTML without --force\n"
629 warn "xmllint not available using unchecked raw HTML with --force\n" unless $quiet;
633 # Inspect any remotes now
634 # Yes, Virginia, remote urls can be multi-valued
638 next unless $k =~ /^remote\.([^\/].*?
)\
.([^.]+)$/; # remote name cannot start with "/"
639 my ($name, $subkey) = ($1, $2);
640 $remotes{$name}->{skip} = git_bool($v,1), next if $subkey eq "skipdefaultupdate
" || $subkey eq "skipfetchall
";
641 $remotes{$name}->{mirror} = git_bool($v,1), next if $subkey eq "mirror
"; # we might want this
642 $remotes{$name}->{vcs} = $v, next if defined($v) && $v !~ /^\s*$/ && $subkey eq "vcs
";
643 push(@{$remotes{$name}->{$subkey}}, $v), next if defined($v) && $v !~ /^\s*$/ &&
644 ($subkey eq "url
" || $subkey eq "fetch
" || $subkey eq "push" || $subkey eq "pushurl
");
646 # remotes.default is the default remote group to fetch for "git remote update
" otherwise --all
647 # the remote names in a group are separated by runs of [ \t\n] characters
648 # remote names "", ".", ".." and any name starting with "/" are invalid
649 # a remote with no url or vcs setting is not considered valid
652 if (exists($config{"remotes
.default"})) {
653 foreach (split(/[ \t\n]+/, $config{"remotes
.default"})) {
654 next unless exists($remotes{$_});
655 my $rmt = $remotes{$_};
656 next if !exists($rmt->{url}) && !$rmt->{vcs};
664 next unless $k =~ /^remote\.([^\/].*?)\.[^.]+$/;
665 next if $seenrmt{$1};
667 next unless exists($remotes{$1});
668 my $rmt = $remotes{$1};
669 next if $rmt->{skip} || (!exists($rmt->{url}) && !$rmt->{vcs});
673 my @needskip = (); # remotes that need skipDefaultUpdate set to true
676 my $foundfetchwithmirror = 0;
678 my $rmt = $remotes{$_};
679 push(@needskip, $_) if $usingall && !exists($rmt->{fetch});
680 next unless exists($rmt->{fetch});
682 ++$foundfetchwithmirror if $rmt->{mirror};
683 ++$foundvcs if $rmt->{vcs} || (exists($rmt->{url}) && $rmt->{url}->[0] =~ /^[a-zA-Z0-9][a-zA-Z0-9+.-]*::/);
685 # if we have $foundvcs then we need to explicitly set fetch.prune to false
686 # if we have $foundfetch > 1 then we need to explicitly set fetch.prune to false
687 my $neednoprune = !exists($config{"fetch
.prune
"}) && ($foundvcs || $foundfetch > 1);
689 my $needfakeorigin = 0; # if true we need to set remote.origin.skipDefaultUpdate = true
690 # if remote "origin
" exists we always pick up its first url or use ""
691 if (exists($remotes{origin})) {
692 my $rmt = $remotes{origin};
693 $baseurl = exists($rmt->{url}) ? $rmt->{url}->[0] : "";
694 $needfakeorigin = !exists($rmt->{url}) && !$rmt->{vcs} && !$rmt->{skip};
697 # get the first url of the @check remotes
699 my $rmt = $remotes{$_};
700 next unless exists($rmt->{url});
701 next unless defined($rmt->{url}->[0]) && $rmt->{url}->[0] ne "";
702 $baseurl = $rmt->{url}->[0];
706 my $makemirror = $type eq "mirror
" || ($type eq "" && $foundfetch);
708 # If we have $foundfetch we want to make a mirror but complain if
709 # we $foundfetchwithmirror as well unless we have --type=mirror.
710 # Warn if we have --type=push and $foundfetch and !$foundfetchwithmirror.
711 # Warn if we need to set fetch.prune=false when making a mirror
712 # Warn if we need to create remote.origin.skipDefaultUpdate when making a mirror
713 # Complain if @needskip AND !$usingall (warn with --force but don't set skip)
714 # Warn if $usingall and any @needskip (and set them) if making a mirror
715 # Warn if making a mirror and $baseurl eq ""
716 # Warn if we have --type=mirror and !$foundfetch
719 warn "No base URL to mirror from
for adopted
\"$projname\"\n" unless $quiet || $baseurl ne "";
720 warn "Adopting mirror
\"$projname\" without any fetch remotes
\n" unless $quiet || $foundfetch;
721 if ($foundfetchwithmirror) {
722 warn "Refusing to adopt mirror
\"$projname\" with active remote
.<name
>.mirror
=true remote
(s
)\n".
723 "(Use
--type
=mirror to override
)\n"
724 unless $type eq "mirror
";
725 exit(255) unless $type eq "mirror
" || $dryrun;
726 warn "Adopting mirror
\"$projname\" with active remote
.<name
>.mirror
=true remotes
\n"
727 unless $quiet || $type ne "mirror
";
729 warn "Setting explicit fetch
.prune
=false
for adoption of mirror
\"$projname\"\n"
730 if !$quiet && $neednoprune;
731 warn "Setting remote
.origin
.skipDefaultUpdate
=true
for adoption of mirror
\"$projname\"\n"
732 if !$quiet && $needfakeorigin;
733 if (!$usingall && @needskip) {
734 warn "Refusing to adopt mirror empty fetch remote
(s
) (override with
--force
)\n"
736 exit(255) unless $force || $dryrun;
737 warn "Adopting mirror with empty fetch remote
(s
) with
--force
\n"
738 unless $quiet || !$force;
740 warn "Will set skipDefaultUpdate
=true on non
-fetch remote
(s
)\n" if !$quiet && $usingall && @needskip;
741 warn "Adopting mirror with base URL
\"$baseurl\"\n" unless $quiet || $baseurl eq "";
743 warn "Adopting
push \"$projname\" but active non
-mirror remotes are present
\n"
744 if !$quiet && $foundfetch && !$foundfetchwithmirror;
747 if (!$noowner && !defined($owner)) {
749 $owner = $config{"gitweb
.owner
"};
750 if (!defined($owner) || $owner eq "") {
751 $owner = $Girocco::Config::admin;
752 warn "Using owner
\"$owner\" for adopted project
\n" unless $quiet;
755 if (!$nousers && !$makemirror && !defined($users)) {
756 # select user list for push project
757 my $findowner = $owner;
758 defined($findowner) or $findowner = $config{"gitweb
.owner
"};
759 $findowner = lc($findowner) if defined($findowner);
760 my @owner_users = ();
761 @owner_users = map {$findowner eq lc($$_[4]) ? $$_[1] : ()} get_all_users
762 if defined($findowner) && $findowner ne "";
763 if (@owner_users <= 1) {
764 $users = \@owner_users;
765 warn "No users found that match owner
\"$findowner\"\n" unless @owner_users || $quiet;
768 warn "Found
".scalar(@owner_users)." users
for owner
\"$findowner\" (" .
769 join(" ", @owner_users) . ") not setting any
\n" unless $quiet;
772 defined($users) or $users = [];
774 # Warn if we preserve an existing receive.denyNonFastForwards or receive.denyDeleteCurrent setting
775 # Complain if core.logallrefupdates or logs subdir exists and contains any files (allow with --force
776 # and warn about preserving the setting)
778 warn "Preserving existing receive
.denyNonFastForwards
=true
\n"
779 if !$quiet && git_bool($config{"receive
.denynonfastforwards
"});
780 warn "Preserving existing receive
.denyDeleteCurrent
=$config{'receive.denydeletecurrent'}\n"
781 if !$quiet && exists($config{"receive
.denydeletecurrent
"}) &&
782 $config{"receive
.denydeletecurrent
"} ne "warn";
784 my $reflogfiles = Girocco::Project::_contains_files("$projdir/logs
");
785 my $reflogactive = git_bool($config{"core
.logallrefupdates
"});
786 if ($reflogactive || $reflogfiles) {
787 warn "Refusing to adopt
\"$projname\" with active
ref logs without
--force
\n" if $reflogfiles && !$force;
788 warn "Refusing to adopt
\"$projname\" with core
.logAllRefUpdates
=true without
--force
\n" if $reflogactive && !$force;
789 exit(255) unless $force || $dryrun;
790 warn "Adopting
\"$projname\" with active
ref logs with
--force
\n" unless $quiet || ($reflogfiles && !$force);
791 warn "Adopting
\"$projname\" with core
.logAllRefUpdates
=true with
--force
\n" unless $quiet || ($reflogactive && !$force);
794 return 0 if $dryrun && !$verbose;
796 my $newproj = eval {Girocco::Project->ghost($projname, $makemirror, 1, $dryrun)};
797 defined($newproj) or die "Girocco
::Project
::ghost failed
: $@
\n";
798 $newproj->{desc} = $desc;
799 $newproj->{README} = $readme;
800 $newproj->{url} = $baseurl if $makemirror || exists($config{"gitweb
.baseurl
"});
801 $newproj->{email} = $owner if defined($owner);
802 $newproj->{users} = $users;
803 $newproj->{crypt} = "unknown
";
804 $newproj->{reverseorder} = 1 unless exists($config{"hooks
.reverseorder
"});
805 $newproj->{summaryonly} = 1 unless exists($config{"hooks
.summaryonly
"});
806 my $dummy = bless {}, "Girocco
::Project
";
807 $dummy->{path} = "$projdir";
808 $dummy->{configfilehash} = \%config;
809 $dummy->_properties_load;
810 delete $dummy->{origurl};
811 foreach my $k (keys(%$dummy)) {
812 $newproj->{$k} = $dummy->{$k}
813 if exists($dummy->{$k}) && !exists($newproj->{$k});
818 my %info = %$newproj;
819 $info{README} = get_readme_desc($info{README}) if exists($info{README});
820 my $d = Data::Dumper->new([\%info], ['*'.$newproj->{name}]);
821 $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
822 print $d->Dump([\%info], ['*'.$newproj->{name}]);
826 # Make any changes as needed for @needskip, $neednoprune and $needfakeorigin
828 git_config($projdir, "fetch
.prune
", "false
") if $neednoprune;
829 git_config($projdir, "remote
.origin
.skipDefaultUpdate
", "true
") if $needfakeorigin;
830 if ($usingall && @needskip) {
831 git_config($projdir, "remote
.$_.skipDefaultUpdate
", "true
") foreach @needskip;
835 # Perform the actual adoption
836 $newproj->adopt or die "Girocco
::Project
::adopt failed
\n";
838 # Perhaps restore core.logAllRefUpdates, receive.denyNonFastForwards and receive.denyDeleteCurrent
839 git_config($projdir, "receive
.denyNonFastForwards
", "true
")
840 if git_bool($config{"receive
.denynonfastforwards
"});
841 git_config($projdir, "receive
.denyDeleteCurrent
", $config{"receive
.denydeletecurrent
"})
842 if exists($config{"receive
.denydeletecurrent
"}) &&
843 $config{"receive
.denydeletecurrent
"} ne "warn";
844 git_config($projdir, "core
.logAllRefUpdates
", "true
")
849 warn "Mirror project
\"$projname\" successfully adopted
.\n" unless $quiet;
851 warn "Push project
\"$projname\" successfully adopted
.\n" unless $quiet;
857 my ($force, $reallydel, $keepforks);
858 parse_options(force => \$force, "really
-delete" => \$reallydel,
859 "keep
-forks
" => \$keepforks, quiet => \$quiet, q =>\$quiet);
860 @ARGV or die "Please give project name on command line
.\n";
861 @ARGV == 1 or die_usage;
862 my $project = get_project($ARGV[0]);
863 my $projname = $project->{name};
864 my $isempty = !$project->{mirror} && $project->is_empty;
865 if (!$project->{mirror} && !$isempty && $reallydel) {
866 die "refusing to remove
and delete non
-empty
push project without
--force
: $projname\n" unless $force;
867 warn "allowing removal
and deletion of non
-empty
push project with
--force
\n" unless $quiet;
871 if ($project->has_forks) {
872 die "refusing to remove project with forks
(use --keep
-forks
): $projname\n" unless $keepforks;
873 warn "allowing removal of forked project
while preserving its forks with
--keep
-forks
\n" unless $quiet;
874 # Run pseudo GC on that repository so that objects don't get lost within forks
875 my $basedir = $Girocco::Config::basedir;
876 my $projdir = $project->{path};
877 warn "We have to run pseudo GC on the repo so that the forks don
't lose data. Hang on...\n" unless $quiet;
878 my $nogcrunning = sub {
879 die "Error: GC appears to be currently running on $projname\n"
880 if -e "$projdir/gc.pid" || -e "$projdir/.gc_in_progress";
883 $removenogc = ! -e "$projdir/.nogc";
884 recreate_file("$projdir/.nogc") if $removenogc;
885 die "unable to create \"$projdir/.nogc\"\n" unless -e "$projdir/.nogc";
886 delete $ENV{show_progress};
887 $ENV{'show_progress
'} = 1 unless $quiet;
890 system("$basedir/toolbox/perform-pre-gc-linking.sh", "--include-packs", $projname) == 0
891 or die "Running pseudo GC on project $projname failed\n";
895 if (!$project->{mirror} && !$isempty && !$reallydel) {
896 $archived = $project->archive_and_delete;
897 unlink("$archived/.nogc") if $removenogc && defined($archived) && $archived ne "";
901 warn "Project '$projname' removed from $Girocco::Config::name" .
902 ($archived ? ", backup in '$archived'" : "") .".\n" unless $quiet;
903 warn "Retained forks may now have unwanted objects/info/alternates lines\n" if $altwarn && !$quiet;
909 @ARGV == 1 or die_usage;
910 my $project = get_clean_project($ARGV[0]);
911 my %info = %$project;
912 my $d = Data::Dumper->new([\%info], ['*'.$project->{name}]);
913 $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
914 print $d->Dump([\%info], ['*'.$project->{name}]);
919 @ARGV == 1 or die_usage;
920 my $project = get_project($ARGV[0]);
921 my @heads = sort({lc($a) cmp lc($b)} $project->get_heads);
922 my $cur = $project->{HEAD};
923 defined($cur) or $cur = '';
925 my $headhash = get_git("--git-dir=$project->{path}", 'rev
-parse
', '--quiet
', '--verify
', 'HEAD
');
926 defined($headhash) or $headhash = '';
928 $headhash or $curmark = '!';
930 my $mark = $_ eq $cur ? $curmark : ' ';
938 shift(@ARGV), $vcnt=1 if @ARGV && ($ARGV[0] eq '--verbose
' || $ARGV[0] eq '-v
');
939 @ARGV == 1 or die_usage;
940 my $project = get_project($ARGV[0]);
942 print map("$$_[0]\t$$_[1]\n", get_ctag_counts($project));
944 print map("$_\n", $project->get_ctag_names);
951 shift(@ARGV), $ic=1 if @ARGV && $ARGV[0] =~ /^(?:--?ignore-case|-i)$/i;
952 @ARGV >= 2 or die_usage;
953 my $project = get_project(shift @ARGV);
956 push(@{$curtags{lc($_)}}, $_) foreach $project->get_ctag_names;
958 push(@{$curtags{$_}}, $_) foreach $project->get_ctag_names;
962 my $ctags = join(" ", @ARGV);
963 $ctags = lc($ctags) if $ic;
964 foreach (split(/[\s,]+/, $ctags)) {
965 next unless exists($curtags{$_});
966 $seentag{$_}=1, push(@deltags, $_) unless $seentag{$_};
969 warn $project->{name}, ": skipping removal of only non-existent tags\n" unless $quiet;
971 # Avoid touching anything other than the ctags
972 foreach my $tg (@deltags) {
973 $project->delete_ctag($_) foreach @{$curtags{$tg}};
975 $project->_set_changed;
976 $project->_set_forkchange;
977 warn $project->{name}, ": specified tags have been removed\n" unless $quiet;
983 @ARGV >= 2 or die_usage;
984 my $project = get_project(shift @ARGV);
985 my $ctags = join(" ", @ARGV);
986 $ctags =~ /[^, a-zA-Z0-9:.+#_-]/ and
987 die "Content tag(s) \"$ctags\" contain(s) evil character(s).\n";
988 my $oldmask = umask();
989 umask($oldmask & ~0060);
991 foreach (split(/[\s,]+/, $ctags)) {
992 ++$changed if $project->add_ctag($_, 1);
995 $project->_set_changed;
996 $project->_set_forkchange;
999 my $cnt = ($changed == 1) ? "1 content tag has" : $changed . " content tags have";
1000 warn $project->{name}, ": $cnt been added/updated\n" unless $quiet;
1004 sub _get_random_val {
1009 $md5 = md5_hex(time . $$ . rand() . join(':',%$p));
1016 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force
';
1018 pop(@ARGV), $random=lc($ARGV[1]) if @ARGV==2 && $ARGV[1] =~ /^(?:random|unknown)$/i;
1019 @ARGV == 1 or die_usage;
1020 my $project = get_project($ARGV[0]);
1021 die "refusing to change locked password of project \"$ARGV[0]\" without --force\n"
1022 if $project->is_password_locked;
1025 if ($random eq "random") {
1026 die "refusing to set random password without --force\n" unless $force;
1027 $rmsg = "set to random value";
1028 $newpw = _get_random_val($project);
1030 die "refusing to set password hash to '$random' without --force\n" unless $force;
1031 $rmsg = "hash set to '$random'";
1037 print "Changing admin password for project $ARGV[0]\n";
1038 my $np1 = prompt_noecho_nl_or_die("New password for project $ARGV[0] (echo is off)");
1039 $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1040 my $np2 = prompt_noecho_nl_or_die("Retype new password for project $ARGV[0]");
1041 $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
1042 "the admin passwords you have entered do not match each other.\n";
1046 defined($newpw) or die "missing new password on STDIN\n";
1050 $newpw ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1051 my $old = $project->{crypt};
1052 $project->{crypt} = (defined($random) && $random ne "random") ? $newpw : scrypt_sha1($newpw);
1053 if (defined($old) && $old eq $project->{crypt}) {
1054 warn $project->{name}, ": skipping update of password hash to same value\n" unless $quiet;
1056 # Avoid touching anything other than the password hash
1057 $project->_group_update;
1058 warn $project->{name}, ": admin password $rmsg (new hash stored)\n" unless $quiet;
1064 @ARGV == 1 or die_usage;
1065 my $project = get_project($ARGV[0]);
1066 my $pwhash = $project->{crypt};
1067 defined($pwhash) or $pwhash = "";
1068 if ($pwhash eq "") {
1069 warn $project->{name}, ": no password required\n" unless $quiet;
1072 if ($project->is_password_locked) {
1073 warn $project->{name}, ": password is locked\n" unless $quiet;
1078 $checkpw = prompt_noecho_nl_or_die("Admin password for project $ARGV[0] (echo is off)");
1079 $checkpw ne "" or warn "checking for empty password as hash (very unlikely)\n" unless $quiet;
1082 defined($checkpw) or die "missing admin password on STDIN\n";
1085 unless (Girocco::CLIUtil::check_passwd_match($pwhash, $checkpw)) {
1086 warn "password check failure\n" unless $quiet;
1089 warn "admin password match\n" unless $quiet;
1095 parse_options(force => \$force, quiet => \$quiet, q =>\$quiet);
1096 @ARGV or die "Please give project name on command line.\n";
1097 @ARGV == 1 or die_usage;
1098 my $project = get_project($ARGV[0]);
1099 $project->{mirror} or die "Project \"$ARGV[0]\" is a push project, not a mirror project.\n";
1100 if ($project->{clone_in_progress} && !$project->{clone_failed}) {
1101 warn "Project \"$ARGV[0]\" already seems to have a clone underway at this moment.\n" unless $quiet && $force;
1102 exit(255) unless $force;
1103 yes_to_continue_or_die("Are you sure you want to force a remirror");
1105 unlink($project->_clonefail_path);
1106 unlink($project->_clonelog_path);
1107 recreate_file($project->_clonep_path);
1108 my $sock = IO::Socket::UNIX->new($Girocco::Config::chroot.'/etc/taskd
.socket') or
1109 die "cannot connect to taskd.socket: $!\n";
1110 select((select($sock),$|=1)[0]);
1111 $sock->print("clone ".$project->{name}."\n");
1112 # Just ignore reply, we are going to succeed anyway and the I/O
1113 # would apparently get quite hairy.
1117 warn "Project \"$ARGV[0]\" remirror initiated.\n" unless $quiet;
1123 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force
';
1124 @ARGV == 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1125 my $project = get_project($ARGV[0]);
1126 if (@ARGV == 2 && !valid_email($ARGV[1])) {
1127 die "invalid owner/email (use --force to accept): \"$ARGV[1]\"\n"
1129 warn "using invalid owner/email with --force\n" unless $quiet;
1131 if (@ARGV == 2 && length($ARGV[1]) > 96) {
1132 die "owner/email longer than 96 chars (use --force to accept): \"$ARGV[1]\"\n"
1134 warn "using longer than 96 char owner/email with --force\n" unless $quiet;
1136 my $old = $project->{email};
1138 print "$old\n" if defined($old);
1141 if (defined($old) && $old eq $ARGV[1]) {
1142 warn $project->{name}, ": skipping update of owner/email to same value\n" unless $quiet;
1144 # Avoid touching anything other than "gitweb.owner"
1145 $project->_property_fput("email", $ARGV[1]);
1146 $project->_update_index;
1147 $project->_set_changed;
1148 warn $project->{name}, ": owner/email updated to \"$ARGV[1]\"\n" unless $quiet;
1155 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force
';
1156 @ARGV >= 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1157 my $project = get_project(shift @ARGV);
1158 if (@ARGV && !valid_desc(join(" ", @ARGV))) {
1159 die "invalid description (use --force to accept): \"".join(" ", @ARGV)."\"\n"
1161 warn "using invalid description with --force\n" unless $quiet;
1163 my $desc = clean_desc(join(" ", @ARGV));
1164 if (@ARGV && length($desc) > 1024) {
1165 die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
1167 warn "using longer than 1024 char description with --force\n" unless $quiet;
1169 my $old = $project->{desc};
1171 print "$old\n" if defined($old);
1174 if (defined($old) && $old eq $desc) {
1175 warn $project->{name}, ": skipping update of description to same value\n" unless $quiet;
1177 # Avoid touching anything other than description file
1178 $project->_property_fput("desc", $desc);
1179 $project->_set_changed;
1180 warn $project->{name}, ": description updated to \"$desc\"\n" unless $quiet;
1187 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force
';
1188 @ARGV == 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1189 my $project = get_project($ARGV[0]);
1190 my $old = $project->{README};
1192 chomp $old if defined($old);
1193 print "$old\n" if defined($old) && $old ne "";
1196 my ($new, $raw, $newname);
1198 if ($ARGV[1] eq "-") {
1202 $newname = "contents of <STDIN>";
1203 } elsif (lc($ARGV[1]) eq "automatic" || lc($ARGV[1]) eq "auto") {
1205 } elsif (lc($ARGV[1]) eq "suppressed" || lc($ARGV[1]) eq "suppress") {
1206 $new = "<!-- suppress -->";
1210 die "missing filename for README\n" unless $fn ne "";
1211 die "no such file: \"$fn\"\n" unless -f $fn && -r $fn;
1212 open F, '<', $fn or die "cannot open \"$fn\" for reading: $!\n";
1217 $newname = "contents of \"$fn\"";
1219 defined($new) or $new = '';
1220 $project->{README} = to_utf8($new, 1);
1221 $project->_cleanup_readme;
1222 if (length($project->{README}) > 8192) {
1223 die "readme greater than 8192 chars is too long (use --force to override)\n"
1225 warn "using readme greater than 8192 chars with --force\n" unless $quiet;
1228 my $rd = get_readme_desc($project->{README});
1229 if ($rd ne "automatic" && $rd ne "suppressed") {
1230 my $xmllint = qx(command -v xmllint); chomp $xmllint;
1231 if (-f $xmllint && -x $xmllint) {
1232 my ($cnt, $err) = $project->_lint_readme(0);
1234 my $msg = "xmllint: $cnt error";
1235 $msg .= "s" unless $cnt == 1;
1236 print STDERR "$msg\n", "-" x length($msg), "\n", $err
1237 unless $force && $quiet;
1238 exit(255) unless $force;
1239 warn $project->{name} . ": using invalid raw HTML with --force\n" unless $quiet;
1242 die "xmllint not available, refusing to use raw HTML without --force\n"
1244 warn "xmllint not available using unchecked raw HTML with --force\n" unless $quiet;
1248 if (defined($old) && $old eq $project->{README}) {
1249 warn $project->{name}, ": skipping update of README to same value\n" unless $quiet;
1251 # Avoid touching anything other than README.html file
1252 $project->_property_fput("README", $project->{README});
1253 $project->_set_changed;
1254 my $desc = get_readme_desc($project->{README});
1256 $newname .= " ($desc)";
1260 warn $project->{name}, ": README updated to $newname\n" unless $quiet;
1266 my ($proj, $newhead) = @_;
1267 my %okheads = map({($_ => 1)} $proj->get_heads);
1268 exists($okheads{$newhead});
1272 @ARGV == 2 || (@ARGV == 1 && !$setopt) or die_usage;
1273 my $project = get_project($ARGV[0]);
1274 if (@ARGV == 2 && !valid_head($project, $ARGV[1])) {
1275 die "invalid head (try \"@{[basename($0)]} listheads $ARGV[0]\"): \"$ARGV[1]\"\n";
1277 my $old = $project->{HEAD};
1279 print "$old\n" if defined($old);
1282 if (defined($old) && $old eq $ARGV[1]) {
1283 warn $project->{name}, ": skipping update of HEAD symref to same value\n" unless $quiet;
1285 # Avoid touching anything other than the HEAD symref
1286 $project->set_HEAD($ARGV[1]);
1287 warn $project->{name}, ": HEAD symref updated to \"refs/heads/$ARGV[1]\"\n" unless $quiet;
1304 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force
';
1305 @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1306 my $project = get_project($ARGV[0]);
1307 if (!exists($boolfields{$ARGV[1]})) {
1308 die "invalid boolean field name: \"$ARGV[1]\" -- try \"help\"\n";
1310 if (@ARGV == 3 && $boolfields{$ARGV[1]} && !$project->{mirror}) {
1311 die "invalid boolean field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
1313 warn "using mirror field on non-mirror with --force\n" unless $quiet;
1315 if (@ARGV == 3 && !valid_bool($ARGV[2])) {
1316 die "invalid boolean value: \"$ARGV[2]\"\n";
1318 my $bool = clean_bool($ARGV[2]);
1319 my $old = $project->{$ARGV[1]};
1321 print "$old\n" if defined($old);
1324 if (defined($old) && $old eq $bool) {
1325 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
1327 # Avoid touching anything other than $ARGV[1] field
1328 $project->_property_fput($ARGV[1], $bool);
1329 warn $project->{name}, ": $ARGV[1] updated to $bool\n" unless $quiet;
1335 my ($url, $type) = @_;
1336 $type ne 'baseurl
' and return valid_web_url($url);
1337 valid_repo_url($url) or return 0;
1338 if ($Girocco::Config::restrict_mirror_hosts) {
1339 my $mh = extract_url_hostname($url);
1340 is_dns_hostname($mh) or return 0;
1341 !is_our_hostname($mh) or return 0;
1349 baseurl => ["url" , 1],
1350 homepage => ["hp" , 0],
1351 notifyjson => ["notifyjson", 0],
1357 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force
';
1358 @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1359 my $project = get_project($ARGV[0]);
1360 if (!exists($urlfields{$ARGV[1]})) {
1361 die "invalid URL field name: \"$ARGV[1]\" -- try \"help\"\n";
1363 if (@ARGV == 3 && ${$urlfields{$ARGV[1]}}[1] && !$project->{mirror}) {
1364 die "invalid URL field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
1366 warn "using mirror field on non-mirror with --force\n" unless $quiet;
1368 if (@ARGV == 3 && !valid_url($ARGV[2], $ARGV[1])) {
1369 die "invalid URL (use --force to accept): \"$ARGV[2]\"\n"
1371 warn "using invalid URL with --force\n" unless $quiet;
1373 my $old = $project->{${$urlfields{$ARGV[1]}}[0]};
1375 print "$old\n" if defined($old);
1378 if (defined($old) && $old eq $ARGV[2]) {
1379 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
1381 # Avoid touching anything other than $ARGV[1]'s field
1382 $project->_property_fput(${$urlfields{$ARGV[1]}}[0], $ARGV[2]);
1383 if ($ARGV[1] eq "baseurl") {
1384 $project->{url
} = $ARGV[2];
1385 $project->_set_bangagain;
1387 $project->_set_changed unless $ARGV[1] eq "notifyjson";
1388 warn $project->{name
}, ": $ARGV[1] updated to $ARGV[2]\n" unless $quiet;
1403 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1404 @ARGV >= 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage
;
1405 my $project = get_project
(shift @ARGV);
1406 my $field = shift @ARGV;
1407 if (!exists($msgsfields{$field})) {
1408 die "invalid msgs field name: \"$field\" -- try \"help\"\n";
1410 if (@ARGV && !valid_addrlist
(@ARGV)) {
1411 die "invalid email address list (use --force to accept): \"".join(" ",@ARGV)."\"\n"
1413 warn "using invalid email address list with --force\n" unless $quiet;
1415 my $old = $project->{$field};
1417 printf "%s\n", clean_addrlist
($old, " ") if defined($old);
1420 my $newlist = clean_addrlist
(join(" ",@ARGV));
1421 if (defined($old) && $old eq $newlist) {
1422 warn $project->{name
}, ": skipping update of $field to same value\n" unless $quiet;
1424 # Avoid touching anything other than $field's field
1425 $project->_property_fput($field, $newlist);
1426 warn $project->{name
}, ": $field updated to \"$newlist\"\n" unless $quiet;
1433 shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1434 @ARGV >= 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage
;
1435 my $project = get_project
(shift @ARGV);
1436 my $projname = $project->{name
};
1437 !@ARGV || !$project->{mirror
} or die "cannot set users list for mirror project: \"$projname\"\n";
1440 eval {@newusers = validate_users
(join(" ", @ARGV), $force); 1;} or exit 255;
1441 die "refusing to set empty users list without --force\n" unless @newusers || $force;
1443 return 0 if !@ARGV && $project->{mirror
};
1444 my $oldusers = $project->{users
};
1445 if ($oldusers && ref($oldusers) eq "ARRAY") {
1446 $oldusers = join("\n", @
$oldusers);
1451 print "$oldusers\n" if $oldusers ne "";
1454 if ($oldusers eq join("\n", @newusers)) {
1455 warn "$projname: skipping update of users list to same value\n" unless $quiet;
1457 # Avoid touching anything other than the users list
1458 $project->{users
} = \
@newusers;
1459 $project->_update_users;
1460 warn "$projname: users list updated to \"@{[join(',',@newusers)]}\"\n" unless $quiet;
1468 owner
=> [\
&cmd_setowner
, 0],
1469 desc
=> [\
&cmd_setdesc
, 0],
1470 description
=> [\
&cmd_setdesc
, 0],
1471 readme
=> [\
&cmd_setreadme
, 0],
1472 head
=> [\
&cmd_sethead
, 0],
1473 HEAD
=> [\
&cmd_sethead
, 0],
1474 cleanmirror
=> [\
&cmd_setbool
, 1],
1475 reverseorder
=> [\
&cmd_setbool
, 1],
1476 summaryonly
=> [\
&cmd_setbool
, 1],
1477 statusupdates
=> [\
&cmd_setbool
, 1],
1478 baseurl
=> [\
&cmd_seturl
, 1],
1479 homepage
=> [\
&cmd_seturl
, 1],
1480 notifyjson
=> [\
&cmd_seturl
, 1],
1481 notifymail
=> [\
&cmd_setmsgs
, 1],
1482 notifytag
=> [\
&cmd_setmsgs
, 1],
1483 users
=> [\
&cmd_setusers
, 0],
1490 push(@newargs, shift) if @_ && $_[0] eq '--force';
1492 (($setopt && @_ >= 3) || @_ == 2) && exists($fieldnames{$field}) or die_usage
;
1493 push(@newargs, shift);
1494 shift unless ${$fieldnames{$field}}[1];
1496 diename
(($setopt ?
"set " : "get ") . $field);
1498 &{${$fieldnames{$field}}[0]}(@ARGV);
1513 create
=> \
&cmd_create
,
1514 adopt
=> \
&cmd_adopt
,
1515 remove
=> \
&cmd_remove
,
1516 trash
=> \
&cmd_remove
,
1517 delete => \
&cmd_remove
,
1519 listheads
=> \
&cmd_listheads
,
1520 listtags
=> \
&cmd_listtags
,
1521 listctags
=> \
&cmd_listtags
,
1522 deltags
=> \
&cmd_deltags
,
1523 delctags
=> \
&cmd_deltags
,
1524 addtags
=> \
&cmd_addtags
,
1525 addctags
=> \
&cmd_addtags
,
1526 chpass
=> \
&cmd_chpass
,
1527 checkpw
=> \
&cmd_checkpw
,
1528 remirror
=> \
&cmd_remirror
,
1529 setowner
=> \
&cmd_setowner
,
1530 setdesc
=> \
&cmd_setdesc
,
1531 setdescription
=> \
&cmd_setdesc
,
1532 setreadme
=> \
&cmd_setreadme
,
1533 sethead
=> \
&cmd_sethead
,
1534 setbool
=> \
&cmd_setbool
,
1535 setflag
=> \
&cmd_setbool
,
1536 seturl
=> \
&cmd_seturl
,
1537 setmsgs
=> \
&cmd_setmsgs
,
1538 setusers
=> \
&cmd_setusers
,
1545 my $bn = basename
($0);
1546 printf "%s version %s\n\n", $bn, $VERSION;
1553 shift, $quiet=1 if @ARGV && $ARGV[0] =~ /^(?:-q|--quiet)$/i;
1554 dohelp
if !@ARGV || @ARGV && $ARGV[0] =~ /^(?:-h|-?-help|help)$/i;
1555 my $command = shift;
1558 if (!exists($commands{$command}) && exists($commands{"set".$command})) {
1560 $command = "set" . $command;
1562 exists($commands{$command}) or die "Unknown command \"$command\" -- try \"help\"\n";
1563 dohelp
if @ARGV && $ARGV[0] =~ /^(?:-h|-?-help|help)$/i && !Girocco
::Project
::does_exist
("help",1);
1564 &{$commands{$command}}(@ARGV);