1 | #!/usr/bin/perl |
---|
2 | |
---|
3 | # Script to help generate find the .scripts-version files |
---|
4 | |
---|
5 | use LockFile::Simple qw(trylock unlock); |
---|
6 | use File::stat; |
---|
7 | |
---|
8 | use lib '/mit/scripts/sec-tools/perl'; |
---|
9 | |
---|
10 | open(FILE, "</mit/scripts/sec-tools/store/scriptslist"); |
---|
11 | my $dump = "/mit/scripts/sec-tools/store/versions"; |
---|
12 | my $dumpbackup = "/mit/scripts/sec-tools/store/versions-backup"; |
---|
13 | |
---|
14 | # try to grab a lock on the version directory |
---|
15 | trylock($dump) || die "Can't acquire lock; lockfile already exists at <$dump.lock>. Another parallel-find may be running. If you are SURE there is not, remove the lock file and retry."; |
---|
16 | |
---|
17 | sub unlock_and_die ($) { |
---|
18 | my $msg = shift; |
---|
19 | unlock($dump); |
---|
20 | die $msg; |
---|
21 | } |
---|
22 | |
---|
23 | # if the versions directory exists, move it to versions-backup |
---|
24 | # (removing the backup directory if necessary). Then make a new copy. |
---|
25 | if (-e $dump){ |
---|
26 | if (-e $dumpbackup){ |
---|
27 | system("rm -rf $dumpbackup") && unlock_and_die "Can't remove old backup directory $dumpbackup"; |
---|
28 | } |
---|
29 | system("mv", $dump, $dumpbackup) && unlock_and_die "Unable to back up current directory $dump"; |
---|
30 | } |
---|
31 | system("mkdir", $dump) && unlock_and_die "mkdir failed to create $dump"; |
---|
32 | |
---|
33 | use Proc::Queue size => 40, debug => 0, trace => 0; |
---|
34 | use POSIX ":sys_wait_h"; # imports WNOHANG |
---|
35 | |
---|
36 | # this loop creates new childs, but Proc::Queue makes it wait every |
---|
37 | # time the limit (50) is reached until enough childs exit |
---|
38 | |
---|
39 | # Note that we miss things where one volume is inside another if we |
---|
40 | # use -xdev. May miss libraries stuff. |
---|
41 | |
---|
42 | sub updatable ($) { |
---|
43 | my $filename = shift; |
---|
44 | for my $l (`fs la "$filename"`) { |
---|
45 | return 1 if ($l =~ /^ system:scripts-security-upd rlidwk/); |
---|
46 | } |
---|
47 | return 0; |
---|
48 | } |
---|
49 | |
---|
50 | sub old_version ($) { |
---|
51 | my $dirname = shift; |
---|
52 | open my $h, "$dirname/.scripts-version"; |
---|
53 | return (<$h>)[-1]; |
---|
54 | } |
---|
55 | |
---|
56 | sub version ($) { |
---|
57 | my $dirname = shift; |
---|
58 | $uid = stat($dirname)->uid; |
---|
59 | open my $h, "sudo -u#$uid git --git-dir=$dirname/.git describe --tags 2>/dev/null |"; |
---|
60 | chomp($val = <$h>); |
---|
61 | if (! $val) { |
---|
62 | print "Failed to read value for $dirname\n" |
---|
63 | } |
---|
64 | return $val; |
---|
65 | } |
---|
66 | |
---|
67 | sub find ($$) { |
---|
68 | my $user = shift; |
---|
69 | my $homedir = shift; |
---|
70 | |
---|
71 | open my $files, "find $homedir/web_scripts -xdev -name .scripts-version -o -name .scripts 2>/dev/null |"; |
---|
72 | open my $out, ">$dump/$user"; |
---|
73 | while (my $f = <$files>) { |
---|
74 | chomp $f; |
---|
75 | my $new_style; |
---|
76 | $new_style = ($f =~ s!/\.scripts$!!); |
---|
77 | if (! $new_style) { |
---|
78 | $f =~ s!/\.scripts-version$!!; |
---|
79 | } |
---|
80 | if (! updatable($f)) { |
---|
81 | print STDERR "not updatable: $f"; |
---|
82 | next; |
---|
83 | } |
---|
84 | $v = $new_style ? version($f) : old_version($f); |
---|
85 | print $out "$f:$v"; |
---|
86 | } |
---|
87 | return 0; |
---|
88 | } |
---|
89 | |
---|
90 | while (<FILE>) { |
---|
91 | my ($user, $homedir) = /^([^ ]*) (.*)$/; |
---|
92 | my $f=fork; |
---|
93 | if(defined ($f) and $f==0) { |
---|
94 | if ($homedir !~ m|^/afs/athena| && $homedir !~ m|^/afs/sipb| && $homedir !~ m|^/afs/zone|) { |
---|
95 | print "ignoring foreign-cell $user $homedir\n"; |
---|
96 | exit(0); |
---|
97 | } |
---|
98 | print "$user\n"; |
---|
99 | $ret = find($user, $homedir); |
---|
100 | sleep rand 1; |
---|
101 | exit($ret); |
---|
102 | } |
---|
103 | 1 while waitpid(-1, WNOHANG)>0; # avoids memory leaks in Proc::Queue |
---|
104 | } |
---|
105 | |
---|
106 | unlock($dump); |
---|
107 | 1; |
---|