fixed up several broken URLs (minor but annoying)
[gitolite.git] / src / lib / Gitolite / Conf / Sugar.pm
blob5c743d39543e3f17612cf25d343742f056574979
1 # and now for something completely different...
3 package SugarBox;
5 sub run_sugar_script {
6 my ( $ss, $lref ) = @_;
7 do $ss if -r $ss;
8 $lref = sugar_script($lref);
9 return $lref;
12 # ----------------------------------------------------------------------
14 package Gitolite::Conf::Sugar;
16 # syntactic sugar for the conf file, including site-local macros
17 # ----------------------------------------------------------------------
19 @EXPORT = qw(
20 sugar
23 use Exporter 'import';
25 use Gitolite::Rc;
26 use Gitolite::Common;
27 use Gitolite::Conf::Explode;
29 use strict;
30 use warnings;
32 # ----------------------------------------------------------------------
34 sub sugar {
35 # gets a filename, returns a listref
37 my @lines = ();
38 explode( shift, 'master', \@lines );
40 my $lines;
41 $lines = \@lines;
43 # run through the sugar stack one by one
45 # first, user supplied sugar:
46 if ( exists $rc{SYNTACTIC_SUGAR} ) {
47 if ( ref( $rc{SYNTACTIC_SUGAR} ) ne 'ARRAY' ) {
48 _warn "bad syntax for specifying sugar scripts; see docs";
49 } else {
50 for my $s ( @{ $rc{SYNTACTIC_SUGAR} } ) {
52 # perl-ism; apart from keeping the full path separate from the
53 # simple name, this also protects %rc from change by implicit
54 # aliasing, which would happen if you touched $s itself
55 my $sfp = _which( "syntactic-sugar/$s", 'r' );
57 _warn("skipped sugar script '$s'"), next if not -r $sfp;
58 $lines = SugarBox::run_sugar_script( $sfp, $lines );
59 $lines = [ grep /\S/, map { cleanup_conf_line($_) } @$lines ];
64 # then our stuff:
66 $lines = rw_cdm($lines);
67 $lines = option($lines); # must come after rw_cdm
68 $lines = owner_desc($lines);
69 $lines = name_vref($lines);
70 $lines = role_names($lines);
71 $lines = skip_block($lines);
73 return $lines;
76 sub rw_cdm {
77 my $lines = shift;
78 my @ret;
80 # repo foo <...> RWC = ...
81 # -> option CREATE_IS_C = 1
82 # (and similarly DELETE_IS_D and MERGE_CHECK)
83 # but only once per repo of course
85 my %seen = ();
86 for my $line (@$lines) {
87 push @ret, $line;
88 if ( $line =~ /^repo / ) {
89 %seen = ();
90 } elsif ( $line =~ /^(-|C|R|RW\+?(?:C?D?|D?C?)M?) (.* )?= (.+)/ ) {
91 my $perms = $1;
92 push @ret, "option DELETE_IS_D = 1" if $perms =~ /D/ and not $seen{D}++;
93 push @ret, "option CREATE_IS_C = 1" if $perms =~ /RW.*C/ and not $seen{C}++;
94 push @ret, "option MERGE_CHECK = 1" if $perms =~ /M/ and not $seen{M}++;
97 return \@ret;
100 sub option {
101 my $lines = shift;
102 my @ret;
104 # option foo = bar
105 # -> config gitolite-options.foo = bar
107 for my $line (@$lines) {
108 $line =~ s/option mirror\.slaves/option mirror.copies/;
109 if ( $line =~ /^option (\S+) = (\S.*)/ ) {
110 push @ret, "config gitolite-options.$1 = $2";
111 } else {
112 push @ret, $line;
115 return \@ret;
118 sub owner_desc {
119 my $lines = shift;
120 my @ret;
122 # owner = "owner name"
123 # -> config gitweb.owner = owner name
124 # desc = "some long description"
125 # -> config gitweb.description = some long description
126 # category = "whatever..."
127 # -> config gitweb.category = whatever...
129 for my $line (@$lines) {
130 if ( $line =~ /^desc = (\S.*)/ ) {
131 push @ret, "config gitweb.description = $1";
132 } elsif ( $line =~ /^owner = (\S.*)/ ) {
133 push @ret, "config gitweb.owner = $1";
134 } elsif ( $line =~ /^category = (\S.*)/ ) {
135 push @ret, "config gitweb.category = $1";
136 } else {
137 push @ret, $line;
140 return \@ret;
143 sub name_vref {
144 my $lines = shift;
145 my @ret;
147 # <perm> NAME/foo = <user>
148 # -> <perm> VREF/NAME/foo = <user>
150 for my $line (@$lines) {
151 if ( $line =~ /^(-|R\S+) \S.* = \S.*/ ) {
152 $line =~ s( NAME/)( VREF/NAME/)g;
154 push @ret, $line;
156 return \@ret;
159 sub role_names {
160 my $lines = shift;
161 my @ret;
163 # <perm> [<ref>] = <user list containing CREATOR|READERS|WRITERS>
164 # -> same but with "@" prepended to rolenames
166 for my $line (@$lines) {
167 if ( $line =~ /^(-|C|R|RW\+?(?:C?D?|D?C?)M?) (.* )?= (.+)/ ) {
168 my ( $p, $r ) = ( $1, $2 );
169 my $u = '';
170 for ( split ' ', $3 ) {
171 $_ = "\@$_" if $_ eq 'CREATOR' or $rc{ROLES}{$_};
172 $u .= " $_";
174 $r ||= '';
175 # mind the spaces (or play safe and run cleanup_conf_line again)
176 push @ret, cleanup_conf_line("$p $r = $u");
177 } else {
178 push @ret, $line;
181 return \@ret;
184 sub skip_block {
185 my $lines = shift;
187 my @out = ();
188 for (@$lines) {
189 my $skip = 0;
190 $skip = 1 if /^= *begin testconf$/;
191 $skip = 1 if /^= *begin template-data$/;
192 # add code for other types of blocks here as needed
194 next if $skip .. /^= *end$/;
195 push @out, $_;
198 return \@out;