To check out this repository please hg clone the following URL, or open the URL using EasyMercurial or your preferred Mercurial client.

Statistics Download as Zip
| Branch: | Tag: | Revision:

root / extra / soundsoftware @ 1546:248c402992ba

1 7:3c16ed8faa07 Chris
package Apache::Authn::SoundSoftware;
2
3
=head1 Apache::Authn::SoundSoftware
4
5
SoundSoftware - a mod_perl module for Apache authentication against a
6
Redmine database and optional LDAP implementing the access control
7
rules required for the SoundSoftware.ac.uk repository site.
8
9
=head1 SYNOPSIS
10
11
This module is closely based on the Redmine.pm authentication module
12
provided with Redmine.  It is intended to be used for authentication
13
in front of a repository service such as hgwebdir.
14
15
Requirements:
16
17
1. Clone/pull from repo for public project: Any user, no
18
authentication required
19
20
2. Clone/pull from repo for private project: Project members only
21
22
3. Push to repo for public project: "Permitted" users only (this
23 8:0c83d98252d9 Chris
probably means project members who are also identified in the hgrc web
24
section for the repository and so will be approved by hgwebdir?)
25 7:3c16ed8faa07 Chris
26 8:0c83d98252d9 Chris
4. Push to repo for private project: "Permitted" users only (as above)
27 7:3c16ed8faa07 Chris
28 300:034e9b00b341 chris
5. Push to any repo that is tracking an external repo: Refused always
29
30 7:3c16ed8faa07 Chris
=head1 INSTALLATION
31
32
Debian/ubuntu:
33
34
  apt-get install libapache-dbi-perl libapache2-mod-perl2 \
35
    libdbd-mysql-perl libauthen-simple-ldap-perl libio-socket-ssl-perl
36
37
Note that LDAP support is hardcoded "on" in this script (it is
38
optional in the original Redmine.pm).
39
40
=head1 CONFIGURATION
41
42
   ## This module has to be in your perl path
43
   ## eg:  /usr/local/lib/site_perl/Apache/Authn/SoundSoftware.pm
44
   PerlLoadModule Apache::Authn::SoundSoftware
45
46
   # Example when using hgwebdir
47
   ScriptAlias / "/var/hg/hgwebdir.cgi/"
48
49
   <Location />
50
       AuthName "Mercurial"
51
       AuthType Basic
52
       Require valid-user
53
       PerlAccessHandler Apache::Authn::SoundSoftware::access_handler
54
       PerlAuthenHandler Apache::Authn::SoundSoftware::authen_handler
55
       SoundSoftwareDSN "DBI:mysql:database=redmine;host=localhost"
56
       SoundSoftwareDbUser "redmine"
57
       SoundSoftwareDbPass "password"
58
       Options +ExecCGI
59
       AddHandler cgi-script .cgi
60
       ## Optional where clause (fulltext search would be slow and
61
       ## database dependant).
62
       # SoundSoftwareDbWhereClause "and members.role_id IN (1,2)"
63 8:0c83d98252d9 Chris
       ## Optional prefix for local repository URLs
64
       # SoundSoftwareRepoPrefix "/var/hg/"
65 7:3c16ed8faa07 Chris
  </Location>
66
67
See the original Redmine.pm for further configuration notes.
68
69
=cut
70
71
use strict;
72
use warnings FATAL => 'all', NONFATAL => 'redefine';
73
74
use DBI;
75
use Digest::SHA1;
76
use Authen::Simple::LDAP;
77
use Apache2::Module;
78
use Apache2::Access;
79
use Apache2::ServerRec qw();
80
use Apache2::RequestRec qw();
81
use Apache2::RequestUtil qw();
82
use Apache2::Const qw(:common :override :cmd_how);
83
use APR::Pool ();
84
use APR::Table ();
85
86
my @directives = (
87
  {
88
    name => 'SoundSoftwareDSN',
89
    req_override => OR_AUTHCFG,
90
    args_how => TAKE1,
91
    errmsg => 'Dsn in format used by Perl DBI. eg: "DBI:Pg:dbname=databasename;host=my.db.server"',
92
  },
93
  {
94
    name => 'SoundSoftwareDbUser',
95
    req_override => OR_AUTHCFG,
96
    args_how => TAKE1,
97
  },
98
  {
99
    name => 'SoundSoftwareDbPass',
100
    req_override => OR_AUTHCFG,
101
    args_how => TAKE1,
102
  },
103
  {
104
    name => 'SoundSoftwareDbWhereClause',
105
    req_override => OR_AUTHCFG,
106
    args_how => TAKE1,
107
  },
108
  {
109 8:0c83d98252d9 Chris
    name => 'SoundSoftwareRepoPrefix',
110 7:3c16ed8faa07 Chris
    req_override => OR_AUTHCFG,
111
    args_how => TAKE1,
112
  },
113
);
114
115
sub SoundSoftwareDSN {
116 8:0c83d98252d9 Chris
    my ($self, $parms, $arg) = @_;
117
    $self->{SoundSoftwareDSN} = $arg;
118
    my $query = "SELECT
119 7:3c16ed8faa07 Chris
                 hashed_password, auth_source_id, permissions
120
              FROM members, projects, users, roles, member_roles
121
              WHERE
122
                projects.id=members.project_id
123
                AND member_roles.member_id=members.id
124
                AND users.id=members.user_id
125
                AND roles.id=member_roles.role_id
126
                AND users.status=1
127
                AND login=?
128
                AND identifier=? ";
129 8:0c83d98252d9 Chris
    $self->{SoundSoftwareQuery} = trim($query);
130 7:3c16ed8faa07 Chris
}
131
132
sub SoundSoftwareDbUser { set_val('SoundSoftwareDbUser', @_); }
133
sub SoundSoftwareDbPass { set_val('SoundSoftwareDbPass', @_); }
134
sub SoundSoftwareDbWhereClause {
135 8:0c83d98252d9 Chris
    my ($self, $parms, $arg) = @_;
136
    $self->{SoundSoftwareQuery} = trim($self->{SoundSoftwareQuery}.($arg ? $arg : "")." ");
137 7:3c16ed8faa07 Chris
}
138
139 8:0c83d98252d9 Chris
sub SoundSoftwareRepoPrefix {
140
    my ($self, $parms, $arg) = @_;
141
    if ($arg) {
142
	$self->{SoundSoftwareRepoPrefix} = $arg;
143
    }
144 7:3c16ed8faa07 Chris
}
145
146
sub trim {
147 8:0c83d98252d9 Chris
    my $string = shift;
148
    $string =~ s/\s{2,}/ /g;
149
    return $string;
150 7:3c16ed8faa07 Chris
}
151
152
sub set_val {
153 8:0c83d98252d9 Chris
    my ($key, $self, $parms, $arg) = @_;
154
    $self->{$key} = $arg;
155 7:3c16ed8faa07 Chris
}
156
157
Apache2::Module::add(__PACKAGE__, \@directives);
158
159
160
my %read_only_methods = map { $_ => 1 } qw/GET PROPFIND REPORT OPTIONS/;
161
162
sub access_handler {
163 8:0c83d98252d9 Chris
    my $r = shift;
164 7:3c16ed8faa07 Chris
165 152:a389c77da9fd Chris
    print STDERR "SoundSoftware.pm: In access handler at " . scalar localtime() . "\n";
166 7:3c16ed8faa07 Chris
167 8:0c83d98252d9 Chris
    unless ($r->some_auth_required) {
168
	$r->log_reason("No authentication has been configured");
169
	return FORBIDDEN;
170
    }
171 7:3c16ed8faa07 Chris
172 8:0c83d98252d9 Chris
    my $method = $r->method;
173 7:3c16ed8faa07 Chris
174 8:0c83d98252d9 Chris
    print STDERR "SoundSoftware.pm: Method: $method, uri " . $r->uri . ", location " . $r->location . "\n";
175
    print STDERR "SoundSoftware.pm: Accept: " . $r->headers_in->{Accept} . "\n";
176 7:3c16ed8faa07 Chris
177 8:0c83d98252d9 Chris
    my $dbh = connect_database($r);
178 152:a389c77da9fd Chris
    unless ($dbh) {
179
	print STDERR "SoundSoftware.pm: Database connection failed!: " . $DBI::errstr . "\n";
180
	return FORBIDDEN;
181
    }
182
183 300:034e9b00b341 chris
    print STDERR "Connected to db, dbh is " . $dbh . "\n";
184 7:3c16ed8faa07 Chris
185 8:0c83d98252d9 Chris
    my $project_id = get_project_identifier($dbh, $r);
186 300:034e9b00b341 chris
187
    if (!defined $read_only_methods{$method}) {
188
        print STDERR "SoundSoftware.pm: Method is not read-only\n";
189
        if (project_repo_is_readonly($dbh, $project_id, $r)) {
190
            print STDERR "SoundSoftware.pm: Project repo is read-only, refusing access\n";
191
	    return FORBIDDEN;
192
        } else {
193
	    print STDERR "SoundSoftware.pm: Project repo is read-write, authentication handler required\n";
194
            return OK;
195
        }
196
    }
197
198 8:0c83d98252d9 Chris
    my $status = get_project_status($dbh, $project_id, $r);
199 7:3c16ed8faa07 Chris
200 8:0c83d98252d9 Chris
    $dbh->disconnect();
201
    undef $dbh;
202 7:3c16ed8faa07 Chris
203 8:0c83d98252d9 Chris
    if ($status == 0) { # nonexistent
204
	print STDERR "SoundSoftware.pm: Project does not exist, refusing access\n";
205
	return FORBIDDEN;
206
    } elsif ($status == 1) { # public
207
	print STDERR "SoundSoftware.pm: Project is public, no restriction here\n";
208
	$r->set_handlers(PerlAuthenHandler => [\&OK])
209
    } else { # private
210
	print STDERR "SoundSoftware.pm: Project is private, authentication handler required\n";
211
    }
212 7:3c16ed8faa07 Chris
213 8:0c83d98252d9 Chris
    return OK
214 7:3c16ed8faa07 Chris
}
215
216
sub authen_handler {
217 8:0c83d98252d9 Chris
    my $r = shift;
218
219 152:a389c77da9fd Chris
    print STDERR "SoundSoftware.pm: In authentication handler at " . scalar localtime() . "\n";
220 7:3c16ed8faa07 Chris
221 8:0c83d98252d9 Chris
    my $dbh = connect_database($r);
222 152:a389c77da9fd Chris
    unless ($dbh) {
223
        print STDERR "SoundSoftware.pm: Database connection failed!: " . $DBI::errstr . "\n";
224
        return AUTH_REQUIRED;
225
    }
226 8:0c83d98252d9 Chris
227
    my $project_id = get_project_identifier($dbh, $r);
228
    my $realm = get_realm($dbh, $project_id, $r);
229
    $r->auth_name($realm);
230
231
    my ($res, $redmine_pass) =  $r->get_basic_auth_pw();
232
    unless ($res == OK) {
233
	$dbh->disconnect();
234
	undef $dbh;
235
	return $res;
236
    }
237
238
    print STDERR "SoundSoftware.pm: User is " . $r->user . ", got password\n";
239
240
    my $permitted = is_permitted($dbh, $project_id, $r->user, $redmine_pass, $r);
241
242
    $dbh->disconnect();
243
    undef $dbh;
244
245
    if ($permitted) {
246
	return OK;
247
    } else {
248
	print STDERR "SoundSoftware.pm: Not permitted\n";
249
	$r->note_auth_failure();
250
	return AUTH_REQUIRED;
251
    }
252 7:3c16ed8faa07 Chris
}
253
254
sub get_project_status {
255 8:0c83d98252d9 Chris
    my $dbh = shift;
256 7:3c16ed8faa07 Chris
    my $project_id = shift;
257
    my $r = shift;
258 8:0c83d98252d9 Chris
259
    if (!defined $project_id or $project_id eq '') {
260
	return 0; # nonexistent
261
    }
262 7:3c16ed8faa07 Chris
263
    my $sth = $dbh->prepare(
264
        "SELECT is_public FROM projects WHERE projects.identifier = ?;"
265
    );
266
267
    $sth->execute($project_id);
268 8:0c83d98252d9 Chris
    my $ret = 0; # nonexistent
269 7:3c16ed8faa07 Chris
    if (my @row = $sth->fetchrow_array) {
270
    	if ($row[0] eq "1" || $row[0] eq "t") {
271
	    $ret = 1; # public
272
    	} else {
273 8:0c83d98252d9 Chris
	    $ret = 2; # private
274 7:3c16ed8faa07 Chris
	}
275
    }
276
    $sth->finish();
277
    undef $sth;
278
279
    $ret;
280
}
281
282 300:034e9b00b341 chris
sub project_repo_is_readonly {
283
    my $dbh = shift;
284
    my $project_id = shift;
285
    my $r = shift;
286
287
    if (!defined $project_id or $project_id eq '') {
288
        return 0; # nonexistent
289
    }
290
291
    my $sth = $dbh->prepare(
292
        "SELECT repositories.is_external FROM repositories, projects WHERE projects.identifier = ? AND repositories.project_id = projects.id;"
293
    );
294
295
    $sth->execute($project_id);
296
    my $ret = 0; # nonexistent
297
    if (my @row = $sth->fetchrow_array) {
298 301:6d3f8aeb51b7 chris
        if (defined($row[0]) && ($row[0] eq "1" || $row[0] eq "t")) {
299 300:034e9b00b341 chris
            $ret = 1; # read-only (i.e. external)
300
        } else {
301
            $ret = 0; # read-write
302
        }
303
    }
304
    $sth->finish();
305
    undef $sth;
306
307
    $ret;
308
}
309
310 8:0c83d98252d9 Chris
sub is_permitted {
311
    my $dbh = shift;
312
    my $project_id = shift;
313
    my $redmine_user = shift;
314
    my $redmine_pass = shift;
315
    my $r = shift;
316 7:3c16ed8faa07 Chris
317 8:0c83d98252d9 Chris
    my $pass_digest = Digest::SHA1::sha1_hex($redmine_pass);
318 7:3c16ed8faa07 Chris
319 8:0c83d98252d9 Chris
    my $cfg = Apache2::Module::get_config
320
	(__PACKAGE__, $r->server, $r->per_dir_config);
321 7:3c16ed8faa07 Chris
322 8:0c83d98252d9 Chris
    my $query = $cfg->{SoundSoftwareQuery};
323
    my $sth = $dbh->prepare($query);
324
    $sth->execute($redmine_user, $project_id);
325 7:3c16ed8faa07 Chris
326 8:0c83d98252d9 Chris
    my $ret;
327
    while (my ($hashed_password, $auth_source_id, $permissions) = $sth->fetchrow_array) {
328 7:3c16ed8faa07 Chris
329 8:0c83d98252d9 Chris
	# Test permissions for this user before we verify credentials
330
	# -- if the user is not permitted this action anyway, there's
331
	# not much point in e.g. contacting the LDAP
332 7:3c16ed8faa07 Chris
333 8:0c83d98252d9 Chris
	my $method = $r->method;
334 7:3c16ed8faa07 Chris
335 8:0c83d98252d9 Chris
	if ((defined $read_only_methods{$method} && $permissions =~ /:browse_repository/)
336
	    || $permissions =~ /:commit_access/) {
337
338
	    # User would be permitted this action, if their
339
	    # credentials checked out -- test those now
340
341
	    print STDERR "SoundSoftware.pm: User $redmine_user has required role, checking credentials\n";
342
343
	    unless ($auth_source_id) {
344
		if ($hashed_password eq $pass_digest) {
345
		    print STDERR "SoundSoftware.pm: User $redmine_user authenticated via password\n";
346
		    $ret = 1;
347
		    last;
348
		}
349
	    } else {
350
		my $sthldap = $dbh->prepare(
351
		    "SELECT host,port,tls,account,account_password,base_dn,attr_login FROM auth_sources WHERE id = ?;"
352
		    );
353
		$sthldap->execute($auth_source_id);
354
		while (my @rowldap = $sthldap->fetchrow_array) {
355
		    my $ldap = Authen::Simple::LDAP->new(
356
			host    => ($rowldap[2] eq "1" || $rowldap[2] eq "t") ? "ldaps://$rowldap[0]" : $rowldap[0],
357
			port    => $rowldap[1],
358
			basedn  => $rowldap[5],
359
			binddn  => $rowldap[3] ? $rowldap[3] : "",
360
			bindpw  => $rowldap[4] ? $rowldap[4] : "",
361
			filter  => "(".$rowldap[6]."=%s)"
362
			);
363
		    if ($ldap->authenticate($redmine_user, $redmine_pass)) {
364
			print STDERR "SoundSoftware.pm: User $redmine_user authenticated via LDAP\n";
365
			$ret = 1;
366
		    }
367
		}
368
		$sthldap->finish();
369
		undef $sthldap;
370
	    }
371
	} else {
372
	    print STDERR "SoundSoftware.pm: User $redmine_user lacks required role for this project\n";
373
	}
374 7:3c16ed8faa07 Chris
    }
375
376 8:0c83d98252d9 Chris
    $sth->finish();
377
    undef $sth;
378
379
    $ret;
380 7:3c16ed8faa07 Chris
}
381
382
sub get_project_identifier {
383 8:0c83d98252d9 Chris
    my $dbh = shift;
384 7:3c16ed8faa07 Chris
    my $r = shift;
385
386
    my $location = $r->location;
387
    my ($repo) = $r->uri =~ m{$location/*([^/]+)};
388 10:2c10dc5f122d Chris
389
    return $repo if (!$repo);
390
391 7:3c16ed8faa07 Chris
    $repo =~ s/[^a-zA-Z0-9\._-]//g;
392
393 8:0c83d98252d9 Chris
    # The original Redmine.pm returns the string just calculated as
394
    # the project identifier.  That won't do for us -- we may have
395
    # (and in fact already do have, in our test instance) projects
396
    # whose repository names differ from the project identifiers.
397
398
    # This is a rather fundamental change because it means that almost
399
    # every request needs more than one database query -- which
400
    # prompts us to start passing around $dbh instead of connecting
401
    # locally within each function as is done in Redmine.pm.
402
403 7:3c16ed8faa07 Chris
    my $sth = $dbh->prepare(
404
        "SELECT projects.identifier FROM projects, repositories WHERE repositories.project_id = projects.id AND repositories.url LIKE ?;"
405
    );
406
407 8:0c83d98252d9 Chris
    my $cfg = Apache2::Module::get_config
408
	(__PACKAGE__, $r->server, $r->per_dir_config);
409
410
    my $prefix = $cfg->{SoundSoftwareRepoPrefix};
411
    if (!defined $prefix) { $prefix = '%/'; }
412
413 7:3c16ed8faa07 Chris
    my $identifier = '';
414
415 8:0c83d98252d9 Chris
    $sth->execute($prefix . $repo);
416 7:3c16ed8faa07 Chris
    my $ret = 0;
417
    if (my @row = $sth->fetchrow_array) {
418
	$identifier = $row[0];
419
    }
420
    $sth->finish();
421
    undef $sth;
422
423 8:0c83d98252d9 Chris
    print STDERR "SoundSoftware.pm: Repository '$repo' belongs to project '$identifier'\n";
424 7:3c16ed8faa07 Chris
425
    $identifier;
426
}
427
428 8:0c83d98252d9 Chris
sub get_realm {
429
    my $dbh = shift;
430
    my $project_id = shift;
431
    my $r = shift;
432
433
    my $sth = $dbh->prepare(
434
        "SELECT projects.name FROM projects WHERE projects.identifier = ?;"
435
    );
436
437
    my $name = $project_id;
438
439
    $sth->execute($project_id);
440
    my $ret = 0;
441
    if (my @row = $sth->fetchrow_array) {
442
	$name = $row[0];
443
    }
444
    $sth->finish();
445
    undef $sth;
446
447
    # be timid about characters not permitted in auth realm and revert
448
    # to project identifier if any are found
449
    if ($name =~ m/[^\w\d\s\._-]/) {
450
	$name = $project_id;
451
    }
452
453
    my $realm = '"Mercurial repository for ' . "'$name'" . '"';
454
455
    $realm;
456
}
457
458 7:3c16ed8faa07 Chris
sub connect_database {
459
    my $r = shift;
460
461 8:0c83d98252d9 Chris
    my $cfg = Apache2::Module::get_config
462
	(__PACKAGE__, $r->server, $r->per_dir_config);
463
464
    return DBI->connect($cfg->{SoundSoftwareDSN},
465 152:a389c77da9fd Chris
	                $cfg->{SoundSoftwareDbUser},
466
		        $cfg->{SoundSoftwareDbPass});
467 7:3c16ed8faa07 Chris
}
468
469
1;
470
package Apache::Authn::SoundSoftware;
471
472
=head1 Apache::Authn::SoundSoftware
473
474
SoundSoftware - a mod_perl module for Apache authentication against a
475
Redmine database and optional LDAP implementing the access control
476
rules required for the SoundSoftware.ac.uk repository site.
477
478
=head1 SYNOPSIS
479
480
This module is closely based on the Redmine.pm authentication module
481
provided with Redmine.  It is intended to be used for authentication
482
in front of a repository service such as hgwebdir.
483
484
Requirements:
485
486
1. Clone/pull from repo for public project: Any user, no
487
authentication required
488
489
2. Clone/pull from repo for private project: Project members only
490
491
3. Push to repo for public project: "Permitted" users only (this
492 8:0c83d98252d9 Chris
probably means project members who are also identified in the hgrc web
493
section for the repository and so will be approved by hgwebdir?)
494 7:3c16ed8faa07 Chris
495 8:0c83d98252d9 Chris
4. Push to repo for private project: "Permitted" users only (as above)
496 7:3c16ed8faa07 Chris
497 300:034e9b00b341 chris
5. Push to any repo that is tracking an external repo: Refused always
498
499 7:3c16ed8faa07 Chris
=head1 INSTALLATION
500
501
Debian/ubuntu:
502
503
  apt-get install libapache-dbi-perl libapache2-mod-perl2 \
504
    libdbd-mysql-perl libauthen-simple-ldap-perl libio-socket-ssl-perl
505
506
Note that LDAP support is hardcoded "on" in this script (it is
507
optional in the original Redmine.pm).
508
509
=head1 CONFIGURATION
510
511
   ## This module has to be in your perl path
512
   ## eg:  /usr/local/lib/site_perl/Apache/Authn/SoundSoftware.pm
513
   PerlLoadModule Apache::Authn::SoundSoftware
514
515
   # Example when using hgwebdir
516
   ScriptAlias / "/var/hg/hgwebdir.cgi/"
517
518
   <Location />
519
       AuthName "Mercurial"
520
       AuthType Basic
521
       Require valid-user
522
       PerlAccessHandler Apache::Authn::SoundSoftware::access_handler
523
       PerlAuthenHandler Apache::Authn::SoundSoftware::authen_handler
524
       SoundSoftwareDSN "DBI:mysql:database=redmine;host=localhost"
525
       SoundSoftwareDbUser "redmine"
526
       SoundSoftwareDbPass "password"
527
       Options +ExecCGI
528
       AddHandler cgi-script .cgi
529
       ## Optional where clause (fulltext search would be slow and
530
       ## database dependant).
531
       # SoundSoftwareDbWhereClause "and members.role_id IN (1,2)"
532 8:0c83d98252d9 Chris
       ## Optional prefix for local repository URLs
533
       # SoundSoftwareRepoPrefix "/var/hg/"
534 7:3c16ed8faa07 Chris
  </Location>
535
536
See the original Redmine.pm for further configuration notes.
537
538
=cut
539
540
use strict;
541
use warnings FATAL => 'all', NONFATAL => 'redefine';
542
543
use DBI;
544 1331:1e9b1bdd062e Chris
use Digest::SHA;
545 7:3c16ed8faa07 Chris
use Authen::Simple::LDAP;
546
use Apache2::Module;
547
use Apache2::Access;
548
use Apache2::ServerRec qw();
549
use Apache2::RequestRec qw();
550
use Apache2::RequestUtil qw();
551
use Apache2::Const qw(:common :override :cmd_how);
552
use APR::Pool ();
553
use APR::Table ();
554
555
my @directives = (
556
  {
557
    name => 'SoundSoftwareDSN',
558
    req_override => OR_AUTHCFG,
559
    args_how => TAKE1,
560
    errmsg => 'Dsn in format used by Perl DBI. eg: "DBI:Pg:dbname=databasename;host=my.db.server"',
561
  },
562
  {
563
    name => 'SoundSoftwareDbUser',
564
    req_override => OR_AUTHCFG,
565
    args_how => TAKE1,
566
  },
567
  {
568
    name => 'SoundSoftwareDbPass',
569
    req_override => OR_AUTHCFG,
570
    args_how => TAKE1,
571
  },
572
  {
573
    name => 'SoundSoftwareDbWhereClause',
574
    req_override => OR_AUTHCFG,
575
    args_how => TAKE1,
576
  },
577
  {
578 8:0c83d98252d9 Chris
    name => 'SoundSoftwareRepoPrefix',
579 7:3c16ed8faa07 Chris
    req_override => OR_AUTHCFG,
580
    args_how => TAKE1,
581
  },
582 732:897bc2b63bfe Chris
  {
583
    name => 'SoundSoftwareSslRequired',
584
    req_override => OR_AUTHCFG,
585
    args_how => TAKE1,
586
  },
587 7:3c16ed8faa07 Chris
);
588
589
sub SoundSoftwareDSN {
590 8:0c83d98252d9 Chris
    my ($self, $parms, $arg) = @_;
591
    $self->{SoundSoftwareDSN} = $arg;
592
    my $query = "SELECT
593 301:6d3f8aeb51b7 chris
                 hashed_password, salt, auth_source_id, permissions
594 7:3c16ed8faa07 Chris
              FROM members, projects, users, roles, member_roles
595
              WHERE
596
                projects.id=members.project_id
597
                AND member_roles.member_id=members.id
598
                AND users.id=members.user_id
599
                AND roles.id=member_roles.role_id
600
                AND users.status=1
601
                AND login=?
602
                AND identifier=? ";
603 8:0c83d98252d9 Chris
    $self->{SoundSoftwareQuery} = trim($query);
604 7:3c16ed8faa07 Chris
}
605
606
sub SoundSoftwareDbUser { set_val('SoundSoftwareDbUser', @_); }
607
sub SoundSoftwareDbPass { set_val('SoundSoftwareDbPass', @_); }
608
sub SoundSoftwareDbWhereClause {
609 8:0c83d98252d9 Chris
    my ($self, $parms, $arg) = @_;
610
    $self->{SoundSoftwareQuery} = trim($self->{SoundSoftwareQuery}.($arg ? $arg : "")." ");
611 7:3c16ed8faa07 Chris
}
612
613 8:0c83d98252d9 Chris
sub SoundSoftwareRepoPrefix {
614
    my ($self, $parms, $arg) = @_;
615
    if ($arg) {
616
	$self->{SoundSoftwareRepoPrefix} = $arg;
617
    }
618 7:3c16ed8faa07 Chris
}
619
620 732:897bc2b63bfe Chris
sub SoundSoftwareSslRequired { set_val('SoundSoftwareSslRequired', @_); }
621
622 7:3c16ed8faa07 Chris
sub trim {
623 8:0c83d98252d9 Chris
    my $string = shift;
624
    $string =~ s/\s{2,}/ /g;
625
    return $string;
626 7:3c16ed8faa07 Chris
}
627
628
sub set_val {
629 8:0c83d98252d9 Chris
    my ($key, $self, $parms, $arg) = @_;
630
    $self->{$key} = $arg;
631 7:3c16ed8faa07 Chris
}
632
633
Apache2::Module::add(__PACKAGE__, \@directives);
634
635
636
my %read_only_methods = map { $_ => 1 } qw/GET PROPFIND REPORT OPTIONS/;
637
638
sub access_handler {
639 8:0c83d98252d9 Chris
    my $r = shift;
640 7:3c16ed8faa07 Chris
641 517:bd1d512f9e1b Chris
    print STDERR "SoundSoftware.pm:$$: In access handler at " . scalar localtime() . "\n";
642 7:3c16ed8faa07 Chris
643 8:0c83d98252d9 Chris
    unless ($r->some_auth_required) {
644
	$r->log_reason("No authentication has been configured");
645
	return FORBIDDEN;
646
    }
647 7:3c16ed8faa07 Chris
648 8:0c83d98252d9 Chris
    my $method = $r->method;
649 7:3c16ed8faa07 Chris
650 517:bd1d512f9e1b Chris
    print STDERR "SoundSoftware.pm:$$: Method: $method, uri " . $r->uri . ", location " . $r->location . "\n";
651
    print STDERR "SoundSoftware.pm:$$: Accept: " . $r->headers_in->{Accept} . "\n";
652 7:3c16ed8faa07 Chris
653 8:0c83d98252d9 Chris
    my $dbh = connect_database($r);
654 152:a389c77da9fd Chris
    unless ($dbh) {
655 517:bd1d512f9e1b Chris
	print STDERR "SoundSoftware.pm:$$: Database connection failed!: " . $DBI::errstr . "\n";
656 152:a389c77da9fd Chris
	return FORBIDDEN;
657
    }
658
659 300:034e9b00b341 chris
    print STDERR "Connected to db, dbh is " . $dbh . "\n";
660 7:3c16ed8faa07 Chris
661 8:0c83d98252d9 Chris
    my $project_id = get_project_identifier($dbh, $r);
662 300:034e9b00b341 chris
663 732:897bc2b63bfe Chris
    # We want to delegate most of the work to the authentication
664
    # handler (to ensure that user is asked to login even for
665
    # nonexistent projects -- so they can't tell whether a private
666
    # project exists or not without authenticating). So
667
    #
668
    # * if the project is public
669
    #   - if the method is read-only
670
    #     + set handler to OK, no auth needed
671
    #   - if the method is not read-only
672
    #     + if the repo is read-only, return forbidden
673
    #     + else require auth
674
    # * if the project is not public or does not exist
675
    #     + require auth
676
    #
677
    # If we are requiring auth and are not currently https, and
678
    # https is required, then we must return a redirect to https
679
    # instead of an OK.
680 300:034e9b00b341 chris
681 8:0c83d98252d9 Chris
    my $status = get_project_status($dbh, $project_id, $r);
682 732:897bc2b63bfe Chris
    my $readonly = project_repo_is_readonly($dbh, $project_id, $r);
683 7:3c16ed8faa07 Chris
684 8:0c83d98252d9 Chris
    $dbh->disconnect();
685
    undef $dbh;
686 7:3c16ed8faa07 Chris
687 734:1d1b8170c2f7 Chris
    my $auth_ssl_reqd = will_require_ssl_auth($r);
688
689 732:897bc2b63bfe Chris
    if ($status == 1) { # public
690
691
	print STDERR "SoundSoftware.pm:$$: Project is public\n";
692
693
	if (!defined $read_only_methods{$method}) {
694
695
	    print STDERR "SoundSoftware.pm:$$: Method is not read-only\n";
696
697
	    if ($readonly) {
698
		print STDERR "SoundSoftware.pm:$$: Project repo is read-only, refusing access\n";
699
		return FORBIDDEN;
700
	    } else {
701
		print STDERR "SoundSoftware.pm:$$: Project repo is read-write, auth required\n";
702
		# fall through, this is the normal case
703
	    }
704
705 734:1d1b8170c2f7 Chris
        } elsif ($auth_ssl_reqd and $r->unparsed_uri =~ m/cmd=branchmap/) {
706
707
            # A hac^H^H^Hspecial case. We want to ensure we switch to
708
            # https (if it will be necessarily for authentication)
709
            # before the first POST request, and this is what I think
710
            # will give us suitable warning for Mercurial.
711
712
            print STDERR "SoundSoftware.pm:$$: Switching to HTTPS in preparation\n";
713
            # fall through, this is the normal case
714
715 732:897bc2b63bfe Chris
	} else {
716
	    # Public project, read-only method -- this is the only
717
	    # case we can decide for certain to accept in this function
718
	    print STDERR "SoundSoftware.pm:$$: Method is read-only, no restriction here\n";
719
	    $r->set_handlers(PerlAuthenHandler => [\&OK]);
720
	    return OK;
721
	}
722
723
    } else { # status != 1, i.e. nonexistent or private -- equivalent here
724
725
	print STDERR "SoundSoftware.pm:$$: Project is private or nonexistent, auth required\n";
726
	# fall through
727 8:0c83d98252d9 Chris
    }
728 7:3c16ed8faa07 Chris
729 734:1d1b8170c2f7 Chris
    if ($auth_ssl_reqd) {
730
        my $redir_to = "https://" . $r->hostname() . $r->unparsed_uri();
731
        print STDERR "SoundSoftware.pm:$$: Need to switch to HTTPS, redirecting to $redir_to\n";
732
        $r->headers_out->add('Location' => $redir_to);
733
        return REDIRECT;
734 732:897bc2b63bfe Chris
    } else {
735 734:1d1b8170c2f7 Chris
        return OK;
736 732:897bc2b63bfe Chris
    }
737 7:3c16ed8faa07 Chris
}
738
739
sub authen_handler {
740 8:0c83d98252d9 Chris
    my $r = shift;
741
742 517:bd1d512f9e1b Chris
    print STDERR "SoundSoftware.pm:$$: In authentication handler at " . scalar localtime() . "\n";
743 7:3c16ed8faa07 Chris
744 8:0c83d98252d9 Chris
    my $dbh = connect_database($r);
745 152:a389c77da9fd Chris
    unless ($dbh) {
746 517:bd1d512f9e1b Chris
        print STDERR "SoundSoftware.pm:$$: Database connection failed!: " . $DBI::errstr . "\n";
747 152:a389c77da9fd Chris
        return AUTH_REQUIRED;
748
    }
749 8:0c83d98252d9 Chris
750
    my $project_id = get_project_identifier($dbh, $r);
751
    my $realm = get_realm($dbh, $project_id, $r);
752
    $r->auth_name($realm);
753
754
    my ($res, $redmine_pass) =  $r->get_basic_auth_pw();
755
    unless ($res == OK) {
756
	$dbh->disconnect();
757
	undef $dbh;
758
	return $res;
759
    }
760
761 517:bd1d512f9e1b Chris
    print STDERR "SoundSoftware.pm:$$: User is " . $r->user . ", got password\n";
762 8:0c83d98252d9 Chris
763 732:897bc2b63bfe Chris
    my $status = get_project_status($dbh, $project_id, $r);
764
    if ($status == 0) {
765
	# nonexistent, behave like private project you aren't a member of
766
	print STDERR "SoundSoftware.pm:$$: Project doesn't exist, not permitted\n";
767
	$dbh->disconnect();
768
	undef $dbh;
769
	$r->note_auth_failure();
770
	return AUTH_REQUIRED;
771
    }
772
773 8:0c83d98252d9 Chris
    my $permitted = is_permitted($dbh, $project_id, $r->user, $redmine_pass, $r);
774
775
    $dbh->disconnect();
776
    undef $dbh;
777
778
    if ($permitted) {
779
	return OK;
780
    } else {
781 517:bd1d512f9e1b Chris
	print STDERR "SoundSoftware.pm:$$: Not permitted\n";
782 8:0c83d98252d9 Chris
	$r->note_auth_failure();
783
	return AUTH_REQUIRED;
784
    }
785 7:3c16ed8faa07 Chris
}
786
787
sub get_project_status {
788 8:0c83d98252d9 Chris
    my $dbh = shift;
789 7:3c16ed8faa07 Chris
    my $project_id = shift;
790
    my $r = shift;
791 8:0c83d98252d9 Chris
792
    if (!defined $project_id or $project_id eq '') {
793
	return 0; # nonexistent
794
    }
795 7:3c16ed8faa07 Chris
796
    my $sth = $dbh->prepare(
797
        "SELECT is_public FROM projects WHERE projects.identifier = ?;"
798
    );
799
800
    $sth->execute($project_id);
801 8:0c83d98252d9 Chris
    my $ret = 0; # nonexistent
802 7:3c16ed8faa07 Chris
    if (my @row = $sth->fetchrow_array) {
803
    	if ($row[0] eq "1" || $row[0] eq "t") {
804
	    $ret = 1; # public
805
    	} else {
806 8:0c83d98252d9 Chris
	    $ret = 2; # private
807 7:3c16ed8faa07 Chris
	}
808
    }
809
    $sth->finish();
810
    undef $sth;
811
812
    $ret;
813
}
814
815 734:1d1b8170c2f7 Chris
sub will_require_ssl_auth {
816
    my $r = shift;
817
818
    my $cfg = Apache2::Module::get_config
819
        (__PACKAGE__, $r->server, $r->per_dir_config);
820
821
    if ($cfg->{SoundSoftwareSslRequired} eq "on") {
822
        if ($r->dir_config('HTTPS') eq "on") {
823
            # already have ssl
824
            return 0;
825
        } else {
826
            # require ssl for auth, don't have it yet
827
            return 1;
828
        }
829
    } elsif ($cfg->{SoundSoftwareSslRequired} eq "off") {
830
        # don't require ssl for auth
831
        return 0;
832
    } else {
833
        print STDERR "WARNING: SoundSoftware.pm:$$: SoundSoftwareSslRequired should be either 'on' or 'off'\n";
834
        # this is safer
835
        return 1;
836
    }
837
}
838
839 300:034e9b00b341 chris
sub project_repo_is_readonly {
840
    my $dbh = shift;
841
    my $project_id = shift;
842
    my $r = shift;
843
844
    if (!defined $project_id or $project_id eq '') {
845
        return 0; # nonexistent
846
    }
847
848
    my $sth = $dbh->prepare(
849
        "SELECT repositories.is_external FROM repositories, projects WHERE projects.identifier = ? AND repositories.project_id = projects.id;"
850
    );
851
852
    $sth->execute($project_id);
853
    my $ret = 0; # nonexistent
854
    if (my @row = $sth->fetchrow_array) {
855 301:6d3f8aeb51b7 chris
        if (defined($row[0]) && ($row[0] eq "1" || $row[0] eq "t")) {
856 300:034e9b00b341 chris
            $ret = 1; # read-only (i.e. external)
857
        } else {
858
            $ret = 0; # read-write
859
        }
860
    }
861
    $sth->finish();
862
    undef $sth;
863
864
    $ret;
865
}
866
867 8:0c83d98252d9 Chris
sub is_permitted {
868
    my $dbh = shift;
869
    my $project_id = shift;
870
    my $redmine_user = shift;
871
    my $redmine_pass = shift;
872
    my $r = shift;
873 7:3c16ed8faa07 Chris
874 1331:1e9b1bdd062e Chris
    my $pass_digest = Digest::SHA::sha1_hex($redmine_pass);
875 7:3c16ed8faa07 Chris
876 8:0c83d98252d9 Chris
    my $cfg = Apache2::Module::get_config
877
	(__PACKAGE__, $r->server, $r->per_dir_config);
878 7:3c16ed8faa07 Chris
879 8:0c83d98252d9 Chris
    my $query = $cfg->{SoundSoftwareQuery};
880
    my $sth = $dbh->prepare($query);
881
    $sth->execute($redmine_user, $project_id);
882 7:3c16ed8faa07 Chris
883 8:0c83d98252d9 Chris
    my $ret;
884 301:6d3f8aeb51b7 chris
    while (my ($hashed_password, $salt, $auth_source_id, $permissions) = $sth->fetchrow_array) {
885 7:3c16ed8faa07 Chris
886 8:0c83d98252d9 Chris
	# Test permissions for this user before we verify credentials
887
	# -- if the user is not permitted this action anyway, there's
888
	# not much point in e.g. contacting the LDAP
889 7:3c16ed8faa07 Chris
890 8:0c83d98252d9 Chris
	my $method = $r->method;
891 7:3c16ed8faa07 Chris
892 8:0c83d98252d9 Chris
	if ((defined $read_only_methods{$method} && $permissions =~ /:browse_repository/)
893
	    || $permissions =~ /:commit_access/) {
894
895
	    # User would be permitted this action, if their
896
	    # credentials checked out -- test those now
897
898
	    print STDERR "SoundSoftware.pm: User $redmine_user has required role, checking credentials\n";
899
900
	    unless ($auth_source_id) {
901 1331:1e9b1bdd062e Chris
                my $salted_password = Digest::SHA::sha1_hex($salt.$pass_digest);
902 301:6d3f8aeb51b7 chris
		if ($hashed_password eq $salted_password) {
903 8:0c83d98252d9 Chris
		    print STDERR "SoundSoftware.pm: User $redmine_user authenticated via password\n";
904
		    $ret = 1;
905
		    last;
906
		}
907
	    } else {
908
		my $sthldap = $dbh->prepare(
909
		    "SELECT host,port,tls,account,account_password,base_dn,attr_login FROM auth_sources WHERE id = ?;"
910
		    );
911
		$sthldap->execute($auth_source_id);
912
		while (my @rowldap = $sthldap->fetchrow_array) {
913
		    my $ldap = Authen::Simple::LDAP->new(
914
			host    => ($rowldap[2] eq "1" || $rowldap[2] eq "t") ? "ldaps://$rowldap[0]" : $rowldap[0],
915
			port    => $rowldap[1],
916
			basedn  => $rowldap[5],
917
			binddn  => $rowldap[3] ? $rowldap[3] : "",
918
			bindpw  => $rowldap[4] ? $rowldap[4] : "",
919
			filter  => "(".$rowldap[6]."=%s)"
920
			);
921
		    if ($ldap->authenticate($redmine_user, $redmine_pass)) {
922 517:bd1d512f9e1b Chris
			print STDERR "SoundSoftware.pm:$$: User $redmine_user authenticated via LDAP\n";
923 8:0c83d98252d9 Chris
			$ret = 1;
924
		    }
925
		}
926
		$sthldap->finish();
927
		undef $sthldap;
928 735:8653bddf26a6 Chris
                last if ($ret);
929 8:0c83d98252d9 Chris
	    }
930
	} else {
931 517:bd1d512f9e1b Chris
	    print STDERR "SoundSoftware.pm:$$: User $redmine_user lacks required role for this project\n";
932 8:0c83d98252d9 Chris
	}
933 7:3c16ed8faa07 Chris
    }
934
935 8:0c83d98252d9 Chris
    $sth->finish();
936
    undef $sth;
937
938
    $ret;
939 7:3c16ed8faa07 Chris
}
940
941
sub get_project_identifier {
942 8:0c83d98252d9 Chris
    my $dbh = shift;
943 7:3c16ed8faa07 Chris
    my $r = shift;
944
    my $location = $r->location;
945 737:1ce6efe3db0e Chris
    my ($repo) = $r->uri =~ m{$location/*([^/]*)};
946 10:2c10dc5f122d Chris
947
    return $repo if (!$repo);
948
949 7:3c16ed8faa07 Chris
    $repo =~ s/[^a-zA-Z0-9\._-]//g;
950 736:51c97efbe241 Chris
951 8:0c83d98252d9 Chris
    # The original Redmine.pm returns the string just calculated as
952
    # the project identifier.  That won't do for us -- we may have
953
    # (and in fact already do have, in our test instance) projects
954
    # whose repository names differ from the project identifiers.
955
956
    # This is a rather fundamental change because it means that almost
957
    # every request needs more than one database query -- which
958
    # prompts us to start passing around $dbh instead of connecting
959
    # locally within each function as is done in Redmine.pm.
960
961 7:3c16ed8faa07 Chris
    my $sth = $dbh->prepare(
962
        "SELECT projects.identifier FROM projects, repositories WHERE repositories.project_id = projects.id AND repositories.url LIKE ?;"
963
    );
964
965 8:0c83d98252d9 Chris
    my $cfg = Apache2::Module::get_config
966
	(__PACKAGE__, $r->server, $r->per_dir_config);
967
968
    my $prefix = $cfg->{SoundSoftwareRepoPrefix};
969
    if (!defined $prefix) { $prefix = '%/'; }
970 7:3c16ed8faa07 Chris
    my $identifier = '';
971
972 8:0c83d98252d9 Chris
    $sth->execute($prefix . $repo);
973 7:3c16ed8faa07 Chris
    my $ret = 0;
974
    if (my @row = $sth->fetchrow_array) {
975
	$identifier = $row[0];
976
    }
977
    $sth->finish();
978
    undef $sth;
979
980 517:bd1d512f9e1b Chris
    print STDERR "SoundSoftware.pm:$$: Repository '$repo' belongs to project '$identifier'\n";
981 7:3c16ed8faa07 Chris
982
    $identifier;
983
}
984
985 8:0c83d98252d9 Chris
sub get_realm {
986
    my $dbh = shift;
987
    my $project_id = shift;
988
    my $r = shift;
989
990
    my $sth = $dbh->prepare(
991
        "SELECT projects.name FROM projects WHERE projects.identifier = ?;"
992
    );
993
994
    my $name = $project_id;
995
996
    $sth->execute($project_id);
997
    my $ret = 0;
998
    if (my @row = $sth->fetchrow_array) {
999
	$name = $row[0];
1000
    }
1001
    $sth->finish();
1002
    undef $sth;
1003
1004
    # be timid about characters not permitted in auth realm and revert
1005
    # to project identifier if any are found
1006
    if ($name =~ m/[^\w\d\s\._-]/) {
1007
	$name = $project_id;
1008 733:c7a731db96e5 Chris
    } elsif ($name =~ m/^\s*$/) {
1009
	# empty or whitespace
1010
	$name = $project_id;
1011
    }
1012
1013
    if ($name =~ m/^\s*$/) {
1014
        # nothing even in $project_id -- probably a nonexistent project.
1015
        # use repo name instead (don't want to admit to user that project
1016
        # doesn't exist)
1017
        my $location = $r->location;
1018 737:1ce6efe3db0e Chris
        my ($repo) = $r->uri =~ m{$location/*([^/]*)};
1019 733:c7a731db96e5 Chris
        $name = $repo;
1020 8:0c83d98252d9 Chris
    }
1021
1022 1271:cf4cc816278a Chris
#    my $realm = '"Mercurial repository for ' . "'$name'" . '"';
1023
# see #577:
1024
    my $realm = '"Mercurial repository for ' . "$name" . '"';
1025 8:0c83d98252d9 Chris
1026
    $realm;
1027
}
1028
1029 7:3c16ed8faa07 Chris
sub connect_database {
1030
    my $r = shift;
1031
1032 8:0c83d98252d9 Chris
    my $cfg = Apache2::Module::get_config
1033
	(__PACKAGE__, $r->server, $r->per_dir_config);
1034
1035
    return DBI->connect($cfg->{SoundSoftwareDSN},
1036 152:a389c77da9fd Chris
	                $cfg->{SoundSoftwareDbUser},
1037
		        $cfg->{SoundSoftwareDbPass});
1038 7:3c16ed8faa07 Chris
}
1039
1040
1;
1041 217:ed8222a04634 chris
#!/usr/bin/env ruby
1042
1043
# == Synopsis
1044
#
1045 241:7658d21a1493 chris
# convert-external-repos: Update local Mercurial mirrors of external repos,
1046
# by running an external command for each project requiring an update.
1047 217:ed8222a04634 chris
#
1048
# == Usage
1049
#
1050
#    convert-external-repos [OPTIONS...] -s [DIR] -r [HOST]
1051
#
1052
# == Arguments (mandatory)
1053
#
1054 241:7658d21a1493 chris
#   -s, --scm-dir=DIR         use DIR as base directory for repositories
1055 217:ed8222a04634 chris
#   -r, --redmine-host=HOST   assume Redmine is hosted on HOST. Examples:
1056
#                             -r redmine.example.net
1057
#                             -r http://redmine.example.net
1058
#                             -r https://example.net/redmine
1059
#   -k, --key=KEY             use KEY as the Redmine API key
1060 241:7658d21a1493 chris
#   -c, --command=COMMAND     use this command to update each external
1061
#                             repository: command is called with the name
1062
#                             of the project, the path to its repo, and
1063
#                             its external repo url as its three args
1064 217:ed8222a04634 chris
#
1065
# == Options
1066
#
1067
#   --http-user=USER          User for HTTP Basic authentication with Redmine WS
1068
#   --http-pass=PASSWORD      Password for Basic authentication with Redmine WS
1069
#   -t, --test                only show what should be done
1070
#   -h, --help                show help and exit
1071
#   -v, --verbose             verbose
1072
#   -V, --version             print version and exit
1073
#   -q, --quiet               no log
1074
1075
1076
require 'getoptlong'
1077
require 'find'
1078
require 'etc'
1079
1080
Version = "1.0"
1081
1082
opts = GetoptLong.new(
1083 241:7658d21a1493 chris
                      ['--scm-dir',      '-s', GetoptLong::REQUIRED_ARGUMENT],
1084 217:ed8222a04634 chris
                      ['--redmine-host', '-r', GetoptLong::REQUIRED_ARGUMENT],
1085
                      ['--key',          '-k', GetoptLong::REQUIRED_ARGUMENT],
1086
                      ['--http-user',          GetoptLong::REQUIRED_ARGUMENT],
1087
                      ['--http-pass',          GetoptLong::REQUIRED_ARGUMENT],
1088 241:7658d21a1493 chris
                      ['--command' ,     '-c', GetoptLong::REQUIRED_ARGUMENT],
1089 217:ed8222a04634 chris
                      ['--test',         '-t', GetoptLong::NO_ARGUMENT],
1090
                      ['--verbose',      '-v', GetoptLong::NO_ARGUMENT],
1091
                      ['--version',      '-V', GetoptLong::NO_ARGUMENT],
1092
                      ['--help'   ,      '-h', GetoptLong::NO_ARGUMENT],
1093
                      ['--quiet'  ,      '-q', GetoptLong::NO_ARGUMENT]
1094
                      )
1095
1096
$verbose      = 0
1097
$quiet        = false
1098
$redmine_host = ''
1099
$repos_base   = ''
1100
$http_user    = ''
1101
$http_pass    = ''
1102
$test         = false
1103
1104 437:102056ec2de9 chris
$mirrordir    = '/var/mirror'
1105
1106 217:ed8222a04634 chris
def log(text, options={})
1107
  level = options[:level] || 0
1108
  puts text unless $quiet or level > $verbose
1109
  exit 1 if options[:exit]
1110
end
1111
1112
def system_or_raise(command)
1113
  raise "\"#{command}\" failed" unless system command
1114
end
1115
1116
begin
1117
  opts.each do |opt, arg|
1118
    case opt
1119 241:7658d21a1493 chris
    when '--scm-dir';        $repos_base   = arg.dup
1120 217:ed8222a04634 chris
    when '--redmine-host';   $redmine_host = arg.dup
1121
    when '--key';            $api_key      = arg.dup
1122
    when '--http-user';      $http_user    = arg.dup
1123
    when '--http-pass';      $http_pass    = arg.dup
1124 241:7658d21a1493 chris
    when '--command';        $command      = arg.dup
1125 217:ed8222a04634 chris
    when '--verbose';        $verbose += 1
1126
    when '--test';           $test = true
1127
    when '--version';        puts Version; exit
1128 1336:b61a51fb42b9 Chris
    when '--help';           puts "Read source for documentation"; exit
1129 217:ed8222a04634 chris
    when '--quiet';          $quiet = true
1130
    end
1131
  end
1132
rescue
1133
  exit 1
1134
end
1135
1136
if $test
1137
  log("running in test mode")
1138
end
1139
1140 241:7658d21a1493 chris
if ($redmine_host.empty? or $repos_base.empty? or $command.empty?)
1141 1336:b61a51fb42b9 Chris
  puts "Read source for documentation"; exit
1142 217:ed8222a04634 chris
end
1143
1144
unless File.directory?($repos_base)
1145
  log("directory '#{$repos_base}' doesn't exist", :exit => true)
1146
end
1147
1148
begin
1149
  require 'active_resource'
1150
rescue LoadError
1151
  log("This script requires activeresource.\nRun 'gem install activeresource' to install it.", :exit => true)
1152
end
1153
1154
class Project < ActiveResource::Base
1155
  self.headers["User-agent"] = "SoundSoftware external repository converter/#{Version}"
1156 1336:b61a51fb42b9 Chris
  self.format = :xml
1157 217:ed8222a04634 chris
end
1158
1159
log("querying Redmine for projects...", :level => 1);
1160
1161
$redmine_host.gsub!(/^/, "http://") unless $redmine_host.match("^https?://")
1162
$redmine_host.gsub!(/\/$/, '')
1163
1164
Project.site = "#{$redmine_host}/sys";
1165
Project.user = $http_user;
1166
Project.password = $http_pass;
1167
1168
begin
1169
  # Get all active projects that have the Repository module enabled
1170
  projects = Project.find(:all, :params => {:key => $api_key})
1171 1336:b61a51fb42b9 Chris
rescue ActiveResource::ForbiddenAccess
1172
  log("Request was denied by your Redmine server. Make sure that 'WS for repository management' is enabled in application settings and that you provided the correct API key.")
1173 217:ed8222a04634 chris
rescue => e
1174
  log("Unable to connect to #{Project.site}: #{e}", :exit => true)
1175
end
1176
1177
if projects.nil?
1178
  log('no project found, perhaps you forgot to "Enable WS for repository management"', :exit => true)
1179
end
1180
1181
log("retrieved #{projects.size} projects", :level => 1)
1182
1183
projects.each do |project|
1184
  log("treating project #{project.name}", :level => 1)
1185
1186
  if project.identifier.empty?
1187
    log("\tno identifier for project #{project.name}")
1188
    next
1189 1445:0c7b3bb73517 Chris
  elsif not project.identifier.match(/^[a-z0-9_\-]+$/)
1190 217:ed8222a04634 chris
    log("\tinvalid identifier for project #{project.name} : #{project.identifier}");
1191
    next
1192
  end
1193
1194
  if !project.respond_to?(:repository) or !project.repository.is_external?
1195
    log("\tproject #{project.identifier} does not use an external repository");
1196
    next
1197
  end
1198
1199
  external_url = project.repository.external_url;
1200
  log("\tproject #{project.identifier} has external repository url #{external_url}");
1201
1202
  if !external_url.match(/^[a-z][a-z+]{0,8}[a-z]:\/\//)
1203
    log("\tthis doesn't look like a plausible url to me, skipping")
1204
    next
1205
  end
1206
1207
  repos_path = File.join($repos_base, project.identifier).gsub(File::SEPARATOR, File::ALT_SEPARATOR || File::SEPARATOR)
1208
1209 241:7658d21a1493 chris
  unless File.directory?(repos_path)
1210
    log("\tproject repo directory '#{repos_path}' doesn't exist")
1211 217:ed8222a04634 chris
    next
1212
  end
1213
1214 241:7658d21a1493 chris
  system($command, project.identifier, repos_path, external_url)
1215 437:102056ec2de9 chris
1216
  $cache_clearance_file = File.join($mirrordir, project.identifier, 'url_changed')
1217
  if File.file?($cache_clearance_file)
1218
    log("\tproject repo url has changed, requesting cache clearance")
1219
    if project.post(:repository_cache, :key => $api_key)
1220
      File.delete($cache_clearance_file)
1221
    end
1222
  end
1223 217:ed8222a04634 chris
1224
end
1225
1226 1538:87bea4981d6d Chris
#!/usr/bin/env ruby
1227
1228
# Create authormap files for hg repos based on the changeset & project
1229
# member info available to Redmine.
1230
#
1231
# We have a set of hg repos in a given directory:
1232
#
1233
# /var/hg/repo_1
1234
# /var/hg/repo_2
1235
# /var/hg/repo_3
1236
#
1237
# and we want to produce authormap files in another directory:
1238
#
1239
# /var/repo-export/authormap/authormap_repo_1
1240
# /var/repo-export/authormap/authormap_repo_2
1241
# /var/repo-export/authormap/authormap_repo_3
1242
#
1243
# This script does that, if given the two directory names as arguments
1244
# to the -s and -o options. In the above example:
1245
#
1246 1543:05d639e5d59b Chris
# ./script/rails runner -e production extra/soundsoftware/create-repo-authormaps.rb -s /var/hg -o /var/repo-export/authormap
1247 1538:87bea4981d6d Chris
#
1248
# Note that this script will overwrite any existing authormap
1249
# files. (That's why the output files are given an authormap_ prefix,
1250
# so we're less likely to clobber something else if the user gets the
1251
# arguments wrong.)
1252
1253
require 'getoptlong'
1254
1255
opts = GetoptLong.new(
1256 1543:05d639e5d59b Chris
                      ['--scm-dir', '-s', GetoptLong::REQUIRED_ARGUMENT],
1257
                      ['--out-dir', '-o', GetoptLong::REQUIRED_ARGUMENT],
1258
                      ['--environment', '-e', GetoptLong::OPTIONAL_ARGUMENT]
1259 1538:87bea4981d6d Chris
)
1260
1261
$repos_base   = ''
1262
$out_base     = ''
1263
1264
def usage
1265
  puts "See source code for supported options"
1266
  exit
1267
end
1268
1269
begin
1270
  opts.each do |opt, arg|
1271
    case opt
1272
    when '--scm-dir';   $repos_base   = arg.dup
1273
    when '--out-dir';   $out_base     = arg.dup
1274
    end
1275
  end
1276
rescue
1277
  exit 1
1278
end
1279
1280
if ($repos_base.empty? or $out_base.empty?)
1281
  usage
1282
end
1283
1284
unless File.directory?($repos_base)
1285 1540:322d7b57e5f0 chris
  puts "input directory '#{$repos_base}' doesn't exist"
1286
  exit 1
1287 1538:87bea4981d6d Chris
end
1288
1289
unless File.directory?($out_base)
1290 1540:322d7b57e5f0 chris
  puts "output directory '#{$out_base}' doesn't exist"
1291
  exit 1
1292 1538:87bea4981d6d Chris
end
1293
1294
projects = Project.find(:all)
1295
1296
if projects.nil?
1297 1540:322d7b57e5f0 chris
  puts 'No projects found'
1298
  exit 1
1299 1538:87bea4981d6d Chris
end
1300
1301
projects.each do |proj|
1302
  next unless proj.respond_to?(:repository)
1303
1304
  repo = proj.repository
1305 1539:22d57b0e0a77 chris
  next if repo.nil? or repo.url.empty?
1306 1538:87bea4981d6d Chris
1307
  repo_url = repo.url
1308
  repo_url = repo_url.gsub(/^file:\/*/, "/");
1309
  if repo_url != File.join($repos_base, proj.identifier)
1310 1542:60acfbd8f6d6 Chris
    puts "Project #{proj.identifier} has repo in unsupported location #{repo_url}, skipping"
1311 1538:87bea4981d6d Chris
    next
1312
  end
1313
1314 1542:60acfbd8f6d6 Chris
  committers = repo.committers
1315 1538:87bea4981d6d Chris
1316
  authormap = ""
1317 1542:60acfbd8f6d6 Chris
  committers.each do |c, uid|
1318 1538:87bea4981d6d Chris
    if not c =~ /[^<]+<.*@.*>/ then
1319 1542:60acfbd8f6d6 Chris
      user = User.find_by_id uid
1320 1539:22d57b0e0a77 chris
      authormap << "#{c}=#{user.name} <#{user.mail}>\n" unless user.nil?
1321 1538:87bea4981d6d Chris
    end
1322
  end
1323
1324 1539:22d57b0e0a77 chris
  File.open(File.join($out_base, "authormap_#{proj.identifier}"), "w") do |f|
1325 1538:87bea4981d6d Chris
    f.puts(authormap)
1326
  end
1327
1328
end
1329
1330 226:5b028aef59a7 chris
#!/usr/bin/perl -w
1331
1332
# Read a Doxyfile and print it out again to stdout, with only
1333
# whitelisted keys in it and with some keys set to pre-fixed values.
1334
#
1335
# Note that OUTPUT_DIRECTORY is not included; it should be added by
1336
# the caller
1337
1338
use strict;
1339
1340
my $txt = join "", <>;
1341
$txt =~ s/^\s*#.*$//gm;
1342
$txt =~ s/\\\n//gs;
1343
$txt =~ s/\r//g;
1344
$txt =~ s/\n\s*\n/\n/gs;
1345
1346
my %fixed = (
1347
    FULL_PATH_NAMES => "NO",
1348
    SYMBOL_CACHE_SIZE => 2,
1349
    EXCLUDE_SYMLINKS => "YES",
1350
    GENERATE_HTML => "YES",
1351
    PERL_PATH => "/usr/bin/perl",
1352
    HAVE_DOT => "YES",
1353
    HTML_OUTPUT => ".",
1354 228:3c084a25d8ab chris
    HTML_DYNAMIC_SECTIONS => "NO",
1355 226:5b028aef59a7 chris
    SEARCHENGINE => "NO",
1356
    DOT_FONTNAME => "FreeMono",
1357
    DOT_FONTSIZE => 10,
1358
    DOT_FONTPATH => "/usr/share/fonts/truetype/freefont",
1359
    DOT_IMAGE_FORMAT => "png",
1360
    DOT_PATH => "/usr/bin/dot",
1361
    DOT_TRANSPARENT => "YES",
1362
);
1363
1364 233:df89e7aa3ce8 Chris
# These are the keys that are safe to take from the output and include
1365
# in the output; they may still need to be checked for safe values (if
1366
# file paths).
1367 226:5b028aef59a7 chris
my @safe = qw(
1368 233:df89e7aa3ce8 Chris
INPUT
1369
FILE_PATTERNS
1370
EXAMPLE_PATH
1371
EXAMPLE_PATTERNS
1372
IMAGE_PATH
1373
INCLUDE_PATH
1374
INCLUDE_FILE_PATTERNS
1375 226:5b028aef59a7 chris
DOXYFILE_ENCODING
1376
PROJECT_NAME
1377
PROJECT_NUMBER
1378
CREATE_SUBDIRS
1379
OUTPUT_LANGUAGE
1380
BRIEF_MEMBER_DESC
1381
REPEAT_BRIEF
1382
ABBREVIATE_BRIEF
1383
ALWAYS_DETAILED_SEC
1384
INLINE_INHERITED_MEMB
1385
STRIP_FROM_PATH
1386
STRIP_FROM_INC_PATH
1387
JAVADOC_AUTOBRIEF
1388
QT_AUTOBRIEF
1389
MULTILINE_CPP_IS_BRIEF
1390
INHERIT_DOCS
1391
SEPARATE_MEMBER_PAGES
1392
TAB_SIZE
1393
ALIASES
1394
OPTIMIZE_OUTPUT_FOR_C
1395
OPTIMIZE_OUTPUT_JAVA
1396
OPTIMIZE_FOR_FORTRAN
1397
OPTIMIZE_OUTPUT_VHDL
1398
EXTENSION_MAPPING
1399
BUILTIN_STL_SUPPORT
1400
CPP_CLI_SUPPORT
1401
SIP_SUPPORT
1402
IDL_PROPERTY_SUPPORT
1403
DISTRIBUTE_GROUP_DOC
1404
SUBGROUPING
1405
TYPEDEF_HIDES_STRUCT
1406
EXTRACT_ALL
1407
EXTRACT_PRIVATE
1408
EXTRACT_STATIC
1409
EXTRACT_LOCAL_CLASSES
1410
EXTRACT_LOCAL_METHODS
1411
EXTRACT_ANON_NSPACES
1412
HIDE_UNDOC_MEMBERS
1413
HIDE_UNDOC_CLASSES
1414
HIDE_FRIEND_COMPOUNDS
1415
HIDE_IN_BODY_DOCS
1416
INTERNAL_DOCS
1417
HIDE_SCOPE_NAMES
1418
SHOW_INCLUDE_FILES
1419
FORCE_LOCAL_INCLUDES
1420
INLINE_INFO
1421
SORT_MEMBER_DOCS
1422
SORT_BRIEF_DOCS
1423
SORT_MEMBERS_CTORS_1ST
1424
SORT_GROUP_NAMES
1425
SORT_BY_SCOPE_NAME
1426
GENERATE_TODOLIST
1427
GENERATE_TESTLIST
1428
GENERATE_BUGLIST
1429
GENERATE_DEPRECATEDLIST
1430
ENABLED_SECTIONS
1431
MAX_INITIALIZER_LINES
1432
SHOW_USED_FILES
1433
SHOW_DIRECTORIES
1434
SHOW_FILES
1435
SHOW_NAMESPACES
1436
QUIET
1437
WARNINGS
1438
WARN_IF_UNDOCUMENTED
1439
WARN_IF_DOC_ERROR
1440
WARN_NO_PARAMDOC
1441
INPUT_ENCODING
1442
RECURSIVE
1443
EXCLUDE
1444
EXCLUDE_SYMLINKS
1445
EXCLUDE_PATTERNS
1446
EXCLUDE_SYMBOLS
1447
EXAMPLE_RECURSIVE
1448
SOURCE_BROWSER
1449
INLINE_SOURCES
1450
STRIP_CODE_COMMENTS
1451
REFERENCED_BY_RELATION
1452
REFERENCES_RELATION
1453
REFERENCES_LINK_SOURCE
1454
VERBATIM_HEADERS
1455
ALPHABETICAL_INDEX
1456
COLS_IN_ALPHA_INDEX
1457
IGNORE_PREFIX
1458
HTML_TIMESTAMP
1459
HTML_ALIGN_MEMBERS
1460
ENABLE_PREPROCESSING
1461
MACRO_EXPANSION
1462
EXPAND_ONLY_PREDEF
1463
SEARCH_INCLUDES
1464
PREDEFINED
1465
EXPAND_AS_DEFINED
1466
SKIP_FUNCTION_MACROS
1467
ALLEXTERNALS
1468
EXTERNAL_GROUPS
1469
CLASS_DIAGRAMS
1470
HIDE_UNDOC_RELATIONS
1471
CLASS_GRAPH
1472
COLLABORATION_GRAPH
1473
GROUP_GRAPHS
1474
UML_LOOK
1475
TEMPLATE_RELATIONS
1476
INCLUDE_GRAPH
1477
INCLUDED_BY_GRAPH
1478
CALL_GRAPH
1479
CALLER_GRAPH
1480
GRAPHICAL_HIERARCHY
1481
DIRECTORY_GRAPH
1482
DOT_GRAPH_MAX_NODES
1483
MAX_DOT_GRAPH_DEPTH
1484
DOT_MULTI_TARGETS
1485
DOT_CLEANUP
1486
);
1487
1488
my %safehash;
1489
for my $sk (@safe) { $safehash{$sk} = 1; }
1490
1491
my @lines = split "\n", $txt;
1492
1493
my %settings;
1494
1495
sub is_safe {
1496
    my $key = shift;
1497
    defined $safehash{$key} and $safehash{$key} == 1;
1498
}
1499
1500
sub has_file_path {
1501
    # Returns true if the given key expects a file path as a value.
1502
    # We only need to test keys that are safe; unsafe keys have been
1503
    # rejected already.
1504
    my $key = shift;
1505
    $key eq "INPUT" or
1506
	$key =~ /^OUTPUT_/ or
1507
	$key =~ /_PATH$/ or
1508
	$key =~ /_PATTERNS$/;
1509
}
1510
1511
sub is_safe_file_path {
1512
    my $value = shift;
1513
    not $value =~ /^\// and not $value =~ /\.\./;
1514
}
1515
1516
foreach my $line (@lines) {
1517
1518
    chomp $line;
1519
    my ($key, $value) = split /\s*=\s*/, $line;
1520
1521
    next if !defined $key;
1522
1523
    if ($key =~ /^GENERATE_/ and not $key =~ /LIST$/) {
1524
	print STDERR "NOTE: Setting $key explicitly to NO\n";
1525
	$settings{$key} = "NO";
1526
	next;
1527
    }
1528
1529
    if (!is_safe($key)) {
1530
	print STDERR "NOTE: Skipping non-whitelisted key $key\n";
1531
	next;
1532
    }
1533
1534
    if (has_file_path($key) and !is_safe_file_path($value)) {
1535
	print STDERR "ERROR: Unsafe file path \"$value\" for key $key\n";
1536
	exit 1;
1537
    }
1538
1539
    $settings{$key} = $value;
1540
}
1541
1542 228:3c084a25d8ab chris
foreach my $key (keys %fixed) {
1543
    my $value = $fixed{$key};
1544
    print STDERR "NOTE: Setting $key to fixed value $value\n";
1545
    $settings{$key} = $value;
1546
}
1547
1548 226:5b028aef59a7 chris
print join "\n", map { "$_ = $settings{$_}" } keys %settings;
1549
print "\n";
1550 1543:05d639e5d59b Chris
#!/bin/bash
1551
1552
set -e
1553
1554
progdir=$(dirname $0)
1555
case "$progdir" in
1556
    /*) ;;
1557
    *) progdir="$(pwd)/$progdir" ;;
1558
esac
1559
1560
rails_scriptdir="$progdir/../../script"
1561
rails="$rails_scriptdir/rails"
1562
1563
if [ ! -x "$rails" ]; then
1564
    echo "Expected to find rails executable at $rails"
1565
    exit 2
1566
fi
1567
1568
fastexport="$progdir/../fast-export/hg-fast-export.sh"
1569
if [ ! -x "$fastexport" ]; then
1570
    echo "Expected to find hg-fast-export.sh executable at $fastexport"
1571
    exit 2
1572
fi
1573
1574 1546:248c402992ba Chris
environment="$1"
1575
hgdir="$2"
1576
gitdir="$3"
1577 1543:05d639e5d59b Chris
1578
if [ -z "$hgdir" ] || [ -z "$gitdir" ]; then
1579 1546:248c402992ba Chris
    echo "Usage: $0 <environment> <hgdir> <gitdir>"
1580
    echo "  where"
1581
    echo "  - environment is the Rails environment (development or production)"
1582
    echo "  - hgdir is the directory containing project Mercurial repositories"
1583
    echo "  - gitdir is the directory in which output git repositories are to be"
1584
    echo "    created or updated"
1585 1543:05d639e5d59b Chris
    exit 2
1586
fi
1587
1588
if [ ! -d "$hgdir" ]; then
1589
    echo "Mercurial repository directory $hgdir not found"
1590
    exit 1
1591
fi
1592
1593
if [ ! -d "$gitdir" ]; then
1594
    echo "Target git repository dir $gitdir not found (please create at least the empty directory)"
1595
    exit 1
1596
fi
1597
1598
set -u
1599
1600
authordir="$gitdir/AUTHORMAPS"
1601
1602
mkdir -p "$authordir"
1603
1604 1546:248c402992ba Chris
echo "About to extract author maps..."
1605
1606
"$rails" runner -e "$environment" "$progdir/create-repo-authormaps.rb" \
1607 1543:05d639e5d59b Chris
	 -s "$hgdir" -o "$authordir"
1608
1609
for hgrepo in "$hgdir"/*; do
1610
1611
    if [ ! -d "$hgrepo/.hg" ]; then
1612
	echo "Directory $hgrepo does not appear to be a Mercurial repo, skipping"
1613
	continue
1614
    fi
1615
1616
    reponame=$(basename "$hgrepo")
1617
    authormap="$authordir/authormap_$reponame"
1618
    gitrepo="$gitdir/$reponame"
1619
1620
    if [ ! -f "$authormap" ]; then
1621
	echo "Authormap file $authormap not found for repo $hgrepo, skipping: the create-repo-authormaps script already run by this script should have created an authormap file (even if empty) for every repo with a corresponding project"
1622
	continue
1623
    fi
1624
1625
    if [ ! -d "$gitrepo" ]; then
1626
	git init "$gitrepo"
1627
    fi
1628
1629 1546:248c402992ba Chris
    echo "About to run fast export for repo $reponame..."
1630 1543:05d639e5d59b Chris
1631
    (
1632
	cd "$gitrepo"
1633
	"$fastexport" -r "$hgrepo" -A "$authormap"
1634
    )
1635
1636
    echo "Fast export done"
1637
1638
done
1639
1640
echo "All done"
1641
1642 203:1e55195bca45 chris
#!/bin/bash
1643
1644
# Run this script from anywhere
1645
1646
# Enumerate Hg repos; make sure they're up to date; extract docs for
1647
# each
1648
1649
hgdir="/var/hg"
1650
docdir="/var/doc"
1651 223:c3544e9fd588 chris
logfile="/var/www/test-cannam/log/extract-docs.log"
1652
1653
redgrp="redmine"
1654 203:1e55195bca45 chris
1655 218:292cde42265a chris
apikey=""
1656 339:5410d82c12df chris
apischeme="https"
1657 218:292cde42265a chris
apihost=""
1658
apiuser=""
1659
apipass=""
1660
1661 203:1e55195bca45 chris
progdir=$(dirname $0)
1662
case "$progdir" in
1663
    /*) ;;
1664
    *) progdir="$(pwd)/$progdir" ;;
1665
esac
1666
1667 411:e7ba81c8dc5a chris
types="doxygen javadoc matlabdocs" # Do Doxygen first (it can be used for Java too)
1668 203:1e55195bca45 chris
1669
for x in $types; do
1670
    if [ ! -x "$progdir/extract-$x.sh" ]; then
1671
	echo "Helper script not available: $progdir/extract-$x.sh"
1672
	exit 1
1673
    fi
1674
done
1675
1676 218:292cde42265a chris
enable_embedded()
1677
{
1678
    p="$1"
1679 228:3c084a25d8ab chris
    if [ -n "$apikey" ]; then
1680
	if [ -n "$apiuser" ]; then
1681 339:5410d82c12df chris
	    sudo -u docgen curl -u "$apiuser":"$apipass" "$apischeme://$apihost/sys/projects/$p/embedded.xml?enable=1&key=$apikey" -d ""
1682 228:3c084a25d8ab chris
	else
1683 339:5410d82c12df chris
	    sudo -u docgen curl "$apischeme://$apihost/sys/projects/$p/embedded.xml?enable=1&key=$apikey" -d ""
1684 228:3c084a25d8ab chris
	fi
1685
    else
1686
	echo "Can't enable Embedded, API not configured" 1>&2
1687 218:292cde42265a chris
    fi
1688
}
1689
1690 223:c3544e9fd588 chris
# We want to ensure the doc extraction is done by the unprivileged
1691
# user docgen, which is not a member of any interesting group
1692
#
1693
# To this end, we create the tmpdir with user docgen and group
1694
# www-data, and use the www-data user to pull out an archive of the Hg
1695
# repo tip into a location beneath that, before using the docgen user
1696
# to extract docs from that location and write them into the tmpdir
1697
1698
# Same tmpdir for each project: we delete and recreate to avoid
1699
# cleanup duty from lots of directories being created
1700
#
1701
tmpdir=$(mktemp -d "$docdir/tmp_XXXXXX")
1702
1703
fail()
1704
{
1705
    message="$1"
1706
    echo "$message" 1>&2
1707
    case "$tmpdir" in
1708
	*/tmp*) rm -rf "$tmpdir";;
1709
	*);;
1710
    esac
1711
    exit 1
1712
}
1713
1714
case "$tmpdir" in
1715
    /*) ;;
1716
    *) fail "Temporary directory creation failed";;
1717
esac
1718
1719
chown docgen.www-data "$tmpdir" || fail "Temporary directory ownership change failed"
1720
chmod g+rwx "$tmpdir" || fail "Temporary directory permissions change failed"
1721
1722 203:1e55195bca45 chris
for projectdir in "$hgdir"/* ; do
1723
1724
    if [ -d "$projectdir" ] && [ -d "$projectdir/.hg" ]; then
1725
1726 223:c3544e9fd588 chris
	if ! sudo -u www-data hg -R "$projectdir" -q update; then
1727
	    echo "Failed to update Hg in $projectdir, skipping" 1>&2
1728
	    continue
1729
	fi
1730
1731 203:1e55195bca45 chris
	project=$(basename "$projectdir")
1732
1733 223:c3544e9fd588 chris
	tmptargetdir="$tmpdir/doc"
1734
	snapshotdir="$tmpdir/hgsnapshot"
1735 203:1e55195bca45 chris
1736 223:c3544e9fd588 chris
	rm -rf "$tmptargetdir" "$snapshotdir"
1737
1738 226:5b028aef59a7 chris
	mkdir -m 770 "$tmptargetdir" || fail "Temporary target directory creation failed"
1739
	chown docgen.www-data "$tmptargetdir" || fail "Temporary target directory ownership change failed"
1740 223:c3544e9fd588 chris
1741
	mkdir -m 770 "$snapshotdir" || fail "Snapshot directory creation failed"
1742
	chown docgen.www-data "$snapshotdir" || fail "Snapshot directory ownership change failed"
1743
1744
	hgparents=$(sudo -u www-data hg -R "$projectdir" parents)
1745
	if [ -z "$hgparents" ]; then
1746
	    echo "Hg repo at $projectdir has no working copy (empty repo?), skipping"
1747
	    continue
1748
	else
1749
	    echo "Found non-empty Hg repo: $projectdir for project $project"
1750
	fi
1751
1752
	if ! sudo -u www-data hg -R "$projectdir" archive -r tip -t files "$snapshotdir"; then
1753
	    echo "Failed to pick archive from $projectdir, skipping" 1>&2
1754
	    continue
1755
	fi
1756 203:1e55195bca45 chris
1757
	targetdir="$docdir/$project"
1758
1759 223:c3544e9fd588 chris
	echo "Temporary dir is $tmpdir, temporary doc dir is $tmptargetdir, snapshot dir is $snapshotdir, eventual target is $targetdir"
1760 203:1e55195bca45 chris
1761
	for x in $types; do
1762 226:5b028aef59a7 chris
	    if sudo -u docgen "$progdir/extract-$x.sh" "$project" "$snapshotdir" "$tmptargetdir" >> "$logfile" 2>&1; then
1763
		break
1764
	    else
1765 203:1e55195bca45 chris
		echo "Failed to extract via type $x"
1766
	    fi
1767
	done
1768
1769 223:c3544e9fd588 chris
        if [ -f "$tmptargetdir/index.html" ]; then
1770 203:1e55195bca45 chris
	    echo "Processing resulted in an index.html being created, looks good!"
1771
	    if [ ! -d "$targetdir" ] || [ ! -f "$targetdir/index.html" ]; then
1772 223:c3544e9fd588 chris
		echo "This project hasn't had doc extracted before: enabling Embedded"
1773 218:292cde42265a chris
		enable_embedded "$project"
1774 203:1e55195bca45 chris
	    fi
1775
1776
	    if [ -d "$targetdir" ]; then
1777
		mv "$targetdir" "$targetdir"_"$$" && \
1778 223:c3544e9fd588 chris
		    mv "$tmptargetdir" "$targetdir" && \
1779 203:1e55195bca45 chris
		    rm -rf "$targetdir"_"$$"
1780 223:c3544e9fd588 chris
		chgrp -R "$redgrp" "$targetdir"
1781 203:1e55195bca45 chris
	    else
1782 223:c3544e9fd588 chris
		mv "$tmptargetdir" "$targetdir"
1783
		chgrp -R "$redgrp" "$targetdir"
1784 203:1e55195bca45 chris
	    fi
1785 228:3c084a25d8ab chris
	else
1786
	    echo "Processing did not result in an index.html being created"
1787 203:1e55195bca45 chris
	fi
1788
    fi
1789
done
1790
1791 223:c3544e9fd588 chris
rm -rf "$tmpdir"
1792 203:1e55195bca45 chris
#!/bin/bash
1793
1794
docdir="/var/doc"
1795
1796 228:3c084a25d8ab chris
progdir=$(dirname $0)
1797
case "$progdir" in
1798
    /*) ;;
1799
    *) progdir="$(pwd)/$progdir" ;;
1800
esac
1801
1802 203:1e55195bca45 chris
project="$1"
1803 223:c3544e9fd588 chris
projectdir="$2"
1804
targetdir="$3"
1805 203:1e55195bca45 chris
1806 223:c3544e9fd588 chris
if [ -z "$project" ] || [ -z "$targetdir" ] || [ -z "$projectdir" ]; then
1807
    echo "Usage: $0 <project> <projectdir> <targetdir>"
1808 203:1e55195bca45 chris
    exit 2
1809
fi
1810
1811 223:c3544e9fd588 chris
if [ ! -d "$projectdir" ]; then
1812
    echo "Project directory $projectdir not found"
1813 203:1e55195bca45 chris
    exit 1
1814
fi
1815
1816
if [ ! -d "$targetdir" ]; then
1817
    echo "Target dir $targetdir not found"
1818
    exit 1
1819
fi
1820
1821
if [ -f "$targetdir/index.html" ]; then
1822
    echo "Target dir $targetdir already contains index.html"
1823
    exit 1
1824
fi
1825
1826
doxyfile=$(find "$projectdir" -type f -name Doxyfile -print | head -1)
1827
1828
if [ -z "$doxyfile" ]; then
1829
    echo "No Doxyfile found for project $project"
1830
    exit 1
1831
fi
1832
1833
echo "Project $project contains a Doxyfile at $doxyfile"
1834
1835
cd "$projectdir" || exit 1
1836
1837 228:3c084a25d8ab chris
"$progdir/doxysafe.pl" "$doxyfile" | \
1838
    sed -e '$a OUTPUT_DIRECTORY='"$targetdir" | \
1839 203:1e55195bca45 chris
    doxygen -
1840
1841
#!/bin/bash
1842 168:c1e9f2dab1d5 chris
1843 203:1e55195bca45 chris
docdir="/var/doc"
1844 168:c1e9f2dab1d5 chris
1845 203:1e55195bca45 chris
project="$1"
1846 223:c3544e9fd588 chris
projectdir="$2"
1847
targetdir="$3"
1848 168:c1e9f2dab1d5 chris
1849 223:c3544e9fd588 chris
if [ -z "$project" ] || [ -z "$targetdir" ] || [ -z "$projectdir" ]; then
1850
    echo "Usage: $0 <project> <projectdir> <targetdir>"
1851 203:1e55195bca45 chris
    exit 2
1852 168:c1e9f2dab1d5 chris
fi
1853
1854 223:c3544e9fd588 chris
if [ ! -d "$projectdir" ]; then
1855
    echo "Project directory $projectdir not found"
1856 203:1e55195bca45 chris
    exit 1
1857
fi
1858 168:c1e9f2dab1d5 chris
1859 203:1e55195bca45 chris
if [ ! -d "$targetdir" ]; then
1860
    echo "Target dir $targetdir not found"
1861
    exit 1
1862
fi
1863 168:c1e9f2dab1d5 chris
1864 203:1e55195bca45 chris
if [ -f "$targetdir/index.html" ]; then
1865
    echo "Target dir $targetdir already contains index.html"
1866
    exit 1
1867 178:2cec5c53cd68 chris
fi
1868 168:c1e9f2dab1d5 chris
1869 191:0d1c6fa50d3a chris
# Identify Java files whose packages match the trailing parts of their
1870
# paths, and list the resulting packages and the path prefixes with
1871
# the packages removed (so as to find code in subdirs,
1872
# e.g. src/com/example/...)
1873
1874
# Regexp match is very rough; check what is actually permitted for
1875
# package declarations
1876
1877 203:1e55195bca45 chris
find "$projectdir" -type f -name \*.java \
1878 989:3549525ba22a Chris
    -exec egrep '^ *package +[a-zA-Z][a-zA-Z0-9\._-]*;.*$' \{\} /dev/null \; |
1879
    sed -e 's/\/[^\/]*: *package */:/' -e 's/;.*$//' |
1880 191:0d1c6fa50d3a chris
    sort | uniq | (
1881
	current_prefix=
1882
	current_packages=
1883
	while IFS=: read filepath package; do
1884
	    echo "Looking at $package in $filepath"
1885
	    packagepath=${package//./\/}
1886
	    prefix=${filepath%$packagepath}
1887 203:1e55195bca45 chris
	    prefix=${prefix:=$projectdir}
1888 191:0d1c6fa50d3a chris
	    if [ "$prefix" = "$filepath" ]; then
1889
		echo "Package $package does not match suffix of path $filepath, skipping"
1890
		continue
1891
	    fi
1892
	    if [ "$prefix" != "$current_prefix" ]; then
1893 450:73401a15037b Chris
		echo "Package $package matches file path and has new prefix $prefix"
1894 191:0d1c6fa50d3a chris
		if [ -n "$current_packages" ]; then
1895
		    echo "Running Javadoc for packages $current_packages from prefix $current_prefix"
1896 450:73401a15037b Chris
		    echo "Command is: javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages"
1897 203:1e55195bca45 chris
		    javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages
1898 191:0d1c6fa50d3a chris
		fi
1899
		current_prefix="$prefix"
1900 450:73401a15037b Chris
		current_packages="$package"
1901 191:0d1c6fa50d3a chris
	    else
1902 450:73401a15037b Chris
		echo "Package $package matches file path with same prefix as previous file"
1903 191:0d1c6fa50d3a chris
		current_packages="$current_packages $package"
1904
	    fi
1905
	done
1906 203:1e55195bca45 chris
	prefix=${prefix:=$projectdir}
1907 191:0d1c6fa50d3a chris
	if [ -n "$current_packages" ]; then
1908
	    echo "Running Javadoc for packages $current_packages in prefix $current_prefix"
1909 450:73401a15037b Chris
  	    echo "Command is: javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages"
1910 203:1e55195bca45 chris
	    javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages
1911 191:0d1c6fa50d3a chris
	fi
1912
    )
1913
1914 450:73401a15037b Chris
if [ -f "$targetdir"/overview-tree.html ]; then
1915
    cp "$targetdir"/overview-tree.html "$targetdir"/index.html
1916
fi
1917
1918 203:1e55195bca45 chris
# for exit code:
1919
[ -f "$targetdir/index.html" ]
1920 168:c1e9f2dab1d5 chris
1921 411:e7ba81c8dc5a chris
#!/bin/bash
1922
1923
docdir="/var/doc"
1924
1925
progdir=$(dirname $0)
1926
case "$progdir" in
1927
    /*) ;;
1928
    *) progdir="$(pwd)/$progdir" ;;
1929
esac
1930
1931
project="$1"
1932
projectdir="$2"
1933
targetdir="$3"
1934
1935
if [ -z "$project" ] || [ -z "$targetdir" ] || [ -z "$projectdir" ]; then
1936
    echo "Usage: $0 <project> <projectdir> <targetdir>"
1937
    exit 2
1938
fi
1939
1940
if [ ! -d "$projectdir" ]; then
1941
    echo "Project directory $projectdir not found"
1942
    exit 1
1943
fi
1944
1945
if [ ! -d "$targetdir" ]; then
1946
    echo "Target dir $targetdir not found"
1947
    exit 1
1948
fi
1949
1950
if [ -f "$targetdir/index.html" ]; then
1951
    echo "Target dir $targetdir already contains index.html"
1952
    exit 1
1953
fi
1954
1955
mfile=$(find "$projectdir" -type f -name \*.m -print0 | xargs -0 grep -l '^% ' | head -1)
1956
1957
if [ -z "$mfile" ]; then
1958
    echo "No MATLAB files with comments found for project $project"
1959
    exit 1
1960
fi
1961
1962
echo "Project $project contains at least one MATLAB file with comments"
1963
1964
cd "$projectdir" || exit 1
1965
1966
perl "$progdir/matlab-docs.pl" -c "$progdir/matlab-docs.conf" -d "$targetdir"
1967
1968 978:bbb88c44f805 Chris
1969 980:9b4919de5317 Chris
# Read an Apache log file in SoundSoftware site format from stdin and
1970
# produce some per-project stats.
1971 978:bbb88c44f805 Chris
#
1972
# Invoke with e.g.
1973
#
1974
# cat /var/log/apache2/code-access.log | \
1975
#   script/runner -e production extra/soundsoftware/get-apache-log-stats.rb
1976
1977 975:198f764e734c Chris
1978
# Use the ApacheLogRegex parser, a neat thing
1979
# See http://www.simonecarletti.com/blog/2009/02/apache-log-regex-a-lightweight-ruby-apache-log-parser/
1980
require 'apachelogregex'
1981
1982
# This is the format defined in our httpd.conf
1983
vhost_combined_format = '%v:%p %h %{X-Forwarded-For}i %l %u %t \"%r\" %>s %O \"%{Referer}i\" \"%{User-Agent}i\"'
1984
1985
parser = ApacheLogRegex.new(vhost_combined_format)
1986
1987
# project name -> count of hg clones
1988
clones = Hash.new(0)
1989
1990
# project name -> count of hg pulls
1991
pulls = Hash.new(0)
1992
1993 978:bbb88c44f805 Chris
# project name -> count of hg pushes
1994
pushes = Hash.new(0)
1995 975:198f764e734c Chris
1996
# project name -> count of hg archive requests (i.e. Download as Zip)
1997
zips = Hash.new(0)
1998
1999
# project name -> count of hits to pages under /projects/projectname
2000
hits = Hash.new(0)
2001
2002 978:bbb88c44f805 Chris
# project name -> Project object
2003
@projects = Hash.new
2004
2005 975:198f764e734c Chris
parseable = 0
2006
unparseable = 0
2007
2008 979:56a38a9f6204 Chris
def is_public_project?(project)
2009 978:bbb88c44f805 Chris
  if !project
2010
    false
2011 983:a97e573d7f87 Chris
  elsif project =~ /^\d+$/
2012
    # ignore numerical project ids, they are only used when editing projects
2013
    false
2014 978:bbb88c44f805 Chris
  elsif @projects.key?(project)
2015 979:56a38a9f6204 Chris
    @projects[project].is_public?
2016 978:bbb88c44f805 Chris
  else
2017
    pobj = Project.find_by_identifier(project)
2018
    if pobj
2019
      @projects[project] = pobj
2020 979:56a38a9f6204 Chris
      pobj.is_public?
2021 978:bbb88c44f805 Chris
    else
2022 979:56a38a9f6204 Chris
      print "Project not found: ", project, "\n"
2023 978:bbb88c44f805 Chris
      false
2024
    end
2025
  end
2026
end
2027
2028 980:9b4919de5317 Chris
def print_stats(h)
2029
  h.keys.sort { |a,b| h[b] <=> h[a] }.each do |p|
2030 982:6edb748be064 Chris
    if h[p] > 0
2031 983:a97e573d7f87 Chris
      print h[p], " ", @projects[p].name, " [", p, "]\n"
2032 982:6edb748be064 Chris
    end
2033 980:9b4919de5317 Chris
  end
2034
end
2035
2036 979:56a38a9f6204 Chris
STDIN.each do |line|
2037 975:198f764e734c Chris
2038
  record = parser.parse(line)
2039
2040
  # most annoyingly, the parser can't handle the comma-separated list
2041
  # in X-Forwarded-For where it has more than one element. If it has
2042 983:a97e573d7f87 Chris
  # failed, remove any IP addresses or the word "unknown" with
2043
  # trailing commas and try again
2044 975:198f764e734c Chris
  if not record
2045 983:a97e573d7f87 Chris
    filtered = line.gsub(/(unknown|([0-9]+\.){3}[0-9]+),\s*/, "")
2046 975:198f764e734c Chris
    record = parser.parse(filtered)
2047
  end
2048
2049
  # discard, but count, unparseable lines
2050
  if not record
2051 979:56a38a9f6204 Chris
    print "Line not parseable: ", line, "\n"
2052 975:198f764e734c Chris
    unparseable += 1
2053
    next
2054
  end
2055
2056
  # discard everything that isn't a 200 OK response
2057
  next if record["%>s"] != "200"
2058
2059
  # discard anything apparently requested by a crawler
2060
  next if record["%{User-Agent}i"] =~ /(bot|slurp|crawler|spider|Redmine)\b/i
2061
2062
  # pull out request e.g. GET / HTTP/1.0
2063
  request = record["%r"]
2064
2065
  # split into method, path, protocol
2066
  if not request =~ /^[^\s]+ ([^\s]+) [^\s]+$/
2067 979:56a38a9f6204 Chris
    print "Line not parseable (bad method, path, protocol): ", line, "\n"
2068 975:198f764e734c Chris
    unparseable += 1
2069
    next
2070
  end
2071
2072
  # get the path e.g. /projects/weevilmatic and split on /
2073
  path = $~[1]
2074
  components = path.split("/")
2075
2076
  # should have at least two elements unless path is "/"; first should
2077
  # be empty (begins with /)
2078
  if path != "/" and (components.size < 2 or components[0] != "")
2079 979:56a38a9f6204 Chris
    print "Line not parseable (degenerate path): ", line, "\n"
2080 975:198f764e734c Chris
    unparseable += 1
2081
    next
2082
  end
2083
2084
  if components[1] == "hg"
2085
2086
    # path is /hg/project?something or /hg/project/something
2087
2088
    project = components[2].split("?")[0]
2089 979:56a38a9f6204 Chris
    if not is_public_project?(project)
2090 978:bbb88c44f805 Chris
      next
2091
    end
2092 975:198f764e734c Chris
2093
    if components[2] =~ /&roots=00*$/
2094
      clones[project] += 1
2095
    elsif components[2] =~ /cmd=capabilities/
2096
      pulls[project] += 1
2097 978:bbb88c44f805 Chris
    elsif components[2] =~ /cmd=unbundle/
2098
      pushes[project] += 1
2099 975:198f764e734c Chris
    elsif components[3] == "archive"
2100
      zips[project] += 1
2101
    end
2102
2103
  elsif components[1] == "projects"
2104
2105
    # path is /projects/project or /projects/project/something
2106
2107
    project = components[2]
2108 979:56a38a9f6204 Chris
    project = project.split("?")[0] if project
2109
    if not is_public_project?(project)
2110 978:bbb88c44f805 Chris
      next
2111 975:198f764e734c Chris
    end
2112
2113 978:bbb88c44f805 Chris
    hits[project] += 1
2114
2115 975:198f764e734c Chris
  end
2116
2117
  parseable += 1
2118
end
2119
2120
# Each clone is also a pull; deduct it from the pulls hash, because we
2121
# want that to contain only non-clone pulls
2122
2123
clones.keys.each do |project|
2124
  pulls[project] -= 1
2125
end
2126
2127 982:6edb748be064 Chris
print parseable, " parseable\n"
2128
print unparseable, " unparseable\n"
2129
2130
2131 980:9b4919de5317 Chris
print "\nMercurial clones:\n"
2132
print_stats clones
2133
2134
print "\nMercurial pulls (excluding clones):\n"
2135
print_stats pulls
2136
2137
print "\nMercurial pushes:\n"
2138
print_stats pushes
2139
2140
print "\nMercurial archive (zip file) downloads:\n"
2141
print_stats zips
2142
2143 982:6edb748be064 Chris
print "\nProject page hits (excluding crawlers):\n"
2144 980:9b4919de5317 Chris
print_stats hits
2145 975:198f764e734c Chris
2146
2147 1536:e2a3230f61fa Chris
2148
# Print out an authormap file for hg-to-git conversion using
2149
# hg-fast-export
2150
#
2151
# Invoke with the project identifier as argument, e.g.
2152
#
2153
# ./script/rails runner -e production extra/soundsoftware/get-repo-authormap.rb soundsoftware-site
2154
2155 1537:e55cbb9ba8bf Chris
proj_ident = ARGV.last
2156 1536:e2a3230f61fa Chris
proj = Project.find_by_identifier(proj_ident)
2157
repo = Repository.where(:project_id => proj.id).first
2158
csets = Changeset.where(:repository_id => repo.id)
2159
committers = csets.map do |c| c.committer end.sort.uniq
2160
committers.each do |c|
2161 1537:e55cbb9ba8bf Chris
  if not c =~ /[^<]+<.*@.*>/ then
2162
    u = repo.find_committer_user c
2163
    print "#{c}=#{u.name} <#{u.mail}>\n" unless u.nil?
2164
  end
2165 1536:e2a3230f61fa Chris
end
2166 970:6bd8364eafae luis
2167 1453:b554eb79ec7b luis
# Log user and project information
2168
#
2169
# Invoke with e.g.
2170
#
2171
# ./script/rails runner -e production extra/soundsoftware/get-statistics.rb
2172 970:6bd8364eafae luis
#
2173
2174 1454:02a05da0bedc luis
projectStats =  {
2175
        :all => Project.active.all.count,
2176
        :private => Project.active.find(:all, :conditions => {:is_public => false}).count,
2177
        :top_level => Project.active.find(:all, :conditions => {:parent_id => nil}).count,
2178
        :top_level_and_private => Project.active.find(:all, :conditions => {:is_public => false, :parent_id => nil}).count
2179
      }
2180 970:6bd8364eafae luis
2181 1453:b554eb79ec7b luis
userStats = {:all => User.active.all.count}
2182 1002:f6ede18f3e6e Chris
2183 1453:b554eb79ec7b luis
stats = {:date => Date.today, :projects => projectStats, :users => userStats}.to_json
2184 1002:f6ede18f3e6e Chris
2185 1453:b554eb79ec7b luis
print "#{stats}\n"
2186 1002:f6ede18f3e6e Chris
2187 383:47ae83ce8db8 Chris
<div style="clear: both; float: right"><small><i>Produced by mtree2html by Hartmut Pohlheim</i></small></div>
2188
# configuration file for generation of html-docu from m-files
2189
#
2190
# Author:   Hartmut Pohlheim
2191
# History:  05.11.2000  file created (parameters for mtree2html2001)
2192
#
2193
# The following options/variables must be changed/adapted:
2194
#   dirmfiles
2195
#   dirhtml
2196
#   csslink
2197
#   texttitleframelayout
2198
#   texttitlefiles
2199
#
2200
# The following options/variables should be adapted:
2201
#   authorfile
2202
#   filenametopframe
2203
#   codeheadmeta
2204
2205
#========================================================================
2206
# Variables (possible keywords: set)
2207
# to use the built-in settings, comment the line using # in first column
2208
#========================================================================
2209
2210
#------------------------------------------------------------------------
2211
# dirmfiles: name of directory containing Matlab m-files
2212
# dirhtml: name of directory to place the html-files into
2213
# exthtml: extension used for the html files (.html or .htm)
2214
#          don't forget the point in front of the extension
2215
#------------------------------------------------------------------------
2216
set dirmfiles = .
2217
set dirhtml = doc-output
2218
set exthtml = .html
2219
2220
#------------------------------------------------------------------------
2221
# authorfile:   name of file containing info about author (in html)
2222
#               if defined, this text is included at the bottom of the
2223
#               html files
2224
#------------------------------------------------------------------------
2225 410:675de8e6becf chris
set authorfile = matlab-docs-credit.html
2226 383:47ae83ce8db8 Chris
2227
#------------------------------------------------------------------------
2228
# csslink:   text for linking to css file (style sheets)
2229
#            the text defined here is directly included into the head
2230
#            of the html file
2231
#------------------------------------------------------------------------
2232 410:675de8e6becf chris
#set csslink = <link rel=stylesheet type="text/css" href="CSSFILENAME.css" />
2233 383:47ae83ce8db8 Chris
2234
#------------------------------------------------------------------------
2235
# links2filescase: this is a bit difficult
2236
#                  Matlab is case sensitive on UNIX, but case insensitive
2237
#                  on Windows. Under UNIX Matlab function calls work
2238
#                  only, when the case of file name and function call are
2239
#                  identical, under Windows you can do what you want.
2240
#                  This scripts help you, to keep an exact case in your
2241
#                  project.
2242
#          exact - internal links are only generated, when case of file
2243
#                  name and in source code are identical
2244
#            all - case doesn't matter
2245
#     exactupper - same as exact, additionally links are also vreated to
2246
#                  all upper case function names in source code (often
2247
#                  used by Mathworks)
2248
#      exactvery - same as exact, additionally info about not matching
2249
#                  case is written to screen (stdout), this can be very
2250
#                  helpful in cleaning up the case in a project
2251
#------------------------------------------------------------------------
2252
set links2filescase = all
2253
2254
#------------------------------------------------------------------------
2255
# texttitleframelayout:    text of title for frame layout file (whole docu)
2256
#------------------------------------------------------------------------
2257 389:0bc92382a86b chris
set texttitleframelayout = MATLAB Function Documentation
2258 383:47ae83ce8db8 Chris
2259
#------------------------------------------------------------------------
2260
# texttitle/headerindexalldirs: text of title and header for directory index
2261
#------------------------------------------------------------------------
2262
set texttitleindexalldirs = Index of Directories
2263
set textheaderindexalldirs = Index of Directories
2264
2265
#------------------------------------------------------------------------
2266
# texttitle/headerindex:    text of title and header for index file
2267
#------------------------------------------------------------------------
2268
set texttitleindex = A-Z Index of Functions
2269
set textheaderindex = A-Z Index of Functions
2270
2271
#------------------------------------------------------------------------
2272
# texttitle/headerfiles:    text of title and header for files
2273
#                           name of file will be added at the end
2274
#------------------------------------------------------------------------
2275 389:0bc92382a86b chris
set texttitlefiles = Function
2276 383:47ae83ce8db8 Chris
set textheaderfiles = Documentation of
2277
2278
#------------------------------------------------------------------------
2279
# frames: whether to use frames in layout (yes or no)
2280
#------------------------------------------------------------------------
2281
set frames = no
2282
2283
#------------------------------------------------------------------------
2284
# filenametopframe: name of file including frame layout (highest level file)
2285
# [default: index]
2286
#------------------------------------------------------------------------
2287
set filenametopframe = index
2288
2289
#------------------------------------------------------------------------
2290
# textjumpindexglobal: text displayed for jump to index of all files
2291
#                      (global)
2292
# textjumpindexlocal:  text displayed for jump to index of files in actual
2293
#                      directory (local)
2294
#------------------------------------------------------------------------
2295 389:0bc92382a86b chris
set textjumpindexglobal = <b>Index of</b> all files:
2296
set textjumpindexlocal = this subdirectory only:
2297 383:47ae83ce8db8 Chris
2298
#------------------------------------------------------------------------
2299
# includesource: include source of m-files in documentation [YES|no]
2300
#------------------------------------------------------------------------
2301
set includesource = yes
2302
2303
#------------------------------------------------------------------------
2304
# usecontentsm: use contents.m files as well for structured
2305
#               (hopefully) index [YES|no]
2306
#------------------------------------------------------------------------
2307
set usecontentsm = no
2308
2309
#------------------------------------------------------------------------
2310
# includesource: write/update contents.m files [yes|NO]
2311
#------------------------------------------------------------------------
2312
set writecontentsm = no
2313
2314
#------------------------------------------------------------------------
2315
# processtree:  parse whole directory tree recursively [YES|no]
2316
#------------------------------------------------------------------------
2317
set processtree = yes
2318
2319
#------------------------------------------------------------------------
2320
# producetree:  produce tree for html-files in same structure than
2321
#		          tree of m-files [yes|NO]
2322
#               if no, all files are saved in the same directory, often
2323
#               easier for outside linking to files
2324
#------------------------------------------------------------------------
2325 401:a0f6e994657f chris
set producetree = yes
2326 383:47ae83ce8db8 Chris
2327
#------------------------------------------------------------------------
2328
# codebodyindex/files: HTML-code for adding to BODY tag
2329
#                      can be used for defining colors and
2330
#                      backgroundimages of the files
2331
#                      No longer recommended, use the css file
2332
#------------------------------------------------------------------------
2333
set codebodyindex =
2334
set codebodyfiles =
2335
2336
#------------------------------------------------------------------------
2337
# codeheadmeta: HTML-code added in HEAD area, use for supplying META info
2338
#------------------------------------------------------------------------
2339
set codeheadmeta =
2340
2341
#------------------------------------------------------------------------
2342
# codehr: HTML-code used to define a <HR>, do what you want
2343
#------------------------------------------------------------------------
2344 411:e7ba81c8dc5a chris
set codehr = <hr>
2345 383:47ae83ce8db8 Chris
2346
#------------------------------------------------------------------------
2347
# codeheader: HTML-code added to <H*> tags, use for centering header text
2348
#             or changing the colour/size/font of the header text
2349
#------------------------------------------------------------------------
2350 389:0bc92382a86b chris
set codeheader =
2351 383:47ae83ce8db8 Chris
2352
2353
# End of parameter file
2354 381:2dc8163e9150 Chris
@rem = '--*-Perl-*--';
2355
@rem = '
2356
@echo off
2357
perl -w -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
2358
goto endofperl
2359
@rem ';
2360
# perl -w -S %0.bat "$@"
2361 382:baff1c482d98 Chris
#!/usr/bin/perl
2362 381:2dc8163e9150 Chris
#
2363
# mtree2html_2000 - produce html files from Matlab m-files.
2364
#                   use configuration file for flexibility
2365
#                   can process tree of directories
2366
#
2367
# Copyright (C) 1996-2000 Hartmut Pohlheim.  All rights reserved.
2368
# includes small parts of m2html from Jeffrey C. Kantor 1995
2369
#
2370
# Author:  Hartmut Pohlheim
2371
# History: 06.03.1996  file created
2372
#          07.03.1996  first working version
2373
#          08.03.1996  modularized, help text only once included
2374
#          11.03.1996  clean up, some functions rwritten
2375
#          18.04.1996  silent output with writing in one line only
2376
#                      version 0.20 fixed
2377
#          14.05.1996  start of adding tree structure, could create tree
2378
#          15.05.1996  creating of index files for every directory
2379
#          17.05.1996  first working version except compact A-Z index
2380
#          20.05.1996  cleanup of actual version, more variables and
2381
#                      configurable settings
2382
#          21.05.1996  reading, update and creation of contents.m added
2383
#          22.05.1996  creation of short index started
2384
#          28.05.1996  jump letters for short index,
2385
#                      3 different directory indexes (short/long/contents)
2386
#          29.05.1996  major cleanup, short and long index created from one function
2387
#                      links for HTML and Indexes from 1 function,
2388
#                      version 0.9
2389
#          30.05.1996  contents.m changed to Contents.m (because unix likes it)
2390
#                      function definition can be in first line of m file before comments
2391
#                      version 0.91 fixed
2392
#          03.06.1996  contents file can be written as wanted, the links will be correct
2393
#                      cross references in help block of m-file will be found and
2394
#                      converted, even if the name of the function is written upper case
2395
#                      version 0.92 fixed
2396
#          05.06.1996  construction of dependency matrix changed, is able now to process
2397
#                      even the whole matlab tree (previous version needed to much memory)
2398
#                      removed warning for contents files in different directories
2399
#                      version 0.94 fixed
2400
#          06.06.1996  new link name matrices for ConstructHTMLFile created,
2401
#                      everything is done in ConstructDependencyMatrix,
2402
#                      both dependencies (calls and called) and matrix
2403
#                      with all mentioned names in this m-file, thus, much
2404
#                      less scanning in html construction
2405
#                      script is now (nearly) linear scalable, thus, matlab-toolbox
2406
#                      tree takes less than 1 hour on a Pentium120, with source
2407
#                      version 0.96 fixed
2408
#          10.06.1996  order of creation changed, first all indexes (includes
2409
#                      update/creation of contents.m) and then ConstructDepency
2410
#                      thus, AutoAdd section will be linked as well
2411
#                      excludenames extended, some more common word function names added
2412
#                      version 0.97 fixed
2413
#          17.02.1998  writecontentsm as command line parameter added
2414
#                      error of file not found will even appear when silent
2415
#                      version 1.02
2416
#          21.05.2000  mark comments in source code specially (no fully correct,
2417
#                      can't handle % in strings)
2418
#                      version 1.11
2419
#          05.11.2000  link also to upper and mixed case m-files
2420
#                      searching for .m files now really works (doesn't find grep.com any longer)
2421
#                      file renamed to mtree2html2001
2422
#                      generated html code now all lower case
2423
#                      inclusion of meta-description and meta-keywords in html files
2424
#                      HTML4 compliance done (should be strict HTML4.0, quite near XHTML)
2425
#                      version 1.23
2426
#
2427 383:47ae83ce8db8 Chris
#	   29.03.2011  (Chris Cannam) add frames option.
2428 381:2dc8163e9150 Chris
2429
$VERSION  = '1.23';
2430
($PROGRAM = $0) =~ s@.*/@@; $PROGRAM = "\U$PROGRAM\E";
2431 411:e7ba81c8dc5a chris
$debug = 1;
2432 381:2dc8163e9150 Chris
2433
#------------------------------------------------------------------------
2434
# Define platform specific things
2435
#------------------------------------------------------------------------
2436
# suffix for files to search is defined twice
2437
# the first ($suffix) is for string creation and contains the . as well
2438
# the second ($suffixforsearch) is for regular expression, handling of . is quite special
2439
$suffix = ".m";
2440
$suffixforsearch = "m";
2441
# the directory separator
2442
$dirsep = "/";
2443
# what is the current directory
2444
$diract = ".";
2445
2446
#------------------------------------------------------------------------
2447 382:baff1c482d98 Chris
#  Define all variables and their standard settings
2448 381:2dc8163e9150 Chris
#  documentation of variables is contained in accompanying rc file
2449
#------------------------------------------------------------------------
2450
%var =
2451
(
2452
   'authorfile',                '',
2453
   'codebodyfiles',             '',
2454
   'codebodyindex',             '',
2455
   'codeheadmeta',              '<meta name="author of conversion perl script" content="Hartmut Pohlheim" />',
2456
   'codehr',                    '<hr size="3" noshade="noshade" />',
2457
   'codeheader',                '',
2458 383:47ae83ce8db8 Chris
   'configfile',                'matlab-docs.conf',
2459 381:2dc8163e9150 Chris
   'csslink',                   '',
2460
   'dirmfiles',                 $diract,
2461
   'dirhtml',                   $diract,
2462
   'exthtml',                   '.html',
2463 382:baff1c482d98 Chris
   'frames',                    'yes',
2464 381:2dc8163e9150 Chris
   'filenametopframe',          'index',
2465
   'filenameindexlongglobal',   'indexlg',
2466
   'filenameindexlonglocal',    'indexll',
2467
   'filenameindexshortglobal',  'indexsg',
2468
   'filenameindexshortlocal',   'indexsl',
2469
   'filenameextensionframe',    'f',
2470
   'filenameextensionindex',    'i',
2471
   'filenameextensionjump',     'j',
2472
   'filenamedirshort',          'dirtops',
2473
   'filenamedirlong',           'dirtopl',
2474
   'filenamedircontents',       'dirtopc',
2475
   'includesource',             'yes',
2476
   'links2filescase',           'all',
2477
   'processtree',               'yes',
2478
   'producetree',               'yes',
2479
   'textjumpindexlocal',        'Local Index',
2480
   'textjumpindexglobal',       'Global Index',
2481
   'texttitleframelayout',      'Documentation of Matlab Files',
2482
   'texttitleindexalldirs',     'Index of Directories',
2483
   'textheaderindexalldirs',    'Index of Directories',
2484
   'texttitleindex',            '',
2485
   'textheaderindex',           '',
2486
   'texttitlefiles',            'Documentation of ',
2487
   'textheaderfiles',           'Documentation of ',
2488
   'usecontentsm',              'yes',
2489
   'writecontentsm',            'no'
2490
);
2491
2492
2493
# define all m-file names, that should be excluded from linking
2494
# however, files will still be converted
2495
@excludenames = ( 'all','ans','any','are',
2496
                  'cs',
2497
                  'demo','dos',
2498
                  'echo','edit','else','elseif','end','exist',
2499
                  'flag','for','function',
2500
                  'global',
2501
                  'help',
2502
                  'i','if','inf','info',
2503
                  'j',
2504
                  'more',
2505
                  'null',
2506
                  'return',
2507
                  'script','strings',
2508
                  'what','which','while','who','whos','why',
2509
                );
2510
2511
# Text for inclusion in created HTML/Frame files: Doctype and Charset
2512
$TextDocTypeHTML  = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN" "http://www.w3.org/TR/REC-html40/strict.dtd">';
2513
$TextDocTypeFrame = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Frameset//EN" "http://www.w3.org/TR/REC-html40/frameset.dtd">';
2514
$TextMetaCharset = '<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />';
2515
2516
#------------------------------------------------------------------------
2517
# Read the command line arguments
2518
#------------------------------------------------------------------------
2519
if (@ARGV == 0) {
2520
   &DisplayHelp()  if &CheckFileName($var{'configfile'}, 'configuration file');
2521
}
2522
2523
# Print provided command line arguments on screen
2524
foreach (@ARGV) { print "   $_\n      "; }
2525
2526
# Get the options
2527
use Getopt::Long;
2528
@options = ('help|h', 'todo|t', 'version|v',
2529
            'authorfile|a=s', 'configfile|c=s', 'dirhtml|html|d=s',
2530
            'dirmfiles|mfiles|m=s', 'includesource|i=s',
2531
            'processtree|r=s', 'producetree|p=s',
2532
            'silent|quiet|q', 'writecontentsm|w=s');
2533
&GetOptions(@options) || die "use -h switch to display help statement\n";
2534
2535
2536
# Display help or todo list, when requested
2537
&DisplayHelp()                         if $opt_help;
2538
&DisplayTodo()                         if $opt_todo;
2539
die "$PROGRAM v$VERSION\n"             if $opt_version;
2540
2541
$exit_status = 0;
2542
2543
#------------------------------------------------------------------------
2544
# Read the config file
2545
#------------------------------------------------------------------------
2546
$var{'configfile'} = $opt_configfile         if $opt_configfile;
2547
&GetConfigFile($var{'configfile'});
2548
2549
2550
#------------------------------------------------------------------------
2551
# Process/Check the command line otions
2552
#------------------------------------------------------------------------
2553
$var{'dirhtml'}   = $opt_dirhtml              if $opt_dirhtml;
2554
if (!(substr($var{'dirhtml'}, -1, 1) eq $dirsep)) { $var{'dirhtml'} = $var{'dirhtml'}.$dirsep; }
2555
$var{'dirmfiles'} = $opt_dirmfiles            if $opt_dirmfiles;
2556
if (!(substr($var{'dirmfiles'}, -1, 1) eq $dirsep)) { $var{'dirmfiles'} = $var{'dirmfiles'}.$dirsep; }
2557
2558
$var{'authorfile'} = $opt_author              if $opt_author;
2559
$var{'includesource'} = $opt_includesource    if $opt_includesource;
2560
if ($var{'includesource'} ne 'no') { $var{'includesource'} = 'yes'; }
2561
$var{'processtree'} = $opt_processtree        if $opt_processtree;
2562
if ($var{'processtree'} ne 'no') { $var{'processtree'} = 'yes'; }
2563
$var{'producetree'} = $opt_producetree        if $opt_producetree;
2564
if ($var{'producetree'} ne 'no') { $var{'producetree'} = 'yes'; }
2565
if ($var{'processtree'} eq 'no') { $var{'producetree'} = 'no'; }
2566 382:baff1c482d98 Chris
if ($var{'frames'} ne 'no') { $var{'frames'} = 'yes'; }
2567 381:2dc8163e9150 Chris
# if (($var{'processtree'} eq 'yes') && ($var{'producetree'} eq 'no')) { $var{'usecontentsm'} = 'no'; }
2568
2569
$var{'writecontentsm'} = $opt_writecontentsm  if $opt_writecontentsm;
2570
2571
#------------------------------------------------------------------------
2572
# Do the real stuff
2573
#------------------------------------------------------------------------
2574
2575
# Print variables on screen, when not silent
2576
&ListVariables                          if !$opt_silent;
2577
2578
# Check the author file
2579
if ($var{'authorfile'} ne '') {
2580 410:675de8e6becf chris
    if (!($var{'authorfile'} =~ m,^/,)) {
2581
	# relative path: treat as relative to config file
2582
	my $cfd = $var{'configfile'};
2583
	$cfd =~ s,/[^/]*$,/,;
2584
	$cfd =~ s,^[^/]*$,.,;
2585
	$var{'authorfile'} = "$cfd/" . $var{'authorfile'};
2586
    }
2587
    if (&CheckFileName($var{'authorfile'}, 'author file')) {
2588
	$var{'authorfile'} = '';
2589
	if (!$opt_silent) { print "   Proceeding without author information!\n"; }
2590
    }
2591 381:2dc8163e9150 Chris
}
2592
2593
# Call the function doing all the real work
2594
&ConstructNameMatrix;
2595
2596
&ConstructDependencyMatrix;
2597
2598
&ConstructAllIndexFiles;
2599
2600
&ConstructHTMLFiles;
2601
2602
exit $exit_status;
2603
2604
#------------------------------------------------------------------------
2605
# Construct list of all mfile names and initialize various data arrays.
2606
#------------------------------------------------------------------------
2607
sub ConstructNameMatrix
2608
{
2609
   local(*MFILE);
2610
   local($file, $dirname);
2611
   local(@newdirectories);
2612
   local(%localnames);
2613
2614
   $RecDeep = 0;
2615
   &ParseTreeReadFiles($var{'dirmfiles'}, $RecDeep);
2616
2617
   foreach $dirname (@directories) {
2618
      if ($dirnumbermfiles{$dirname} > 0) {
2619
         push(@newdirectories, $dirname);
2620
         if (! defined($contentsname{$dirname})) {
2621
            $contentsname{$dirname} = 'Contents';
2622
            if (($var{'writecontentsm'} eq 'no') && ($var{'usecontentsm'} eq 'yes')) {
2623
               print "\r ParseTree - for directory  $dirname  no contents file found!\n";
2624
               print   "             create one or enable writing of contents file (writecontentsm = yes)!\n";
2625
            }
2626
         }
2627
      }
2628
   }
2629
   @alldirectories = @directories;
2630
   @directories = @newdirectories;
2631
2632
   foreach $dirname (@directories) {
2633
      if ($debug > 0) { print "Dir: $dirname \t\t $dirnumbermfiles{$dirname} \t$contentsname{$dirname}\n"; }
2634
   }
2635
2636
   @names = sort(keys %mfile);
2637
2638
   # check, if name of directory is identical to name of file
2639
   @dirsinglenames = values(%dirnamesingle);
2640
   grep($localnames{$_}++, @dirsinglenames);
2641
   @dirandfilename = grep($localnames{$_}, @names);
2642
   if (@dirandfilename) {
2643
      print "\r   Name clash between directory and file name: @dirandfilename\n";
2644
      print   "      These files will be excluded from linking!\n";
2645
      push(@excludenames, @dirandfilename);
2646
   }
2647
2648
   # construct names matrix for help text linking
2649
   #    exclude some common words (and at the same time m-functions) from linking in help text
2650
   grep($localnames{$_}++, @excludenames);
2651
   @linknames = grep(!$localnames{$_}, @names);
2652
2653
   if ($debug > 2) { print "linknames (names of found m-files):\n    @linknames\n"; }
2654
2655
}
2656
2657
#------------------------------------------------------------------------
2658
# Parse tree and collect all Files
2659
#------------------------------------------------------------------------
2660
sub ParseTreeReadFiles
2661
{
2662
   local($dirname, $localRecDeep) = @_;
2663
   local($file, $name, $filewosuffix);
2664
   local($dirhtmlname, $dirmode);
2665
   local($relpath, $relpathtoindex, $replacevardir);
2666
   local(*CHECKDIR, *AKTDIR);
2667
   local(@ALLEFILES);
2668
2669
   opendir(AKTDIR, $dirname) || die "ParseTree - Can't open directory $dirname: $!";
2670
   if ($debug > 1) { print "\nDirectory: $dirname\n"; }
2671
2672
   # create relative path
2673
   $_ = $dirname; $replacevardir = $var{'dirmfiles'};
2674
   s/$replacevardir//; $relpath = $_;
2675
   s/[^\/]+/../g; $relpathtoindex = $_;
2676
2677
   # producetree no
2678
   if ($var{'producetree'} eq 'no') { $relpath = ''; $relpathtoindex = ''; }
2679
2680
   # names of directories (top-level and below top-level m-file-directory)
2681
   push(@directories, $dirname);
2682
   $dirnumbermfiles{$dirname} = 0;    # set number of m-files for this dir to zero
2683
   # relative path from top-level directory, depends on directory name
2684
   $dirnamerelpath{$dirname} = $relpath;
2685
   # relative path from actual directory to top-level directory, depends on directory name
2686
   $dirnamerelpathtoindex{$dirname} = $relpathtoindex;
2687
   # recursion level for directory, depends on directory name
2688
   $dirnamerecdeep{$dirname} = $localRecDeep;
2689
2690
   # only the name of the directory, without path
2691
   $rindexprint = rindex($dirname, $dirsep, length($dirname)-2);
2692
   $rindsub = substr($dirname, $rindexprint+1, length($dirname)-$rindexprint-2);
2693
   $dirnamesingle{$dirname} = $rindsub;
2694
2695
   # create name of html-directories
2696
   $_ = $dirname;
2697
   s/$var{'dirmfiles'}/$var{'dirhtml'}/;
2698
   $dirhtmlname = $_;
2699
   if ($var{'producetree'} eq 'no') { $dirhtmlname = $var{'dirhtml'}; }
2700
   # try to open html directory, if error, then create directory,
2701
   # use same mode as for corresponding m-file directory
2702
   opendir(CHECKDIR,"$dirhtmlname") || do {
2703
      $dirmode = (stat($dirname))[2]; # print "$dirmode\n";
2704
      mkdir("$dirhtmlname", $dirmode) || die ("Cannot create directory $dirhtmlname: $! !");
2705
   };
2706
   closedir(CHECKDIR);
2707
2708
2709
   # read everything from this directory and process them
2710
   @ALLEFILES = readdir(AKTDIR);
2711
2712
   foreach $file (@ALLEFILES) {
2713
      # exclude . and .. directories
2714
      next if $file eq '.';  next if $file eq '..';
2715
2716
      # test for existense of entry (redundant, used for debugging)
2717
      if (-e $dirname.$file) {
2718
         # if it's a directory, call this function recursively
2719
         if (-d $dirname.$file) {
2720
            if ($var{'processtree'} eq 'yes') {
2721
               &ParseTreeReadFiles($dirname.$file.$dirsep, $localRecDeep+1);
2722
            }
2723
         }
2724
         # if it's a file - test for m-file, save name and create some arrays
2725
         elsif (-f $dirname.$file) {
2726
            if ($file =~ /\.$suffixforsearch$/i) {
2727
               # Remove the file suffix to establish the matlab identifiers
2728
               $filewosuffix = $file;
2729
               $filewosuffix =~ s/\.$suffixforsearch$//i;
2730
               # $filename = $name;
2731
2732
               # Contents file in unix must start with a capital letter (Contents.m)
2733
               # ensure, that m-file name is lower case, except the contents file
2734
               if (! ($filewosuffix =~ /^contents$/i)) {
2735 388:dad587ecb8d0 chris
		   # if ($var{'links2filescase'}  eq 'low') { $filewosuffix = "\L$filewosuffix\E"; }
2736 381:2dc8163e9150 Chris
                  $filewosuffixlow = "\L$filewosuffix\E";
2737
               }
2738
               else { $contentsname{$dirname} = $filewosuffix; }
2739
2740
               # internal handle name is always lower case
2741
               $name     = $filewosuffixlow;
2742
               # file name is not lower case
2743
               $filename = $filewosuffix;
2744
2745
               # if don't use C|contents.m, then forget all C|contents.m
2746
               if ($var{'usecontentsm'} eq 'no') { if ($name =~ /contents/i) { next; } }
2747
2748
               # if m-file with this name already exists, use directory and name for name
2749
               # only the first occurence of name will be used for links
2750
               if (defined $mfile{$name}) {
2751
                  if (! ($name =~ /^contents$/i) ) {
2752
                     print "\r ParseTree - Name conflict:  $name in $dirname already exists: $mfile{$name} !\n";
2753
                     print   "             $mfile{$name}  will be used for links!\n";
2754
                  }
2755
                  $name = $dirname.$name;
2756
               }
2757
               # mfile name with path
2758
               $mfile{$name} = $dirname.$file;
2759
               # mfile name (without path)
2760
               $mfilename{$name} = $filename;
2761
               # mfile directory
2762
               $mfiledir{$name} = $dirname;
2763
2764
               # html file name and full path, special extension of Contents files
2765
               if ($name =~ /contents/i) { $extrahtmlfilename = $dirnamesingle{$dirname}; }
2766
               else { $extrahtmlfilename = ''; }
2767
               $hfile{$name} = $dirhtmlname.$mfilename{$name}.$extrahtmlfilename.$var{'exthtml'};
2768
2769
               # save relative html path
2770
               # if ($var{'producetree'} eq 'yes') {
2771
               $hfilerelpath{$name} = $relpath;
2772
               # } else { # if no tree to produce, relative path is empty
2773
               #    $hfilerelpath{$name} = '';
2774
               # }
2775
2776
               # create relative path from html file to directory with global index file
2777
               $hfileindexpath{$name} = $relpathtoindex;
2778
2779
               # Function declaration, if one exists, set default to script
2780
               $synopsis{$name} = "";
2781
               $mtype{$name} = "script";
2782
2783
               # First comment line
2784
               $apropos{$name} = "";
2785
2786
               # count number of m-files in directories
2787
               $dirnumbermfiles{$dirname}++;
2788
2789
               if ($debug > 1) {
2790
                  if ($opt_silent) { print "\r"; }
2791
                  print "   ParseTree: $name \t\t $mfile{$name} \t\t $hfile{$name}\t\t";
2792
                  if (!$opt_silent) { print "\n"; }
2793
               }
2794
            }
2795
         }
2796
         else {
2797
            print "Unknown type of file in $dirname: $file\n";
2798
         }
2799
      }
2800
      else { print "Error: Not existing file in $dirname: $file\n"; }
2801
   }
2802
2803
   closedir(AKTDIR)
2804
2805
}
2806
2807
#------------------------------------------------------------------------
2808
# Construct Dependency matrix
2809
#    $dep{$x,$y} > 0 if $x includes a reference to $y.
2810
#------------------------------------------------------------------------
2811
sub ConstructDependencyMatrix
2812
{
2813
   &ConstructDependencyMatrixReadFiles('all');
2814
   &ConstructDependencyMatrixReally;
2815
}
2816
2817
2818
#------------------------------------------------------------------------
2819
# Construct Dependency matrix
2820
#    $dep{$x,$y} > 0 if $x includes a reference to $y.
2821
#------------------------------------------------------------------------
2822
sub ConstructDependencyMatrixReadFiles
2823
{
2824
   local($whatstring) = @_;
2825
   local(*MFILE);
2826
   local($name, $inames);
2827
   local(%symbolsdep, %symbolsall);
2828
2829
   # Initialize as all zeros.
2830
   # foreach $name (@names) { grep($dep{$name,$_}=0,@names); if ($debug > 0) { print "\r   DepMatrix anlegen: $name\t$#names\t"; } }
2831
2832
   # Compute the dependency matrix
2833
   $inames = -1;
2834
   foreach $name (@names) {
2835
      # Read each file and tabulate the distinct alphanumeric identifiers in
2836
      # an array of symbols. Also scan for:
2837
      #   synopsis: The function declaration line
2838
      #   apropos:  The first line of the help text
2839
2840
      # look for whatstring, if all: process every file, if contents: process only contents files
2841
      if ($whatstring eq 'contents') { if (! ($name =~ /contents$/i) ) { next; } }
2842
      elsif ($whatstring eq 'all') { }    # do nothing
2843
      else { print "\r   ConstructDependency: Unknown parameter whatstring: $whatstring \n"; }
2844
2845
      undef %symbolsall; undef %symbolsdep;
2846
      open(MFILE,"<$mfile{$name}") || die("Can't open $mfile{$name}: $!\n");
2847
      while (<MFILE>) {
2848
         chop;
2849
2850
         # Split on nonalphanumerics, then look for all words, used for links later
2851
         # this one for all references
2852
         @wordsall = grep(/[a-zA-Z]\w*/, split('\W',$_));
2853
         # set all words to lower case for link checking
2854
         undef @wordsall2;
2855
         # do case conversion not, case checking is done later
2856
         foreach (@wordsall) { push(@wordsall2, "\L$_\E"); }
2857
         # @wordsall2 = @wordsall;
2858
         grep($symbolsall{$_}++, @wordsall2);
2859
2860
         # Store first comment line, skip all others.
2861
         if (/^\s*%/) {
2862
            if (!$apropos{$name}) {
2863
               s/^\s*%\s*//;   # remove % and leading white spaces on line
2864
               $_ = &SubstituteHTMLEntities($_);
2865
               $apropos{$name} = $_;
2866
            }
2867
            next;
2868
         }
2869
2870
         # If it's the function declaration line, then store it and skip
2871
         # but only, when first function definition (multiple function lines when private subfunctions in file
2872
         if ($synopsis{$name} eq '') {
2873
            if (/^\s*function/) {
2874
               s/^\s*function\s*//;
2875
               $synopsis{$name} = $_;
2876
               $mtype{$name} = "function";
2877
               next;
2878
            }
2879
         }
2880
2881
         # Split off any trailing comments
2882
         if ($_ ne '') {
2883
            # this one for references in program code only
2884
            # when syntax parsing, here is a working place
2885
            ($statement) = split('%',$_,1);
2886
            @wordsdep = grep(/[a-zA-Z]\w*/,split('\W',$statement));
2887
            # do case conversion not, case checking is done later
2888
            undef @wordsdep2;
2889
            foreach (@wordsdep) { push(@wordsdep2, "\L$_\E"); }
2890
            grep($symbolsdep{$_}++, @wordsdep2);
2891
         }
2892
      }
2893
      close MFILE;
2894
2895
      # compute intersection between %symbolsall and @linknames
2896
      delete($symbolsall{$name});
2897
      # foreach $localsumall ($symbolsall) {
2898
      #    $localsumall = "\L$localsumall\E";
2899
      # }
2900
      @{'all'.$name} = grep($symbolsall{$_}, @linknames);
2901
2902
      # compute intersection between %symbolsdep and @linknames
2903
      delete($symbolsdep{$name});
2904
      @{'depcalls'.$name} = grep($symbolsdep{$_}, @linknames);
2905
2906
      $inames++; print "\r   DepCallsMatrix: $inames/$#names\t $name\t";
2907
      if ($debug > 2) { print "\n      depnames: @{'depcalls'.$name}\n      all: @{'all'.$name}\n"; }
2908
   }
2909
}
2910
2911
2912
#------------------------------------------------------------------------
2913
# Construct Dependency matrix
2914
#    $dep{$x,$y} > 0 if $x includes a reference to $y.
2915
#------------------------------------------------------------------------
2916
sub ConstructDependencyMatrixReally
2917
{
2918
   local($inames, $name);
2919
2920
   $inames = -1;
2921
   foreach $name (@names) { undef %{'depint'.$name}; }
2922
   foreach $name (@names) {
2923
      grep(${'depint'.$_}{$name}++, @{'depcalls'.$name});
2924
      $inames++; print "\r   DepCalledMatrix1: $inames/$#names\t $name\t";
2925
   }
2926
   $inames = -1;
2927
   foreach $name (@names) {
2928
      # compute intersection between %depint.name{$_} and @linknames
2929
      if (defined (%{'depint'.$name})) { @{'depcalled'.$name} = grep(${'depint'.$name}{$_}, @linknames); }
2930
      $inames++; print "\r   DepCalledMatrix2: $inames/$#names\t $name\t";
2931
      if ($debug > 2) { print "\n      depcalled: @{'depcalled'.$name}\n"; }
2932
   }
2933
2934
}
2935
2936
2937
#========================================================================
2938
# Construct all index files
2939
#========================================================================
2940
sub ConstructAllIndexFiles
2941
{
2942
   local(@localnames);
2943
   local($ActDir);
2944
   local($name);
2945
2946
   # define variables and names for frame target
2947
   $GlobalNameFrameMainLeft = 'Cont_Main';
2948
   $GlobalNameFrameMainRight = 'Cont_Lower';
2949
   $GlobalNameFrameAZIndexsmall = 'IndexAZindex';
2950
   $GlobalNameFrameAZIndexjump = 'IndexAZjump';
2951
2952
   $indexcreated = 0;
2953
2954
   &ConstructHighestIndexFile;
2955
   $indexcreated++;
2956
2957
   # if ($var{'producetree'} eq 'yes') {
2958
      # moved next 2 lines out of if for producetree no
2959
      # &ConstructHighestIndexFile;
2960
      # $indexcreated++;
2961
2962
      foreach $ActDir (@directories) {
2963
         undef @localnames;
2964
         foreach $name (@names) {
2965
            local($pathsubstr) = substr($mfile{$name}, 0, rindex($mfile{$name}, "/")+1);
2966
            if ($ActDir eq $pathsubstr) {
2967
               if ($debug > 1) { print "IndexFile: $pathsubstr    ActDir: $ActDir   Hfilerelpath: $hfilerelpath{$name}\n"; }
2968
               push(@localnames, $name);
2969
            }
2970
         }
2971
         if ($debug > 2) { print "localnames: @localnames\n"; }
2972
         # create contents file and short|long index of files in local directory
2973
         &ConstructContentsmFile($ActDir, @localnames);
2974
         &ConstructAZIndexFile($ActDir, 'short', 'local', @localnames);
2975
         &ConstructAZIndexFile($ActDir, 'long', 'local', @localnames);
2976
         $indexcreated+=2;
2977
      }
2978
   # } else {
2979
   #    &ConstructContentsmFile($var{'dirmfiles'}, @names);
2980
   # }
2981
2982
   # create short|long index of files in all directory
2983
   &ConstructAZIndexFile($var{'dirmfiles'}, 'short', 'global', @names);
2984
   &ConstructAZIndexFile($var{'dirmfiles'}, 'long', 'global', @names);
2985
   $indexcreated+=2;
2986
2987
   # if contents.m were created or updated, the dependency matrices should
2988
   # be updated as well
2989
   if ($var{'writecontentsm'} eq 'yes') { &ConstructDependencyMatrixReadFiles('contents');; }
2990
}
2991
2992
2993
#========================================================================
2994
# Construct the highest level index file
2995
#========================================================================
2996
sub ConstructHighestIndexFile
2997
{
2998
   local(*IFILE);
2999
   local($indexfile, $filename);
3000
3001
   # Build the frame layout file, this files includes the layout of the frames
3002
   # Build the frame layout file name (highest one)
3003
   $indexfile = $var{'dirhtml'}.$var{'filenametopframe'}.$var{'exthtml'};
3004
3005 382:baff1c482d98 Chris
   if ($var{'frames'} eq 'yes') {
3006 381:2dc8163e9150 Chris
3007 382:baff1c482d98 Chris
       open(IFILE,">$indexfile") || die("Cannot open frame layout file $indexfile\n");
3008 381:2dc8163e9150 Chris
3009 382:baff1c482d98 Chris
       # Write the header of frame file
3010
       print IFILE "$TextDocTypeFrame\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n";
3011
       print IFILE "   <title>$var{'texttitleframelayout'}</title>\n";
3012
       print IFILE "</head>\n";
3013 381:2dc8163e9150 Chris
3014 382:baff1c482d98 Chris
       # definition of 2 frames, left the tree of directories,
3015
       # right the index of that directory or the docu of a file
3016
       print IFILE "<frameset  cols=\"25%,75%\">\n";
3017
       print IFILE "   <frame src=\"$var{'filenamedirshort'}$var{'exthtml'}\" name=\"$GlobalNameFrameMainLeft\" />\n";
3018
       print IFILE "   <frame src=\"$var{'filenameindexshortglobal'}$var{'filenameextensionframe'}$var{'exthtml'}\" name=\"$GlobalNameFrameMainRight\" />\n";   print IFILE "</frameset>\n";
3019 381:2dc8163e9150 Chris
3020 382:baff1c482d98 Chris
       print IFILE "</html>\n";
3021
3022
       close(IFILE);
3023
3024
       if ($opt_silent) { print "\r"; }
3025
       print "   Frame layout file created: $indexfile\t";
3026
       if (!$opt_silent) { print "\n"; }
3027
   }
3028 381:2dc8163e9150 Chris
3029
   for($irun=0; $irun <= 2; $irun++) {
3030
      # Build the top directory index file, these files include the directory tree
3031
      # Build the directory tree index file name
3032
3033
      # Create no directory file for contents, when no contents to use
3034
      if (($irun == 2) && ($var{'usecontentsm'} eq 'no')) { next; }
3035
3036
      # Assign the correct index file name
3037
      if ($irun == 0) { $filename = $var{'filenamedirshort'}; }
3038
      elsif ($irun == 1) { $filename = $var{'filenamedirlong'}; }
3039
      elsif ($irun == 2) { $filename = $var{'filenamedircontents'}; }
3040
3041
      $indexfile = $var{'dirhtml'}.$filename.$var{'exthtml'};
3042
3043
      open(IFILE,">$indexfile") || die("Cannot open directory tree index file $indexfile\n");
3044
      # Write header of HTML file
3045
      print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3046
3047
      if ($var{'texttitleindexalldirs'} eq '') {
3048
         print IFILE "<title>Index of Directories of $var{'dirmfiles'}</title>\n";
3049
      } else {
3050
         print IFILE "<title>$var{'texttitleindexalldirs'}</title>\n";
3051
      }
3052 382:baff1c482d98 Chris
3053
      if ($var{'frames'} eq 'yes') {
3054
	  print IFILE "<base target=\"$GlobalNameFrameMainRight\" />\n";
3055
      }
3056
3057 381:2dc8163e9150 Chris
      print IFILE "</head>\n";
3058
      print IFILE "<body $var{'codebodyindex'}>\n";
3059 410:675de8e6becf chris
      print IFILE "<div id=\"matlabdoc\">\n";
3060 381:2dc8163e9150 Chris
      if ($var{'textheaderindexalldirs'} eq '') {
3061
         print IFILE "<h1 $var{'codeheader'}>Index of Directories of <em>$var{'dirmfiles'}</em></h1>\n";
3062
      } else {
3063
         print IFILE "<h1 $var{'codeheader'}>$var{'textheaderindexalldirs'}</h1>\n";
3064
      }
3065 389:0bc92382a86b chris
      print IFILE "<p>\n";
3066 382:baff1c482d98 Chris
3067
      if ($var{'frames'} eq 'yes') {
3068
	  if ($irun == 0) { print IFILE "<strong>short</strong>\n"; }
3069
	  else { print IFILE "<a href=\"$var{'filenamedirshort'}$var{'exthtml'}\" target=\"$GlobalNameFrameMainLeft\">short</a>\n"; }
3070
	  if ($irun == 1) { print IFILE " | <strong>long</strong>\n"; }
3071
	  else { print IFILE " | <a href=\"$var{'filenamedirlong'}$var{'exthtml'}\" target=\"$GlobalNameFrameMainLeft\">long</a>\n"; }
3072
	  if ($var{'usecontentsm'} eq 'yes') {
3073
	      if ($irun == 2) { print IFILE " | <strong>contents</strong>\n"; }
3074
	      else { print IFILE " | <a href=\"$var{'filenamedircontents'}$var{'exthtml'}\" target=\"$GlobalNameFrameMainLeft\">contents</a>\n"; }
3075
	  }
3076
      } else {
3077
	  if ($irun == 0) { print IFILE "<strong>short</strong>\n"; }
3078
	  else { print IFILE "<a href=\"$var{'filenamedirshort'}$var{'exthtml'}\">short</a>\n"; }
3079
	  if ($irun == 1) { print IFILE " | <strong>long</strong>\n"; }
3080
	  else { print IFILE " | <a href=\"$var{'filenamedirlong'}$var{'exthtml'}\">long</a>\n"; }
3081
	  if ($var{'usecontentsm'} eq 'yes') {
3082
	      if ($irun == 2) { print IFILE " | <strong>contents</strong>\n"; }
3083
	      else { print IFILE " | <a href=\"$var{'filenamedircontents'}$var{'exthtml'}\">contents</a>\n"; }
3084
	  }
3085 381:2dc8163e9150 Chris
      }
3086
3087
      print IFILE "</p><br />\n\n";
3088
      print IFILE "<ul>\n";
3089
3090
      # go through all directories and create a list entry for each one,
3091
      # depending on recursion level create sublists
3092
      $prevrecdeeplevel = 0;
3093
      foreach $name (@alldirectories) {
3094
         $actrecdeeplevel = $dirnamerecdeep{$name};
3095
         for( ; $prevrecdeeplevel < $actrecdeeplevel; $prevrecdeeplevel++ ) { print IFILE "<ul>\n"; }
3096
         for( ; $prevrecdeeplevel > $actrecdeeplevel; $prevrecdeeplevel-- ) { print IFILE "</ul>\n"; }
3097
         if ($irun == 0) { $indexfilenameused = $var{'filenameindexshortlocal'}.$var{'filenameextensionframe'}; }
3098
         elsif ($irun == 1) { $indexfilenameused = $var{'filenameindexlonglocal'}.$var{'filenameextensionframe'}; }
3099
         elsif ($irun == 2) { $indexfilenameused = $contentsname{$name}; }
3100
         else { die "ConstructHighestIndexFile: Unknown value of irun"; }
3101
         if ($dirnumbermfiles{$name} > 0) {
3102
            # producetree no
3103
            # if ($var{'producetree'} eq 'no') { $dirnamehere = ''; }
3104
            # else { $dirnamehere = '$dirnamerelpath{$name}'; }
3105
            # print IFILE "<LI><A HREF=\"$dirnamehere$indexfilenameused_$dirnamesingle{$name}$var{'exthtml'}\">$dirnamesingle{$name}</A>\n";
3106
            print IFILE "<li><a href=\"$dirnamerelpath{$name}$indexfilenameused$dirnamesingle{$name}$var{'exthtml'}\">$dirnamesingle{$name}</a></li>\n";
3107
         } else {
3108
            # print directories with no m-files inside not
3109
            # print IFILE "<li>$dirnamesingle{$name}</li>\n";
3110
         }
3111
      }
3112
      $actrecdeeplevel = 0;
3113
      for( ; $prevrecdeeplevel > $actrecdeeplevel; $prevrecdeeplevel-- ) { print IFILE "</ul>\n"; }
3114
      print IFILE "</ul>\n<br />$var{'codehr'}\n";
3115
3116
      # Include info about author from authorfile
3117
      &WriteFile2Handle($var{'authorfile'}, IFILE);
3118
3119
      print IFILE "<!--navigate-->\n";
3120
      print IFILE "<!--copyright-->\n";
3121 410:675de8e6becf chris
      print IFILE "</div>\n</body>\n</html>\n";
3122 381:2dc8163e9150 Chris
3123
      close(IFILE);
3124
3125
      if ($opt_silent) { print "\r"; }
3126
      print "   Directory - Indexfile created: $indexfile\t";
3127
      if (!$opt_silent) { print "\n"; }
3128
   }
3129
}
3130
3131
3132
#========================================================================
3133
# Construct the A-Z index file (global/local and/or short/long)
3134
#========================================================================
3135
sub ConstructAZIndexFile
3136
{
3137
   local($LocalActDir, $LocalShortLong, $LocalGlobalLocal, @localnames) = @_;
3138
   local(*IFILE);
3139
   local($name, $indexfilename, $dirpath);
3140
   local($firstletter, $firstone);
3141
3142
   if ($debug > 2) { print "localnames in AZ small: @localnames\n"; print "     ActDir in A-Z: $LocalActDir\n"; }
3143
3144
   # extract filename of index file from parameters of function
3145
   if ($LocalShortLong eq 'short') {
3146
      if ($LocalGlobalLocal eq 'global') { $indexfilename = $var{'filenameindexshortglobal'}; }
3147
      elsif ($LocalGlobalLocal eq 'local') { $indexfilename = $var{'filenameindexshortlocal'}; }
3148
      else { die "wrong parameter for LocalGlobalLocal in ConstructAZIndexFile: $LocalGlobalLocal."; }
3149
   } elsif ($LocalShortLong eq 'long') {
3150
      if ($LocalGlobalLocal eq 'global') { $indexfilename = $var{'filenameindexlongglobal'}; }
3151
      elsif ($LocalGlobalLocal eq 'local') { $indexfilename = $var{'filenameindexlonglocal'}; }
3152
      else { die "wrong parameter for LocalGlobalLocal in ConstructAZIndexFile: $LocalGlobalLocal."; }
3153
   } else { die "wrong parameter for LocalShortLong in ConstructAZIndexFile: $LocalShortLong."; }
3154
3155
   # producetree no
3156
   # if ($var{'producetree'} eq 'no') { $dirnamehere = ''; }
3157
   # else { $dirnamehere = '$dirnamerelpath{$LocalActDir}'; }
3158
   # Build the index file name
3159
   # handle the global index file case separately (no extra directory name in file)
3160
   #    the local index file name must be extended by the name of the directory
3161
   if ($LocalGlobalLocal eq 'global') { $extradirfilename = ''; }
3162
   else { $extradirfilename = $dirnamesingle{$LocalActDir}; }
3163
   $indexfile = $var{'dirhtml'}.$dirnamerelpath{$LocalActDir}.$indexfilename.$var{'filenameextensionindex'}.$extradirfilename.$var{'exthtml'};
3164 382:baff1c482d98 Chris
3165 401:a0f6e994657f chris
   if ($LocalShortLong eq 'short' and $extradirfilename eq '' and $var{'frames'} ne 'yes') {
3166
       # With no frames and no subdir path, this must go in the
3167
       # top-level index file instead
3168 382:baff1c482d98 Chris
       $indexfile = $var{'dirhtml'}.$var{'filenametopframe'}.$var{'exthtml'};
3169
   }
3170
3171 381:2dc8163e9150 Chris
   if ($debug > 2) { print "   indexfilename (a-z small): $indexfile\n"; }
3172
3173
   open(IFILE,">$indexfile") || die("Cannot open index file $indexfile: $!\n");
3174
3175
   # Write the header of HTML file
3176
   print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3177
3178 410:675de8e6becf chris
   my $dirToPrint = $LocalActDir;
3179
   $dirToPrint =~ s,^./,,;
3180
3181 381:2dc8163e9150 Chris
   if ($var{'texttitleindex'} eq '') {
3182 410:675de8e6becf chris
      print IFILE "<title>Index of Matlab Files in Directory $dirToPrint</title>\n";
3183 381:2dc8163e9150 Chris
   } else {
3184
      if ($LocalGlobalLocal eq 'global') { print IFILE "<title>$var{'texttitleindex'}</title>\n"; }
3185 410:675de8e6becf chris
      else { print IFILE "<title>$var{'texttitleindex'} in Directory $dirToPrint</title>\n"; }
3186 381:2dc8163e9150 Chris
   }
3187 382:baff1c482d98 Chris
3188
   if ($var{'frames'} eq 'yes') {
3189
       print IFILE "<base target=\"$GlobalNameFrameMainRight\" />\n";
3190
   }
3191 381:2dc8163e9150 Chris
   print IFILE "</head>\n";
3192 382:baff1c482d98 Chris
3193 381:2dc8163e9150 Chris
   print IFILE "<body $var{'codebodyindex'}>\n";
3194 410:675de8e6becf chris
   print IFILE "<div id=\"matlabdoc\">\n";
3195 381:2dc8163e9150 Chris
   if ($var{'textheaderindex'} eq '') {
3196 410:675de8e6becf chris
      print IFILE "<h1 $var{'codeheader'}>Index of Matlab Files in Directory $dirToPrint</h1>\n";
3197 381:2dc8163e9150 Chris
   } else {
3198
      if ($LocalGlobalLocal eq 'global') { print IFILE "<h1 $var{'codeheader'}>$var{'textheaderindex'}</h1>\n"; }
3199 410:675de8e6becf chris
      else { print IFILE "<h1 $var{'codeheader'}>$var{'textheaderindex'} in Directory $dirToPrint</h1>\n"; }
3200 381:2dc8163e9150 Chris
   }
3201
3202
   # include links to indexes
3203
   &ConstructLinks2Index(IFILE, $dirnamerelpathtoindex{$LocalActDir}, $LocalActDir, $LocalGlobalLocal);
3204
3205
   # Collect the starting letters of m files in this directory or all m-files
3206
   for('a'..'z') { undef @{$_}; }
3207
   foreach $name (@localnames) {
3208
      if (! ($mfilename{$name} =~ /contents/i)) {
3209
         $firstletter = substr($mfilename{$name}, 0, 1);
3210
         # convert first letter always to lower case
3211
         # needed for reference to lower and upper case m-files
3212
         $firstletter = "\L$firstletter\E";
3213
         push(@{$firstletter}, $name);
3214
      }
3215
   }
3216
3217
   if ($LocalShortLong eq 'short') {
3218
      # begin create short index
3219
      print IFILE "<table width=\"100%\">\n";
3220
3221
      for('a'..'z') {
3222
         # print "   $_: @{$_}\n";
3223
         $numberofletter = $#{$_}+1;
3224 410:675de8e6becf chris
	 $cols = 3;
3225 381:2dc8163e9150 Chris
         if ($numberofletter > 0) {
3226 410:675de8e6becf chris
            print IFILE "\n<tr><td><br/><strong><a name=\"\U$_\E$_\"></a><span class=\"an\">\U$_\E</span></strong></td></tr>\n";
3227
            for ($count = 0; $count < $numberofletter; $count++) {
3228
		if (($count % $cols) == 0) {
3229
		    if ($count > 0) {
3230
			print IFILE "</tr><tr>\n";
3231
		    }
3232
		    print IFILE "<tr><td></td>";
3233
		}
3234
		$name = @{$_}[$count];
3235
		if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3236
		print IFILE "<td><a href=\"$dirpath$mfilename{$name}$var{'exthtml'}\">$mfilename{$name}</a></td>";
3237
	    }
3238
3239
	    print IFILE "</tr>\n";
3240
3241
            # $numberhalf = ($numberofletter + 1 - (($numberofletter+1) % 2))/2;
3242
            # if ($debug > 2) { print "   $_: @{$_} \t $numberhalf \t $numberofletter\n"; }
3243
            # for($count = 0; $count < $numberhalf; $count++) {
3244
            #    $name = @{$_}[$count];
3245
            #    if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3246
            #    print IFILE "<tr><td width=\"50%\"><a href=\"$dirpath$mfilename{$name}$var{'exthtml'}\">$mfilename{$name}</a></td>";
3247
            #    if (($count + $numberhalf) < $numberofletter) {
3248
            #       $name = @{$_}[$count + $numberhalf];
3249
            #       if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3250
            #       print IFILE "<td width=\"50%\"><a href=\"$dirpath$mfilename{$name}$var{'exthtml'}\">$mfilename{$name}</a></td></tr>\n";
3251
            #    } else {
3252
            #       print IFILE "<td width=\"50%\"></td></tr>\n";
3253
            #    }
3254
            # }
3255 381:2dc8163e9150 Chris
         }
3256
      }
3257
      print IFILE "</table>\n<br />$var{'codehr'}\n";
3258
3259
   } elsif ($LocalShortLong eq 'long') {
3260
      # begin create long index
3261 410:675de8e6becf chris
      print IFILE "<table width=\"100%\">\n";
3262 401:a0f6e994657f chris
      print IFILE "<tr><th>Name</th><th>Synopsis</th></tr>\n";
3263 381:2dc8163e9150 Chris
3264
      for('a'..'z') {
3265
         # print "   $_: @{$_}\n";
3266
         $numberofletter = $#{$_}+1;
3267
         if ($numberofletter > 0) {
3268
            $firstone = 1;
3269
            foreach $name (@{$_}) {
3270
               if ($debug > 1) { print "   AZinforeach1: $name \t\t $hfilerelpath{$name} \t\t $dirnamerelpath{$LocalActDir}\n"; }
3271
               if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3272
               if (! ($mfilename{$name} =~ /contents/i)) {
3273 400:4ad6499d7998 chris
                  if ($firstone == 1) { print IFILE "\n<tr><td colspan=\"2\"><br /><strong><a name=\"\U$_\E$_\"></a><span class=\"an\">\U$_\E</span></strong></td></tr>\n"; $firstone = 0; }
3274 381:2dc8163e9150 Chris
                  print IFILE "<tr><td valign=\"top\"><a href=\"$dirpath$mfilename{$name}$var{'exthtml'}\">$mfilename{$name}</a></td><td>$apropos{$name}</td></tr>\n";
3275
               }
3276
            }
3277
         }
3278
      }
3279
      print IFILE "</table>\n<br />$var{'codehr'}\n";
3280
   } else { die "wrong parameter for LocalShortLong in ConstructAZIndexFile: $LocalShortLong."; }
3281
3282
   # Include info about author from authorfile
3283
   &WriteFile2Handle($var{'authorfile'}, IFILE);
3284
3285
   print IFILE "<!--navigate-->\n";
3286
   print IFILE "<!--copyright-->\n";
3287 410:675de8e6becf chris
   print IFILE "</div>\n</body>\n</html>\n";
3288 381:2dc8163e9150 Chris
3289
   close(IFILE);
3290
3291
   if ($opt_silent) { print "\r"; }
3292
   print "   Indexfile small (A-Z) created: $indexfile\t";
3293
   if (!$opt_silent) { print "\n"; }
3294
3295
3296
   # Build the A-Z jump index file name
3297
   # handle the global index file case separately (no extra directory name in file)
3298
   if ($LocalGlobalLocal eq 'global') { $extradirfilename = ''; }
3299
   else { $extradirfilename = $dirnamesingle{$LocalActDir}; }
3300
3301 382:baff1c482d98 Chris
   if ($var{'frames'} eq 'yes') {
3302
3303
       $indexfile = $var{'dirhtml'}.$dirnamerelpath{$LocalActDir}.$indexfilename.$var{'filenameextensionjump'}.$extradirfilename.$var{'exthtml'};
3304
       if ($debug > 2) { print "   indexfilename (a-z jump): $indexfile\n"; }
3305
       open(IFILE,">$indexfile") || die("Cannot open jump index file $indexfile: $!\n");
3306
3307
       # Write the header of HTML file
3308
       print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3309
3310
       if ($var{'texttitleindex'} eq '') {
3311 410:675de8e6becf chris
	   print IFILE "<title>A-Z jump index in directory $dirToPrint</title>\n";
3312 382:baff1c482d98 Chris
       } else {
3313
	   if ($LocalGlobalLocal eq 'global') { print IFILE "<title>$var{'texttitleindex'}</title>\n"; }
3314 410:675de8e6becf chris
	   else { print IFILE "<title>$var{'texttitleindex'} in Directory $dirToPrint</title>\n"; }
3315 382:baff1c482d98 Chris
       }
3316
3317
       if ($var{'frames'} eq 'yes') {
3318
	   print IFILE "<base target=\"$GlobalNameFrameAZIndexsmall\" />\n";
3319
       }
3320
       print IFILE "</head>\n";
3321
       print IFILE "<body $var{'codebodyindex'}>\n";
3322 410:675de8e6becf chris
       print IFILE "<div id=\"matlabdoc\">\n";
3323 382:baff1c482d98 Chris
3324
       # Write the A-Z jump line, generate link for letters with files starting with this letter
3325
       # and only letters for no files starting with this letter
3326
       # use previously generated arrays with names of files sorted by starting letter
3327
       for('a'..'z') {
3328
	   $numberofletter = $#{$_}+1;
3329
	   if ($numberofletter > 0) {
3330
	       print IFILE "<strong><a href=\"$indexfilename$var{'filenameextensionindex'}$extradirfilename$var{'exthtml'}#\U$_\E$_\">\U$_\E</a> </strong>\n";
3331
	   } else {
3332
	       print IFILE "\U$_\E \n";
3333
	   }
3334
       }
3335
3336 410:675de8e6becf chris
       print IFILE "</div></body>\n</html>\n";
3337 382:baff1c482d98 Chris
3338
       close(IFILE);
3339
3340
       if ($opt_silent) { print "\r"; }
3341
       print "   Indexfile small (A-Z jump) created: $indexfile\t";
3342
       if (!$opt_silent) { print "\n"; }
3343 381:2dc8163e9150 Chris
   }
3344
3345
3346
   # Build the frame layout file, this file includes the layout of the frames
3347
   # Build the frame layout file name (for small/compact A-Z index)
3348
   # handle the global index file case separately (no extra directory name in file)
3349
   if ($LocalGlobalLocal eq 'global') { $extradirfilename = ''; }
3350
   else { $extradirfilename = $dirnamesingle{$LocalActDir}; }
3351
3352 382:baff1c482d98 Chris
   if ($var{'frames'} eq 'yes') {
3353 381:2dc8163e9150 Chris
3354 382:baff1c482d98 Chris
       $indexfile = $var{'dirhtml'}.$dirnamerelpath{$LocalActDir}.$indexfilename.$var{'filenameextensionframe'}.$extradirfilename.$var{'exthtml'};
3355
       if ($debug > 2) { print "   indexfilename (a-z frame): $indexfile\n"; }
3356 381:2dc8163e9150 Chris
3357 382:baff1c482d98 Chris
       open(IFILE,">$indexfile") || die("Cannot open jump index frame file $indexfile: $!\n");
3358
3359
       # Write the header of Frame file
3360
       print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3361
3362
       if ($var{'texttitleindex'} eq '') {
3363 410:675de8e6becf chris
	   print IFILE "<title>Index of Matlab Files in Directory $dirToPrint</title>\n";
3364 382:baff1c482d98 Chris
       } else {
3365
	   if ($LocalGlobalLocal eq 'global') { print IFILE "<title>$var{'texttitleindex'}</title>\n"; }
3366 410:675de8e6becf chris
	   else { print IFILE "<title>$var{'texttitleindex'} in Directory $dirToPrint</title>\n"; }
3367 382:baff1c482d98 Chris
       }
3368
       print IFILE "</head>\n";
3369
3370
       # definition of 2 frames, top the A-Z index, below the jump letter line
3371
       print IFILE "<frameset  rows=\"90%,10%\">\n";
3372
       print IFILE "   <frame src=\"$indexfilename$var{'filenameextensionindex'}$extradirfilename$var{'exthtml'}\" name=\"$GlobalNameFrameAZIndexsmall\" />\n";
3373
       print IFILE "   <frame src=\"$indexfilename$var{'filenameextensionjump'}$extradirfilename$var{'exthtml'}\" name=\"$GlobalNameFrameAZIndexjump\" />\n";
3374
       print IFILE "</frameset>\n";
3375
3376
       print IFILE "</html>\n";
3377
3378
       close(IFILE);
3379
3380
       if ($opt_silent) { print "\r"; }
3381
       print "   Frame layout file created: $indexfile\t";
3382
       if (!$opt_silent) { print "\n"; }
3383 381:2dc8163e9150 Chris
   }
3384
}
3385 382:baff1c482d98 Chris
3386 381:2dc8163e9150 Chris
3387
#========================================================================
3388
# Construct the links to all indexes
3389
#========================================================================
3390
sub ConstructLinks2Index
3391
{
3392
   local(*WRITEFILE, $LocalPath2Index, $PathContents, $LocalGlobalLocal) = @_;
3393
3394
   # include links to short/long - local/global index and C|contents.m
3395 389:0bc92382a86b chris
   print WRITEFILE "\n<p>";
3396
   print WRITEFILE "$var{'textjumpindexglobal'} ";
3397 382:baff1c482d98 Chris
3398
   if ($var{'frames'} eq 'yes') {
3399
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenameindexshortglobal'}$var{'filenameextensionframe'}$var{'exthtml'}\">short</a> | ";
3400 389:0bc92382a86b chris
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenameindexlongglobal'}$var{'filenameextensionframe'}$var{'exthtml'}\">long</a>\n";
3401 382:baff1c482d98 Chris
   } else {
3402 387:f89765996ef9 Chris
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenametopframe'}$var{'exthtml'}\">short</a> | ";
3403 389:0bc92382a86b chris
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenameindexlongglobal'}$var{'filenameextensionindex'}$var{'exthtml'}\">long</a>\n";
3404 382:baff1c482d98 Chris
   }
3405
3406 381:2dc8163e9150 Chris
   if ($LocalGlobalLocal eq 'local') {
3407
      if ($var{'usecontentsm'} eq 'yes') {
3408
         print WRITEFILE " | <a href=\"$contentsname{$PathContents}$dirnamesingle{$PathContents}$var{'exthtml'}\">Local contents</a>\n";
3409
      }
3410 389:0bc92382a86b chris
      if ($var{'frames'} eq 'yes') {
3411
         print WRITEFILE " | $var{'textjumpindexlocal'} ";
3412 382:baff1c482d98 Chris
         print WRITEFILE "<a href=\"$var{'filenameindexshortlocal'}$var{'filenameextensionframe'}$dirnamesingle{$PathContents}$var{'exthtml'}\">short</a> | ";
3413 389:0bc92382a86b chris
         print WRITEFILE "<a href=\"$var{'filenameindexlonglocal'}$var{'filenameextensionframe'}$dirnamesingle{$PathContents}$var{'exthtml'}\">long</a>\n";
3414
      } else {
3415
         print WRITEFILE " | $var{'textjumpindexlocal'} ";
3416
         print WRITEFILE "<a href=\"$var{'filenameindexshortlocal'}$var{'filenameextensionindex'}$dirnamesingle{$PathContents}$var{'exthtml'}\">short</a> | ";
3417
         print WRITEFILE "<a href=\"$var{'filenameindexlonglocal'}$var{'filenameextensionindex'}$dirnamesingle{$PathContents}$var{'exthtml'}\">long</a>\n";
3418
      }
3419 381:2dc8163e9150 Chris
   }
3420
   print WRITEFILE "</p>\n\n";
3421
   print WRITEFILE "$var{'codehr'}\n";
3422
}
3423
3424
3425
#========================================================================
3426
# Construct the contents.m files or update
3427
#========================================================================
3428
sub ConstructContentsmFile
3429
{
3430
   local($LocalActDir, @localnames) = @_;
3431
   local(*CFILE, $name,$newline);
3432
   local($contentsfile, $isincontentsonly);
3433
   local(@lines, @autoaddlines, @emptylines);
3434
   local($autoadd) = 'AutoAdd';
3435
   local($autoaddsection) = 0;
3436
   local($emptylineflag) = 0;
3437
   local(%nameincontents);
3438
3439
   # Build the contents file name
3440
   $contentsfile = $LocalActDir.$contentsname{$LocalActDir}.$suffix;
3441
3442
   if (-e $contentsfile) {
3443
      open(CFILE,"<$contentsfile") || die("Cannot open contents file $contentsfile: $!\n");
3444
      while (<CFILE>) {
3445
         # Search for the specified string pattern
3446
         @words = split;
3447
         if ((@words >= 3) && ($words[2] eq '-')) {
3448
            $isincontentsonly = 0;
3449
            foreach $name (@localnames) {
3450
               if ($name eq $words[1]) {    # old
3451
               # if ($mfilename{$name} eq $words[1]) {
3452
                  $isincontentsonly = 1;
3453
                  $nameincontents{$name} = 1;
3454
                  $newline = sprintf("%% %-13s - %s\n", $mfilename{$name}, $apropos{$name});
3455
                  push(@lines, $newline);
3456
               }
3457
            }
3458
            # issue a warning, if file is in contents, but not as file in the directory
3459
            if ($isincontentsonly == 0) {
3460
               print "\rConstructContents: Obsolete entry  $words[1]  in  $contentsfile ! Entry not used.\n";
3461
            }
3462
         } else {
3463
            # look for the AutoAdd section, should be the second word
3464
            if ((@words >= 2) && ($words[1] eq $autoadd)) { $autoaddsection = 1; }
3465
            # push the red line in an array
3466
            push(@lines, $_);
3467
         }
3468
      }
3469
      close(CFILE);
3470
   } else {
3471
      $newline = "% MATLAB Files in directory  $LocalActDir\n%\n";
3472
      push(@lines, $newline);
3473
3474
   }
3475
3476
   # collect the file names, that were not included in original C|contents.m
3477
   foreach $name (@localnames) {
3478
      if (! defined $nameincontents{$name}) {
3479
         if (! ($mfilename{$name} =~ /contents/i)) {
3480
            $newline = sprintf("%% %-13s - %s\n", $mfilename{$name}, $apropos{$name});
3481
            push(@autoaddlines, $newline);
3482
         }
3483
      }
3484
   }
3485
3486
   # write/update C|contents.m only if variable is set
3487
   if ($var{'writecontentsm'} eq 'yes') {
3488
      unlink($contentsfile);
3489
      open(CFILE,">$contentsfile") || die("Cannot open contents file $contentsfile: $!\n");
3490
      # write old C|contents.m or header of new file, as long as comment lines
3491
      foreach $line (@lines) {
3492
         if ($emptylineflag == 0) {
3493
            if ($line =~ /^\s*%/) { print CFILE $line; }
3494
            else { $emptylineflag = 1; push(@emptylines, $line); }
3495
         } else { push(@emptylines, $line); }
3496
      }
3497
      # add header of AutoAdd section
3498
      if (($autoaddsection == 0) && (@autoaddlines > 0)) { print CFILE "%\n% $autoadd\n"; }
3499
      # add autoadd section lines (previously undocumented files
3500
      foreach $line (@autoaddlines) { print CFILE $line; }
3501
      # add tail of original C|contents.m (everything behind first non-comment line)
3502
      foreach $line (@emptylines)   { print CFILE $line; }
3503
      print CFILE "\n";
3504
      close CFILE;
3505
      if ($opt_silent) { print "\r"; }
3506
      print "   Contents file created/updated: $contentsfile\t";
3507
      if (!$opt_silent) { print "\n"; }
3508
   }
3509
}
3510
3511
3512
#========================================================================
3513
# Replace found special characters with their HTMl Entities
3514
#========================================================================
3515
sub SubstituteHTMLEntities {
3516
   local($_) = @_;
3517
3518
   # Replace & <-> &amp;  < <-> &lt;  > <-> &gt;  " <-> &quot;
3519
   s/&/&amp;/g; s/\</&lt;/g; s/\>/&gt;/g; s/\"/&quot;/g;
3520
   return $_;
3521
}
3522
3523
#========================================================================
3524
# Replace found m-filenamestring with full link.
3525
#========================================================================
3526
sub SubstituteName2Link {
3527
   local($_, $funname) = @_;
3528
   local($refstr1, $refstr2, $reffound);
3529
3530
   # Look for something matching in the line
3531
   if ( /(\W+)($funname)(\W+)/i ) {
3532
      $reffound = $2;
3533 388:dad587ecb8d0 chris
      $refstr1 = "<a class=\"mfun\" href=\"$hfileindexpath{$name}$hfilerelpath{$funname}$mfilename{$funname}$var{'exthtml'}\">";
3534 381:2dc8163e9150 Chris
      $refstr2 = "<\/a>";
3535
      # Do links only for exact case match
3536
      if ( ($var{'links2filescase'}  eq 'exact') || ($var{'links2filescase'}  eq 'exactvery') ) {
3537
         if ( /(\W+)($funname)(\W+)/g ) {
3538
            s/(\W+)($funname)(\W+)/$1$refstr1$funname$refstr2$3/g;
3539
         }
3540
         else {
3541
            # Print info for not matching case in references, good for check up of files
3542
            if ( ($var{'links2filescase'}  eq 'exactvery') ) {
3543
               print "Diff in case found: $funname  (case of file name)   <->  $reffound  (case in source code)\n";
3544
               print "     (source line)  $_ \n";
3545
            }
3546
         }
3547
      }
3548
      # Do links for exact match and additionally for all upper case (often used in original matlab help text)
3549
      elsif ( ($var{'links2filescase'}  eq 'exactupper') ) {
3550
         s/(\W+)($funname)(\W+)/$1$refstr1$2$refstr2$3/g;
3551
         $funname2 = "\U$funname\E";
3552
         s/(\W+)($funname2)(\W+)/$1$refstr1$2$refstr2$3/g;
3553
      }
3554
      # Do links for all case mixes, this calls for trouble under LINUX/UNIX
3555
      else {  #elsif ( ($var{'links2filescase'}  eq 'all') )
3556
         s/(\W+)($funname)(\W+)/$1$refstr1$2$refstr2$3/ig;
3557
      }
3558
   }
3559
3560
   return $_;
3561
}
3562
3563
#========================================================================
3564
# Construct the html files for each matlab file.
3565
#    Need to reread each matlab file to find the help text.
3566
#    Note that we can't do this in a single loop because sometimes
3567
#    the help text maybe before the function declaration.
3568
#========================================================================
3569
sub ConstructHTMLFiles
3570
{
3571
   local(*MFILE);
3572
   local(*HFILE);
3573
3574
   local($filescreated) = 0;
3575
   local($functionline);
3576
3577
   foreach $name (@names) {
3578
      # Create cross reference information already here, used for keywords as well
3579
      # Construct list of referenced functions
3580
      @xref = @{'depcalls'.$name};    # the functions, that this m-file calls
3581
      @yref = @{'depcalled'.$name};   # the functions, that this m-file is called from
3582
      # print "   depcalls: @{'depcalls'.$name}\n   depcalled: @{'depcalled'.$name}\n";
3583
      # foreach $cname (@names) { next if $cname eq $name; push(@yref,$cname) if grep(/$name/,@{'depcalls'.$cname}); }
3584
3585
3586
      # Open m-file and html-file
3587
      open(MFILE,"<$mfile{$name}");
3588
      open(HFILE,">$hfile{$name}");
3589
3590
      # Write the header of HTML file
3591
      print HFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3592
3593
      # Write meta tags: use apropos (one line function description) for description
3594
      # and cross reference function names for keywords (any better ideas?)
3595
      print HFILE "<meta name=\"description\" content=\" $apropos{$name} \" />\n";
3596
      print HFILE "<meta name=\"keywords\" content=\" @xref @yref \" />\n";
3597
3598
      # Write Title and start body of html-file
3599
      print HFILE "<title>$var{'texttitlefiles'} $mfilename{$name}</title>\n</head>\n";
3600
      print HFILE "<body $var{'codebodyfiles'}>\n";
3601 410:675de8e6becf chris
      print HFILE "<div id=\"matlabdoc\">\n";
3602 381:2dc8163e9150 Chris
      print HFILE "<h1 $var{'codeheader'}>$var{'textheaderfiles'} $mfilename{$name}</h1>\n";
3603 401:a0f6e994657f chris
3604
# http://test.soundsoftware.ac.uk/cannam/projects/smallbox/repository/annotate/DL/RLS-DLA/SolveFISTA.m
3605 410:675de8e6becf chris
#      print HFILE "<a href=\"" . $hfileindexpath{$name} . "../../projects/smallbox/repository/annotate/" . $mfiledir{$name}  . $mfilename{$name} . ".m\">View in repository</a>\n";
3606 401:a0f6e994657f chris
3607 381:2dc8163e9150 Chris
      print HFILE "$var{'codehr'}\n";
3608
3609
      # include links to short/long - local/global index and C|contents.m
3610
      &ConstructLinks2Index(HFILE, $hfileindexpath{$name}, $mfiledir{$name}, 'local');
3611
3612
      # If this is a function, then write out the first line as a synopsis
3613
      if ($mtype{$name} eq "function") {
3614
         print HFILE "<h2 $var{'codeheader'}>Function Synopsis</h2>\n";
3615
         print HFILE "<pre>$synopsis{$name}</pre>\n$var{'codehr'}\n";
3616
      }
3617
3618
      # Look for the matlab help text block
3619
      $functionline = "\n";
3620
      do {
3621
         $_ = <MFILE>;
3622
         # remember functionline, if before help text block
3623
         if (/^\s*function/) { $functionline = $_; }
3624
      } until (/^\s*%/ || eof);
3625
      if (! (eof(MFILE))) {
3626
         print HFILE "<h2 $var{'codeheader'}>Help text</h2>\n";
3627
         print HFILE "<pre>\n";
3628
         while (/^\s*%/) {
3629
            # First remove leading % and white space, then Substitute special characlers
3630
            s/^\s*%//;
3631
            $_ = &SubstituteHTMLEntities($_);
3632
3633
            # check/create cross references
3634
            foreach $funname (@{'all'.$name}) {
3635
               if ($funname =~ /simulink/) { print "\n Simulink - Filename: $name;  scanname: $funname\n"; }
3636
               next if $funname eq $name;
3637
               $_ = &SubstituteName2Link($_, $funname);
3638
            }
3639
            print HFILE $_;
3640
            if (! eof) { $_ = <MFILE>; }
3641
         }
3642
         print HFILE "</pre>\n$var{'codehr'}\n";
3643
      }
3644
3645
      # Write the cross reference information
3646
      if (@xref || @yref) {
3647
         print HFILE "<h2 $var{'codeheader'}>Cross-Reference Information</H2>\n";
3648
         print HFILE "<table border=\"0\" width=\"100%\">\n<tr align=\"left\">\n<th width=\"50%\">";
3649
         if (@xref) {
3650
            print HFILE "This $mtype{$name} calls";
3651
         }
3652
         print HFILE "</th>\n<th width=\"50%\">";
3653
         if (@yref) {
3654
            print HFILE "This $mtype{$name} is called by";
3655
         }
3656
         print HFILE "</th>\n</tr>\n<tr valign=\"top\"><td>";
3657
         if (@xref) {
3658
            print HFILE "\n<ul>\n";
3659
            foreach $cname (sort @xref) {
3660
               print HFILE "<li><a class=\"mfun\" href=\"$hfileindexpath{$name}$hfilerelpath{$cname}$mfilename{$cname}$var{'exthtml'}\">$mfilename{$cname}</a></li>\n";
3661
            }
3662
            print HFILE "</ul>\n";
3663
         }
3664
         print HFILE "</td><td>";
3665
         if (@yref) {
3666
            print HFILE "\n<ul>\n";
3667
            foreach $cname (sort @yref) {
3668
               print HFILE "<li><a class=\"mfun\" href=\"$hfileindexpath{$name}$hfilerelpath{$cname}$mfilename{$cname}$var{'exthtml'}\">$mfilename{$cname}</a></li>\n";
3669
            }
3670
            print HFILE "</ul>\n";
3671
         }
3672
         print HFILE "</td>\n</tr>\n</table>\n";
3673
         print HFILE "$var{'codehr'}\n";
3674
      }
3675
3676
      # Include source text if requested
3677
      if (($var{'includesource'} eq 'yes') && (! ($mfilename{$name} =~ /^contents$/i))) {
3678
         print HFILE "<h2 $var{'codeheader'}>Listing of $mtype{$name} $mfilename{$name}</h2>\n";
3679
         seek(MFILE,0,0);
3680
         print HFILE "<pre>\n";
3681
         $IsStillHelp = 2;
3682
         print HFILE $functionline;    # functionline from scanning of help
3683
         while (<MFILE>) {
3684
            if ($IsStillHelp == 2) {
3685
               next     if (/^\s*$/);
3686
               next     if (/^\s*function/);
3687
               if (/^\s*%/) { $IsStillHelp = 1; next; }
3688
            } elsif ($IsStillHelp == 1) {
3689
               next     if (/^\s*%/);
3690
               $IsStillHelp = 0;
3691
            }
3692
3693
            # Substritute special characters
3694
            $_ = &SubstituteHTMLEntities($_);
3695
3696
            # check for comment in line and format with css em
3697 400:4ad6499d7998 chris
            s/^(.*)%(.*?)([\s\r\n]+)$/$1<em class=\"mcom\">%$2<\/em>$3/;
3698 381:2dc8163e9150 Chris
3699
            # check/create cross references
3700
            foreach $funname (@{'all'.$name}) {
3701
               next if $funname eq $name;
3702
               $_ = &SubstituteName2Link($_, $funname);
3703
            }
3704
            print HFILE $_;
3705
         }
3706
         print HFILE "</pre>\n$var{'codehr'}\n";
3707
      }
3708
3709
      # Include info about author from authorfile
3710
      &WriteFile2Handle($var{'authorfile'}, HFILE)   ;
3711
3712
      print HFILE "<!--navigate-->\n";
3713
      print HFILE "<!--copyright-->\n";
3714 410:675de8e6becf chris
      print HFILE "</div>\n</body>\n</html>\n";
3715 381:2dc8163e9150 Chris
      close(MFILE);
3716
      close(HFILE);
3717
3718
      # Print name of finished file
3719
      if ($opt_silent) { print "\r"; }
3720
      print "   HTML-File created: $hfile{$name}\t";
3721
      if (!$opt_silent) { print "\n"; }
3722
      $filescreated++;
3723
   }
3724
3725
   print "\n$PROGRAM: $indexcreated index and $filescreated files created.\n";
3726
}
3727
3728
#========================================================================
3729
# Function:	CheckFileName
3730
# Purpose:	.
3731
#========================================================================
3732
sub CheckFileName {
3733
   local($filename, $description) = @_;
3734
   local(*CHECKFILE);
3735
3736
   open(CHECKFILE,"<$filename") || do {
3737
      if ($description eq '') {$description = 'file';}
3738
      # if (!$opt_silent) { print "Cannot open $description $filename: $!\n"; }
3739
      print "Cannot open $description $filename: $!\n";
3740
      return 1;
3741
   };
3742
   close(CHECKFILE);
3743
   return 0;
3744
3745
}
3746
3747
#========================================================================
3748
# Function:	CheckDirName
3749
# Purpose:	.
3750
#========================================================================
3751
sub CheckDirName {
3752
   local($dirname, $description) = @_;
3753
   local(*CHECKDIR);
3754
3755
   opendir(CHECKDIR,"$dirname") || die ("Cannot open $description directory $dirname: $!\n");
3756
   closedir(CHECKDIR);
3757
}
3758
3759
#========================================================================
3760
# Function:	WriteFile2Handle
3761
# Purpose:	.
3762
#========================================================================
3763
sub WriteFile2Handle {
3764
   local($filename, *WRITEFILE) = @_;
3765
   local(*READFILE);
3766
3767
   if ($filename ne '') {
3768
      open(READFILE,"<$filename");
3769
      @filecontents = <READFILE>;
3770
      close(READFILE);
3771
      print WRITEFILE "@filecontents\n";
3772
      # if (!$opt_silent) {print "      Contents of $filename added\n"};
3773
   }
3774
}
3775
3776
3777
#========================================================================
3778
# Function:	GetConfigFile
3779
# Purpose:	Read user's configuration file, if such exists.
3780
#========================================================================
3781
sub GetConfigFile
3782
{
3783
   local($filename) = @_;
3784
   local(*CONFIG);
3785
   local($value);
3786
3787
   if (&CheckFileName($filename, 'configuration file')) {
3788
      # if (!$opt_silent) { print "   Proceeding using built-in defaults for configuration.\n"; }
3789
      print "   Proceeding using built-in defaults for configuration.\n";
3790
      return 0;
3791
   };
3792
3793
   open(CONFIG,"< $filename");
3794
   while (<CONFIG>) {
3795
      s/#.*$//;
3796
      next if /^\s*$/o;
3797
3798
      # match keyword: process one or more arguments
3799
      # keyword set
3800
      if (/^\s*set\s+(\S+)\s*=\s*(.*)/) {
3801
         # setting a configuration variable
3802
         if (defined $var{$1}) {
3803
            $var{$1} = $2;
3804
            if ($debug > 3) { print "$1:   $var{$1}\n"; }
3805
         }
3806
         else {
3807
            print "$PROGRAM: unknown variable `$1' in configuration file\n"
3808
         }
3809
      } else {
3810
         chop($_);
3811
         print "$PROGRAM: unknown keyword in configuration file in line: `$_'\n"
3812
      }
3813
   }
3814
   close CONFIG;
3815
   1;
3816
}
3817
3818
3819
#------------------------------------------------------------------------
3820
# DisplayHelp - display help text using -h or -help command-line switch
3821
#------------------------------------------------------------------------
3822
sub DisplayHelp
3823
{
3824
   $help=<<EofHelp;
3825
   $PROGRAM v$VERSION - generate html documentation from Matlab m-files
3826
3827
   Usage: $PROGRAM [-h] [-c config_file] [-m|dirmfiles matlab_dir] [-d|dirhtml html_dir]
3828
                   [-i yes|no] [-r yes|no] [-p yes|no] [-quiet|q] [-a authorfile]
3829
3830
   $PROGRAM is a perl script that reads each matlab .m file in a directory
3831
   to produce a corresponding .html file of help documentation and cross
3832
   reference information. An index file is written with links to all of
3833
   the html files produced. The options are:
3834
3835
      -quiet         or -q : be silent, no status information during generation
3836
      -help          or -h : display this help message
3837
      -todo          or -t : print the todo list for $PROGRAM
3838
      -version       or -v : display version
3839
3840
      -configfile    or -c : name of configuration file (default to $var{'configfile'}).
3841
      -dirmfiles     or -m : top level directory containing matlab files to generate html for;
3842
                             default to actual directory.
3843
      -dirhtml       or -d : top level directory for generated html files;
3844
                             default to actual directory.
3845
3846
      -includesource or -i : Include matlab source in the html documentation [yes|no]
3847
                             default to yes.
3848
      -processtree   or -r : create docu for m-file directory and all subdirectories [yes|no];
3849
                             default to yes.
3850
      -producetree   or -p : create multi-level docu identical to directory structure
3851
                             of m-files [yes|no]; default to yes.
3852
      -writecontentsm or -w: update or write contents.m files into the matlab source
3853
                             directories [yes|no]; default to no.
3854
3855
      -authorfile    or -a : name of file including author information, last element in html;
3856
                             default to empty.
3857
3858
   The command line setting overwrite all other settings (built-in and configuration file).
3859
   The configuration file settings overwrite the built-in settings (and not the command
3860
   line settings).
3861
3862
   Typical usages are:
3863
     $PROGRAM
3864
        (use default parameters from perl script, if configuration
3865
         file is found -> generation of docu, else display of help)
3866
3867
     $PROGRAM -dirmfiles matlab -dirhtml html
3868
        (generate html documentation for all m-files in directory matlab,
3869
         place html files in directory html, use built-in defaults for
3870
         all other parameters, this way all m-files in the directory
3871
         matlab and below are converted and the generated html-files are
3872
         placed in the directory html and below producing the same
3873
         directory structure than below matlab)
3874
3875
     $PROGRAM -quiet
3876
        (use built-in parameters from perl script, if configuration
3877
         file is found use these settings as well, do generation,
3878
         no display except critical errors, status of conversion and result)
3879
3880
     $PROGRAM -m toolbox -dirhtml doc/html -r yes -p no
3881
        (convert all m-files in directory toolbox and below and place
3882
         the generated html files in directory doc/html, read all m-files
3883
         recursively, however, the generated html files are placed in one
3884
         directory)
3885
3886
     $PROGRAM -m toolbox -dirhtml doc/html -i no -r no
3887
        (convert all m-files in directory toolbox and place
3888
         the generated html files in directory doc/html, do not read m-files
3889
         recursively, do not include source code in documentation)
3890
3891
EofHelp
3892
3893
   die "$help";
3894
}
3895
3896
#------------------------------------------------------------------------
3897
# DisplayTodo - display ToDo list using -t or -todo command-line switch
3898
#------------------------------------------------------------------------
3899
sub DisplayTodo
3900
{
3901
   $todo=<<EofToDo;
3902
      $PROGRAM v$VERSION - ToDo list
3903
3904
       o	use more than one high level directory
3905
3906
       o	what should/could be done here???
3907
3908
EofToDo
3909
3910
   die "$todo";
3911
}
3912
3913
3914
#------------------------------------------------------------------------
3915
# ListVariables - list all defined variables and their values
3916
#------------------------------------------------------------------------
3917
sub ListVariables
3918
{
3919
   local($value);
3920
3921
   if ($debug > 0) {
3922
      print "List of all variables and their values\n";
3923
      foreach (sort keys %var)
3924
      {
3925
         if ($var{$_} eq '') {
3926
            $value = "empty";
3927
         } else {
3928
            $value = $var{$_};
3929
         }
3930
         print "   $_\n      $value\n";
3931
      }
3932
      print "\n\n";
3933
   }
3934
}
3935
3936
3937
__END__
3938
:endofperl
3939 0:513646585e45 Chris
#!/usr/bin/env ruby
3940
3941
# == Synopsis
3942
#
3943
# reposman: manages your repositories with Redmine
3944
#
3945
# == Usage
3946
#
3947
#    reposman [OPTIONS...] -s [DIR] -r [HOST]
3948 441:cbce1fd3b1b7 Chris
#
3949 0:513646585e45 Chris
#  Examples:
3950 241:7658d21a1493 chris
#    reposman --scm-dir=/var/svn --redmine-host=redmine.example.net --scm subversion
3951 0:513646585e45 Chris
#    reposman -s /var/git -r redmine.example.net -u http://svn.example.net --scm git
3952
#
3953
# == Arguments (mandatory)
3954
#
3955 241:7658d21a1493 chris
#   -s, --scm-dir=DIR         use DIR as base directory for repositories
3956 0:513646585e45 Chris
#   -r, --redmine-host=HOST   assume Redmine is hosted on HOST. Examples:
3957
#                             -r redmine.example.net
3958
#                             -r http://redmine.example.net
3959
#                             -r https://example.net/redmine
3960 909:cbb26bc654de Chris
#   -k, --key=KEY             use KEY as the Redmine API key (you can use the
3961
#                             --key-file option as an alternative)
3962 0:513646585e45 Chris
#
3963
# == Options
3964
#
3965
#   -o, --owner=OWNER         owner of the repository. using the rails login
3966
#                             allow user to browse the repository within
3967
#                             Redmine even for private project. If you want to
3968
#                             share repositories through Redmine.pm, you need
3969
#                             to use the apache owner.
3970
#   -g, --group=GROUP         group of the repository. (default: root)
3971
#   --scm=SCM                 the kind of SCM repository you want to create (and
3972
#                             register) in Redmine (default: Subversion).
3973
#                             reposman is able to create Git and Subversion
3974
#                             repositories. For all other kind, you must specify
3975
#                             a --command option
3976
#   -u, --url=URL             the base url Redmine will use to access your
3977
#                             repositories. This option is used to automatically
3978
#                             register the repositories in Redmine. The project
3979
#                             identifier will be appended to this url. Examples:
3980
#                             -u https://example.net/svn
3981
#                             -u file:///var/svn/
3982 28:12420e46bed9 chris
#                             if this option isn't set, reposman will register
3983
#                             the repositories with local file paths in Redmine
3984 0:513646585e45 Chris
#   -c, --command=COMMAND     use this command instead of "svnadmin create" to
3985
#                             create a repository. This option can be used to
3986
#                             create repositories other than subversion and git
3987
#                             kind.
3988
#                             This command override the default creation for git
3989
#                             and subversion.
3990 13:80433603a2cd Chris
#   --http-user=USER          User for HTTP Basic authentication with Redmine WS
3991
#   --http-pass=PASSWORD      Password for Basic authentication with Redmine WS
3992 909:cbb26bc654de Chris
#       --key-file=PATH       path to a file that contains the Redmine API key
3993
#                             (use this option instead of --key if you don't
3994
#                             the key to appear in the command line)
3995 0:513646585e45 Chris
#   -t, --test                only show what should be done
3996
#   -h, --help                show help and exit
3997
#   -v, --verbose             verbose
3998
#   -V, --version             print version and exit
3999
#   -q, --quiet               no log
4000
#
4001
# == References
4002 441:cbce1fd3b1b7 Chris
#
4003 0:513646585e45 Chris
# You can find more information on the redmine's wiki : http://www.redmine.org/wiki/redmine/HowTos
4004
4005
4006
require 'getoptlong'
4007 1332:1d1cb01c0417 Chris
#require 'rdoc/usage'
4008 0:513646585e45 Chris
require 'find'
4009
require 'etc'
4010
4011
Version = "1.3"
4012
SUPPORTED_SCM = %w( Subversion Darcs Mercurial Bazaar Git Filesystem )
4013
4014
opts = GetoptLong.new(
4015 241:7658d21a1493 chris
                      ['--scm-dir',      '-s', GetoptLong::REQUIRED_ARGUMENT],
4016 0:513646585e45 Chris
                      ['--redmine-host', '-r', GetoptLong::REQUIRED_ARGUMENT],
4017
                      ['--key',          '-k', GetoptLong::REQUIRED_ARGUMENT],
4018 909:cbb26bc654de Chris
                      ['--key-file',           GetoptLong::REQUIRED_ARGUMENT],
4019 0:513646585e45 Chris
                      ['--owner',        '-o', GetoptLong::REQUIRED_ARGUMENT],
4020
                      ['--group',        '-g', GetoptLong::REQUIRED_ARGUMENT],
4021
                      ['--url',          '-u', GetoptLong::REQUIRED_ARGUMENT],
4022
                      ['--command' ,     '-c', GetoptLong::REQUIRED_ARGUMENT],
4023
                      ['--scm',                GetoptLong::REQUIRED_ARGUMENT],
4024 13:80433603a2cd Chris
                      ['--http-user',          GetoptLong::REQUIRED_ARGUMENT],
4025
                      ['--http-pass',          GetoptLong::REQUIRED_ARGUMENT],
4026 0:513646585e45 Chris
                      ['--test',         '-t', GetoptLong::NO_ARGUMENT],
4027
                      ['--verbose',      '-v', GetoptLong::NO_ARGUMENT],
4028
                      ['--version',      '-V', GetoptLong::NO_ARGUMENT],
4029
                      ['--help'   ,      '-h', GetoptLong::NO_ARGUMENT],
4030
                      ['--quiet'  ,      '-q', GetoptLong::NO_ARGUMENT]
4031
                      )
4032
4033
$verbose      = 0
4034
$quiet        = false
4035
$redmine_host = ''
4036
$repos_base   = ''
4037 13:80433603a2cd Chris
$http_user    = ''
4038
$http_pass    = ''
4039 0:513646585e45 Chris
$svn_owner    = 'root'
4040
$svn_group    = 'root'
4041
$use_groupid  = true
4042
$svn_url      = false
4043
$test         = false
4044
$scm          = 'Subversion'
4045
4046
def log(text, options={})
4047
  level = options[:level] || 0
4048
  puts text unless $quiet or level > $verbose
4049
  exit 1 if options[:exit]
4050
end
4051
4052
def system_or_raise(command)
4053
  raise "\"#{command}\" failed" unless system command
4054
end
4055
4056 1332:1d1cb01c0417 Chris
def usage
4057
  puts "See source code for supported options"
4058
  exit
4059
end
4060
4061 0:513646585e45 Chris
module SCM
4062
4063
  module Subversion
4064
    def self.create(path)
4065
      system_or_raise "svnadmin create #{path}"
4066
    end
4067
  end
4068
4069
  module Git
4070
    def self.create(path)
4071
      Dir.mkdir path
4072
      Dir.chdir(path) do
4073
        system_or_raise "git --bare init --shared"
4074
        system_or_raise "git update-server-info"
4075
      end
4076
    end
4077
  end
4078
4079
end
4080
4081
begin
4082
  opts.each do |opt, arg|
4083
    case opt
4084 241:7658d21a1493 chris
    when '--scm-dir';        $repos_base   = arg.dup
4085 0:513646585e45 Chris
    when '--redmine-host';   $redmine_host = arg.dup
4086
    when '--key';            $api_key      = arg.dup
4087 909:cbb26bc654de Chris
    when '--key-file'
4088
      begin
4089
        $api_key = File.read(arg).strip
4090
      rescue Exception => e
4091
        $stderr.puts "Unable to read the key from #{arg}: #{e.message}"
4092
        exit 1
4093
      end
4094 0:513646585e45 Chris
    when '--owner';          $svn_owner    = arg.dup; $use_groupid = false;
4095
    when '--group';          $svn_group    = arg.dup; $use_groupid = false;
4096
    when '--url';            $svn_url      = arg.dup
4097
    when '--scm';            $scm          = arg.dup.capitalize; log("Invalid SCM: #{$scm}", :exit => true) unless SUPPORTED_SCM.include?($scm)
4098 13:80433603a2cd Chris
    when '--http-user';      $http_user    = arg.dup
4099
    when '--http-pass';      $http_pass    = arg.dup
4100 0:513646585e45 Chris
    when '--command';        $command =      arg.dup
4101
    when '--verbose';        $verbose += 1
4102
    when '--test';           $test = true
4103
    when '--version';        puts Version; exit
4104 1332:1d1cb01c0417 Chris
    when '--help';           usage
4105 0:513646585e45 Chris
    when '--quiet';          $quiet = true
4106
    end
4107
  end
4108
rescue
4109
  exit 1
4110
end
4111
4112
if $test
4113
  log("running in test mode")
4114
end
4115
4116
# Make sure command is overridden if SCM vendor is not handled internally (for the moment Subversion and Git)
4117
if $command.nil?
4118
  begin
4119
    scm_module = SCM.const_get($scm)
4120
  rescue
4121
    log("Please use --command option to specify how to create a #{$scm} repository.", :exit => true)
4122
  end
4123
end
4124
4125
$svn_url += "/" if $svn_url and not $svn_url.match(/\/$/)
4126
4127
if ($redmine_host.empty? or $repos_base.empty?)
4128 1332:1d1cb01c0417 Chris
  usage
4129 0:513646585e45 Chris
end
4130
4131
unless File.directory?($repos_base)
4132 217:ed8222a04634 chris
  log("directory '#{$repos_base}' doesn't exist", :exit => true)
4133 0:513646585e45 Chris
end
4134
4135
begin
4136
  require 'active_resource'
4137
rescue LoadError
4138
  log("This script requires activeresource.\nRun 'gem install activeresource' to install it.", :exit => true)
4139
end
4140
4141 37:94944d00e43c chris
class Project < ActiveResource::Base
4142 217:ed8222a04634 chris
  self.headers["User-agent"] = "SoundSoftware repository manager/#{Version}"
4143 909:cbb26bc654de Chris
  self.format = :xml
4144 37:94944d00e43c chris
end
4145 0:513646585e45 Chris
4146
log("querying Redmine for projects...", :level => 1);
4147
4148
$redmine_host.gsub!(/^/, "http://") unless $redmine_host.match("^https?://")
4149
$redmine_host.gsub!(/\/$/, '')
4150
4151
Project.site = "#{$redmine_host}/sys";
4152 13:80433603a2cd Chris
Project.user = $http_user;
4153
Project.password = $http_pass;
4154 0:513646585e45 Chris
4155
begin
4156
  # Get all active projects that have the Repository module enabled
4157
  projects = Project.find(:all, :params => {:key => $api_key})
4158 909:cbb26bc654de Chris
rescue ActiveResource::ForbiddenAccess
4159
  log("Request was denied by your Redmine server. Make sure that 'WS for repository management' is enabled in application settings and that you provided the correct API key.")
4160 0:513646585e45 Chris
rescue => e
4161
  log("Unable to connect to #{Project.site}: #{e}", :exit => true)
4162
end
4163
4164
if projects.nil?
4165 909:cbb26bc654de Chris
  log('No project found, perhaps you forgot to "Enable WS for repository management"', :exit => true)
4166 0:513646585e45 Chris
end
4167
4168 1107:4f45ab104990 Chris
log("found #{projects.size} projects at " + Time.now.inspect);
4169 0:513646585e45 Chris
4170
def set_owner_and_rights(project, repos_path, &block)
4171 441:cbce1fd3b1b7 Chris
  if mswin?
4172 0:513646585e45 Chris
    yield if block_given?
4173
  else
4174
    uid, gid = Etc.getpwnam($svn_owner).uid, ($use_groupid ? Etc.getgrnam(project.identifier).gid : Etc.getgrnam($svn_group).gid)
4175 34:09b1d4349da3 Chris
    right = project.is_public ? 02775 : 02770
4176 0:513646585e45 Chris
    yield if block_given?
4177
    Find.find(repos_path) do |f|
4178
      File.chmod right, f
4179
      File.chown uid, gid, f
4180
    end
4181
  end
4182
end
4183
4184
def other_read_right?(file)
4185
  (File.stat(file).mode & 0007).zero? ? false : true
4186
end
4187
4188
def owner_name(file)
4189
  mswin? ?
4190
    $svn_owner :
4191 441:cbce1fd3b1b7 Chris
    Etc.getpwuid( File.stat(file).uid ).name
4192 0:513646585e45 Chris
end
4193 441:cbce1fd3b1b7 Chris
4194 0:513646585e45 Chris
def mswin?
4195
  (RUBY_PLATFORM =~ /(:?mswin|mingw)/) || (RUBY_PLATFORM == 'java' && (ENV['OS'] || ENV['os']) =~ /windows/i)
4196
end
4197
4198
projects.each do |project|
4199 1107:4f45ab104990 Chris
  log("inspecting project #{project.name}", :level => 1)
4200 0:513646585e45 Chris
4201
  if project.identifier.empty?
4202 1107:4f45ab104990 Chris
    log("\tno identifier for project #{project.name}!")
4203 0:513646585e45 Chris
    next
4204 1445:0c7b3bb73517 Chris
  elsif not project.identifier.match(/^[a-z0-9_\-]+$/)
4205 1107:4f45ab104990 Chris
    log("\tinvalid identifier for project #{project.name} : #{project.identifier}!");
4206 0:513646585e45 Chris
    next;
4207
  end
4208
4209
  repos_path = File.join($repos_base, project.identifier).gsub(File::SEPARATOR, File::ALT_SEPARATOR || File::SEPARATOR)
4210
4211 28:12420e46bed9 chris
  create_repos = false
4212
  # Logic required for SoundSoftware.ac.uk repositories:
4213
  #
4214
  # * If the project has a repository path declared already,
4215
  #   - if it's a local path,
4216
  #     - if it does not exist
4217
  #       - if it has the right root
4218
  #         - create it
4219
  #   - else
4220
  #     - leave alone (remote repository)
4221
  # * else
4222
  #   - create repository with same name as project
4223
  #   - set to project
4224
4225
  if project.respond_to?(:repository)
4226
4227
    repos_url = project.repository.url;
4228 1107:4f45ab104990 Chris
    log("\texisting url for project #{project.identifier} is #{repos_url}", :level => 2);
4229 28:12420e46bed9 chris
4230
    if repos_url.match(/^file:\//) || repos_url.match(/^\//)
4231
4232
      repos_url = repos_url.gsub(/^file:\/*/, "/");
4233 1107:4f45ab104990 Chris
      log("\tthis is a local file path, at #{repos_url}", :level => 2);
4234 28:12420e46bed9 chris
4235
      if repos_url.slice(0, $repos_base.length) != $repos_base
4236
        # leave repos_path set to our original suggestion
4237 1107:4f45ab104990 Chris
        log("\tpreparing to replace incorrect repo location #{repos_url} for #{project.name} with #{repos_path}");
4238 28:12420e46bed9 chris
        create_repos = true
4239
      else
4240
        if !File.directory?(repos_url)
4241 1107:4f45ab104990 Chris
          log("\tpreparing to create repo for #{project.name} at #{repos_url}");
4242 28:12420e46bed9 chris
          repos_path = repos_url
4243
          create_repos = true
4244
        else
4245 1107:4f45ab104990 Chris
          log("\tit exists and is in the right place", :level => 2);
4246 28:12420e46bed9 chris
        end
4247
      end
4248
    else
4249 1107:4f45ab104990 Chris
      log("\tthis is a remote path, leaving alone", :level => 2);
4250 28:12420e46bed9 chris
    end
4251
  else
4252 1107:4f45ab104990 Chris
    log("\tpreparing to set repo location and create for #{project.name} at #{repos_url}")
4253 28:12420e46bed9 chris
#    if File.directory?(repos_path)
4254
#      log("\trepository path #{repos_path} already exists, not creating")
4255
#    else
4256
      create_repos = true
4257
#    end
4258
  end
4259
4260
  if create_repos
4261
4262
    registration_url = repos_path
4263
    if $svn_url
4264
      registration_url = "#{$svn_url}#{project.identifier}"
4265
    end
4266 0:513646585e45 Chris
4267
    if $test
4268 28:12420e46bed9 chris
      log("\tproposal: create repository #{repos_path}")
4269
      log("\tproposal: register repository #{repos_path} in Redmine with vendor #{$scm}, url #{registration_url}")
4270 0:513646585e45 Chris
      next
4271
    end
4272
4273 52:8c3409528d3a Chris
# No -- we need "other" users to be able to read it.  Access control
4274
# is not handled through Unix user id anyway
4275
#    project.is_public ? File.umask(0002) : File.umask(0007)
4276
    File.umask(0002)
4277
4278 28:12420e46bed9 chris
    log("\taction: create repository #{repos_path}")
4279 0:513646585e45 Chris
4280
    begin
4281 28:12420e46bed9 chris
      if !File.directory?(repos_path)
4282
        set_owner_and_rights(project, repos_path) do
4283
          if scm_module.nil?
4284
            log("\trunning command: #{$command} #{repos_path}")
4285
            system_or_raise "#{$command} #{repos_path}"
4286
          else
4287
            scm_module.create(repos_path)
4288
          end
4289 0:513646585e45 Chris
        end
4290
      end
4291
    rescue => e
4292
      log("\tunable to create #{repos_path} : #{e}\n")
4293
      next
4294
    end
4295
4296 28:12420e46bed9 chris
    begin
4297
      log("\taction: register repository #{repos_path} in Redmine with vendor #{$scm}, url #{registration_url}");
4298
      project.post(:repository, :vendor => $scm, :repository => {:url => "#{registration_url}"}, :key => $api_key)
4299
    rescue => e
4300
      log("\trepository #{repos_path} not registered in Redmine: #{e.message}");
4301 0:513646585e45 Chris
    end
4302
    log("\trepository #{repos_path} created");
4303
  end
4304 37:94944d00e43c chris
end
4305 0:513646585e45 Chris
4306 1107:4f45ab104990 Chris
log("project review completed at " + Time.now.inspect);
4307
4308 241:7658d21a1493 chris
#!/bin/sh
4309
4310 242:bde4f47b6427 chris
mirrordir="/var/mirror"
4311 1336:b61a51fb42b9 Chris
hg="/usr/bin/hg"
4312 242:bde4f47b6427 chris
4313 241:7658d21a1493 chris
project="$1"
4314
local_repo="$2"
4315
remote_repo="$3"
4316
4317
if [ -z "$project" ] || [ -z "$local_repo" ] || [ -z "$remote_repo" ]; then
4318
    echo "Usage: $0 <project> <local-repo-path> <remote-repo-url>"
4319
    exit 2
4320
fi
4321
4322
  # We need to handle different source repository types separately.
4323
  #
4324
  # The convert extension cannot convert directly from a remote git
4325
  # repo; we'd have to mirror to a local repo first.  Incremental
4326
  # conversions do work though.  The hg-git plugin will convert
4327
  # directly from remote repositories, but not via all schemes
4328
  # (e.g. https is not currently supported).  It's probably easier to
4329
  # use git itself to clone locally and then convert or hg-git from
4330
  # there.
4331
  #
4332
  # We can of course convert directly from remote Subversion repos,
4333
  # but we need to keep track of that -- you can ask to convert into a
4334
  # repo that has already been used (for Mercurial) and it'll do so
4335
  # happily; we don't want that.
4336
  #
4337
  # Converting from a remote Hg repo should be fine!
4338
  #
4339
  # One other thing -- we can't actually tell the difference between
4340
  # the various SCM types based on URL alone.  We have to try them
4341
  # (ideally in an order determined by a guess based on the URL) and
4342
  # see what happens.
4343
4344 242:bde4f47b6427 chris
project_mirror="$mirrordir/$project"
4345
mkdir -p "$project_mirror"
4346
project_repo_mirror="$project_mirror/repo"
4347 241:7658d21a1493 chris
4348 242:bde4f47b6427 chris
  # Some test URLs:
4349
  #
4350
  # http://aimc.googlecode.com/svn/trunk/
4351
  # http://aimc.googlecode.com/svn/
4352
  # http://vagar.org/git/flam
4353
  # https://github.com/wslihgt/IMMF0salience.git
4354
  # http://hg.breakfastquay.com/dssi-vst/
4355
  # git://github.com/schacon/hg-git.git
4356
  # http://svn.drobilla.net/lad (externals!)
4357
4358
# If we are importing from another distributed system, then our aim is
4359
# to create either a Hg repo or a git repo at $project_mirror, which
4360
# we can then pull from directly to the Hg repo at $local_repo (using
4361
# hg-git, in the case of a git repo).
4362
4363
# Importing from SVN, we should use hg convert directly to the target
4364
# hg repo (or should we?) but keep a record of the last changeset ID
4365
# we brought in, and test each time whether it matches the last
4366
# changeset ID actually in the repo
4367
4368
success=""
4369
4370 436:4eb486dbf730 Chris
# If we have a record of the last successfully updated remote repo
4371
# URL, check it against our current remote URL: if it has changed, we
4372
# will need to start again with a new clone rather than pulling
4373
# updates into the existing local mirror
4374
4375
successfile="$project_mirror/last_successful_url"
4376
if [ -f "$successfile" ]; then
4377
    last=$(cat "$successfile")
4378 437:102056ec2de9 chris
    if [ x"$last" = x"$remote_repo" ]; then
4379 436:4eb486dbf730 Chris
	echo "$$: Remote URL is unchanged from last successful update"
4380
    else
4381
	echo "$$: Remote URL has changed since last successful update:"
4382
	echo "$$: Last URL was $last, current is $remote_repo"
4383
	suffix="$$.$(date +%s)"
4384
	echo "$$: Moving existing repos to $suffix suffix and starting afresh"
4385
	mv "$project_repo_mirror" "$project_repo_mirror"."$suffix"
4386
	mv "$local_repo" "$local_repo"."$suffix"
4387
	mv "$successfile" "$successfile"."$suffix"
4388 437:102056ec2de9 chris
	touch "$project_mirror/url_changed"
4389 436:4eb486dbf730 Chris
    fi
4390
fi
4391
4392 242:bde4f47b6427 chris
if [ -d "$project_repo_mirror" ]; then
4393
4394
    # Repo mirror exists: update it
4395
    echo "$$: Mirror for project $project exists at $project_repo_mirror, updating" 1>&2
4396
4397
    if [ -d "$project_repo_mirror/.hg" ]; then
4398 433:7fd72f22a42b Chris
	"$hg" --config extensions.convert= convert --datesort "$remote_repo" "$project_repo_mirror" && success=true
4399 439:d3faf348b287 chris
	if [ -z "$success" ]; then
4400
	    ( cd "$project_repo_mirror" && "$hg" pull "$remote_repo" ) && success=true
4401
	fi
4402 242:bde4f47b6427 chris
    elif [ -d "$project_repo_mirror/.git" ]; then
4403 431:d3af621ba9d4 Chris
	( cd "$project_repo_mirror" && git pull "$remote_repo" master ) && success=true
4404 242:bde4f47b6427 chris
    else
4405
	echo "$$: ERROR: Repo mirror dir $project_repo_mirror exists but is not an Hg or git repo" 1>&2
4406
    fi
4407
4408
else
4409
4410
    # Repo mirror does not exist yet
4411
    echo "$$: Mirror for project $project does not yet exist at $project_repo_mirror, trying to convert or clone" 1>&2
4412
4413
    case "$remote_repo" in
4414
	*git*)
4415
	    git clone "$remote_repo" "$project_repo_mirror" ||
4416 433:7fd72f22a42b Chris
	    "$hg" --config extensions.convert= convert --datesort "$remote_repo" "$project_repo_mirror"
4417 242:bde4f47b6427 chris
	    ;;
4418
	*)
4419 433:7fd72f22a42b Chris
	    "$hg" --config extensions.convert= convert --datesort "$remote_repo" "$project_repo_mirror" ||
4420 299:defe55be97b9 chris
	    git clone "$remote_repo" "$project_repo_mirror" ||
4421 433:7fd72f22a42b Chris
	    "$hg" clone "$remote_repo" "$project_repo_mirror"
4422 242:bde4f47b6427 chris
	    ;;
4423
    esac && success=true
4424
4425
fi
4426
4427
echo "Success=$success"
4428
4429
if [ -n "$success" ]; then
4430
    echo "$$: Update successful, pulling into local repo at $local_repo"
4431 436:4eb486dbf730 Chris
    if [ ! -d "$local_repo" ]; then
4432
	"$hg" init "$local_repo"
4433
    fi
4434 242:bde4f47b6427 chris
    if [ -d "$project_repo_mirror/.git" ]; then
4435 436:4eb486dbf730 Chris
	( cd "$local_repo" && "$hg" --config extensions.hggit= pull "$project_repo_mirror" ) && echo "$remote_repo" > "$successfile"
4436 242:bde4f47b6427 chris
    else
4437 436:4eb486dbf730 Chris
	( cd "$local_repo" && "$hg" pull "$project_repo_mirror" ) && echo "$remote_repo" > "$successfile"
4438 242:bde4f47b6427 chris
    fi
4439
fi