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 @ 1552:3a2254124fa8

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 1548:fd4cc11ae096 Chris
1303
  next unless proj.is_public
1304
1305 1538:87bea4981d6d Chris
  next unless proj.respond_to?(:repository)
1306
1307
  repo = proj.repository
1308 1539:22d57b0e0a77 chris
  next if repo.nil? or repo.url.empty?
1309 1538:87bea4981d6d Chris
1310
  repo_url = repo.url
1311
  repo_url = repo_url.gsub(/^file:\/*/, "/");
1312
  if repo_url != File.join($repos_base, proj.identifier)
1313 1542:60acfbd8f6d6 Chris
    puts "Project #{proj.identifier} has repo in unsupported location #{repo_url}, skipping"
1314 1538:87bea4981d6d Chris
    next
1315
  end
1316
1317 1542:60acfbd8f6d6 Chris
  committers = repo.committers
1318 1538:87bea4981d6d Chris
1319
  authormap = ""
1320 1542:60acfbd8f6d6 Chris
  committers.each do |c, uid|
1321 1552:3a2254124fa8 Chris
1322
    # Some of our repos have broken email addresses in them: e.g. one
1323
    # changeset has a committer name of the form
1324
    #
1325
    # NAME <name <NAME <name@example.com">
1326
    #
1327
    # I don't know how it got like that... If the committer has more
1328
    # than one '<' in it, truncate it just before the first one, and
1329
    # then we look up the author name again.
1330
    if c =~ /<.*</ then
1331
      c = c.sub(/\s*<.*$/, "")
1332
    end
1333
1334 1538:87bea4981d6d Chris
    if not c =~ /[^<]+<.*@.*>/ then
1335 1542:60acfbd8f6d6 Chris
      user = User.find_by_id uid
1336 1539:22d57b0e0a77 chris
      authormap << "#{c}=#{user.name} <#{user.mail}>\n" unless user.nil?
1337 1538:87bea4981d6d Chris
    end
1338
  end
1339
1340 1539:22d57b0e0a77 chris
  File.open(File.join($out_base, "authormap_#{proj.identifier}"), "w") do |f|
1341 1538:87bea4981d6d Chris
    f.puts(authormap)
1342
  end
1343
1344
end
1345
1346 226:5b028aef59a7 chris
#!/usr/bin/perl -w
1347
1348
# Read a Doxyfile and print it out again to stdout, with only
1349
# whitelisted keys in it and with some keys set to pre-fixed values.
1350
#
1351
# Note that OUTPUT_DIRECTORY is not included; it should be added by
1352
# the caller
1353
1354
use strict;
1355
1356
my $txt = join "", <>;
1357
$txt =~ s/^\s*#.*$//gm;
1358
$txt =~ s/\\\n//gs;
1359
$txt =~ s/\r//g;
1360
$txt =~ s/\n\s*\n/\n/gs;
1361
1362
my %fixed = (
1363
    FULL_PATH_NAMES => "NO",
1364
    SYMBOL_CACHE_SIZE => 2,
1365
    EXCLUDE_SYMLINKS => "YES",
1366
    GENERATE_HTML => "YES",
1367
    PERL_PATH => "/usr/bin/perl",
1368
    HAVE_DOT => "YES",
1369
    HTML_OUTPUT => ".",
1370 228:3c084a25d8ab chris
    HTML_DYNAMIC_SECTIONS => "NO",
1371 226:5b028aef59a7 chris
    SEARCHENGINE => "NO",
1372
    DOT_FONTNAME => "FreeMono",
1373
    DOT_FONTSIZE => 10,
1374
    DOT_FONTPATH => "/usr/share/fonts/truetype/freefont",
1375
    DOT_IMAGE_FORMAT => "png",
1376
    DOT_PATH => "/usr/bin/dot",
1377
    DOT_TRANSPARENT => "YES",
1378
);
1379
1380 233:df89e7aa3ce8 Chris
# These are the keys that are safe to take from the output and include
1381
# in the output; they may still need to be checked for safe values (if
1382
# file paths).
1383 226:5b028aef59a7 chris
my @safe = qw(
1384 233:df89e7aa3ce8 Chris
INPUT
1385
FILE_PATTERNS
1386
EXAMPLE_PATH
1387
EXAMPLE_PATTERNS
1388
IMAGE_PATH
1389
INCLUDE_PATH
1390
INCLUDE_FILE_PATTERNS
1391 226:5b028aef59a7 chris
DOXYFILE_ENCODING
1392
PROJECT_NAME
1393
PROJECT_NUMBER
1394
CREATE_SUBDIRS
1395
OUTPUT_LANGUAGE
1396
BRIEF_MEMBER_DESC
1397
REPEAT_BRIEF
1398
ABBREVIATE_BRIEF
1399
ALWAYS_DETAILED_SEC
1400
INLINE_INHERITED_MEMB
1401
STRIP_FROM_PATH
1402
STRIP_FROM_INC_PATH
1403
JAVADOC_AUTOBRIEF
1404
QT_AUTOBRIEF
1405
MULTILINE_CPP_IS_BRIEF
1406
INHERIT_DOCS
1407
SEPARATE_MEMBER_PAGES
1408
TAB_SIZE
1409
ALIASES
1410
OPTIMIZE_OUTPUT_FOR_C
1411
OPTIMIZE_OUTPUT_JAVA
1412
OPTIMIZE_FOR_FORTRAN
1413
OPTIMIZE_OUTPUT_VHDL
1414
EXTENSION_MAPPING
1415
BUILTIN_STL_SUPPORT
1416
CPP_CLI_SUPPORT
1417
SIP_SUPPORT
1418
IDL_PROPERTY_SUPPORT
1419
DISTRIBUTE_GROUP_DOC
1420
SUBGROUPING
1421
TYPEDEF_HIDES_STRUCT
1422
EXTRACT_ALL
1423
EXTRACT_PRIVATE
1424
EXTRACT_STATIC
1425
EXTRACT_LOCAL_CLASSES
1426
EXTRACT_LOCAL_METHODS
1427
EXTRACT_ANON_NSPACES
1428
HIDE_UNDOC_MEMBERS
1429
HIDE_UNDOC_CLASSES
1430
HIDE_FRIEND_COMPOUNDS
1431
HIDE_IN_BODY_DOCS
1432
INTERNAL_DOCS
1433
HIDE_SCOPE_NAMES
1434
SHOW_INCLUDE_FILES
1435
FORCE_LOCAL_INCLUDES
1436
INLINE_INFO
1437
SORT_MEMBER_DOCS
1438
SORT_BRIEF_DOCS
1439
SORT_MEMBERS_CTORS_1ST
1440
SORT_GROUP_NAMES
1441
SORT_BY_SCOPE_NAME
1442
GENERATE_TODOLIST
1443
GENERATE_TESTLIST
1444
GENERATE_BUGLIST
1445
GENERATE_DEPRECATEDLIST
1446
ENABLED_SECTIONS
1447
MAX_INITIALIZER_LINES
1448
SHOW_USED_FILES
1449
SHOW_DIRECTORIES
1450
SHOW_FILES
1451
SHOW_NAMESPACES
1452
QUIET
1453
WARNINGS
1454
WARN_IF_UNDOCUMENTED
1455
WARN_IF_DOC_ERROR
1456
WARN_NO_PARAMDOC
1457
INPUT_ENCODING
1458
RECURSIVE
1459
EXCLUDE
1460
EXCLUDE_SYMLINKS
1461
EXCLUDE_PATTERNS
1462
EXCLUDE_SYMBOLS
1463
EXAMPLE_RECURSIVE
1464
SOURCE_BROWSER
1465
INLINE_SOURCES
1466
STRIP_CODE_COMMENTS
1467
REFERENCED_BY_RELATION
1468
REFERENCES_RELATION
1469
REFERENCES_LINK_SOURCE
1470
VERBATIM_HEADERS
1471
ALPHABETICAL_INDEX
1472
COLS_IN_ALPHA_INDEX
1473
IGNORE_PREFIX
1474
HTML_TIMESTAMP
1475
HTML_ALIGN_MEMBERS
1476
ENABLE_PREPROCESSING
1477
MACRO_EXPANSION
1478
EXPAND_ONLY_PREDEF
1479
SEARCH_INCLUDES
1480
PREDEFINED
1481
EXPAND_AS_DEFINED
1482
SKIP_FUNCTION_MACROS
1483
ALLEXTERNALS
1484
EXTERNAL_GROUPS
1485
CLASS_DIAGRAMS
1486
HIDE_UNDOC_RELATIONS
1487
CLASS_GRAPH
1488
COLLABORATION_GRAPH
1489
GROUP_GRAPHS
1490
UML_LOOK
1491
TEMPLATE_RELATIONS
1492
INCLUDE_GRAPH
1493
INCLUDED_BY_GRAPH
1494
CALL_GRAPH
1495
CALLER_GRAPH
1496
GRAPHICAL_HIERARCHY
1497
DIRECTORY_GRAPH
1498
DOT_GRAPH_MAX_NODES
1499
MAX_DOT_GRAPH_DEPTH
1500
DOT_MULTI_TARGETS
1501
DOT_CLEANUP
1502
);
1503
1504
my %safehash;
1505
for my $sk (@safe) { $safehash{$sk} = 1; }
1506
1507
my @lines = split "\n", $txt;
1508
1509
my %settings;
1510
1511
sub is_safe {
1512
    my $key = shift;
1513
    defined $safehash{$key} and $safehash{$key} == 1;
1514
}
1515
1516
sub has_file_path {
1517
    # Returns true if the given key expects a file path as a value.
1518
    # We only need to test keys that are safe; unsafe keys have been
1519
    # rejected already.
1520
    my $key = shift;
1521
    $key eq "INPUT" or
1522
	$key =~ /^OUTPUT_/ or
1523
	$key =~ /_PATH$/ or
1524
	$key =~ /_PATTERNS$/;
1525
}
1526
1527
sub is_safe_file_path {
1528
    my $value = shift;
1529
    not $value =~ /^\// and not $value =~ /\.\./;
1530
}
1531
1532
foreach my $line (@lines) {
1533
1534
    chomp $line;
1535
    my ($key, $value) = split /\s*=\s*/, $line;
1536
1537
    next if !defined $key;
1538
1539
    if ($key =~ /^GENERATE_/ and not $key =~ /LIST$/) {
1540
	print STDERR "NOTE: Setting $key explicitly to NO\n";
1541
	$settings{$key} = "NO";
1542
	next;
1543
    }
1544
1545
    if (!is_safe($key)) {
1546
	print STDERR "NOTE: Skipping non-whitelisted key $key\n";
1547
	next;
1548
    }
1549
1550
    if (has_file_path($key) and !is_safe_file_path($value)) {
1551
	print STDERR "ERROR: Unsafe file path \"$value\" for key $key\n";
1552
	exit 1;
1553
    }
1554
1555
    $settings{$key} = $value;
1556
}
1557
1558 228:3c084a25d8ab chris
foreach my $key (keys %fixed) {
1559
    my $value = $fixed{$key};
1560
    print STDERR "NOTE: Setting $key to fixed value $value\n";
1561
    $settings{$key} = $value;
1562
}
1563
1564 226:5b028aef59a7 chris
print join "\n", map { "$_ = $settings{$_}" } keys %settings;
1565
print "\n";
1566 1543:05d639e5d59b Chris
#!/bin/bash
1567
1568
set -e
1569
1570
progdir=$(dirname $0)
1571
case "$progdir" in
1572
    /*) ;;
1573
    *) progdir="$(pwd)/$progdir" ;;
1574
esac
1575
1576
rails_scriptdir="$progdir/../../script"
1577
rails="$rails_scriptdir/rails"
1578
1579
if [ ! -x "$rails" ]; then
1580
    echo "Expected to find rails executable at $rails"
1581
    exit 2
1582
fi
1583
1584
fastexport="$progdir/../fast-export/hg-fast-export.sh"
1585
if [ ! -x "$fastexport" ]; then
1586
    echo "Expected to find hg-fast-export.sh executable at $fastexport"
1587
    exit 2
1588
fi
1589
1590 1546:248c402992ba Chris
environment="$1"
1591
hgdir="$2"
1592
gitdir="$3"
1593 1543:05d639e5d59b Chris
1594
if [ -z "$hgdir" ] || [ -z "$gitdir" ]; then
1595 1546:248c402992ba Chris
    echo "Usage: $0 <environment> <hgdir> <gitdir>"
1596
    echo "  where"
1597
    echo "  - environment is the Rails environment (development or production)"
1598
    echo "  - hgdir is the directory containing project Mercurial repositories"
1599
    echo "  - gitdir is the directory in which output git repositories are to be"
1600
    echo "    created or updated"
1601 1543:05d639e5d59b Chris
    exit 2
1602
fi
1603
1604
if [ ! -d "$hgdir" ]; then
1605
    echo "Mercurial repository directory $hgdir not found"
1606
    exit 1
1607
fi
1608
1609
if [ ! -d "$gitdir" ]; then
1610
    echo "Target git repository dir $gitdir not found (please create at least the empty directory)"
1611
    exit 1
1612
fi
1613
1614
set -u
1615
1616 1550:7d825cbd76c8 Chris
authordir="$gitdir/__AUTHORMAPS"
1617 1543:05d639e5d59b Chris
mkdir -p "$authordir"
1618
1619 1550:7d825cbd76c8 Chris
wastedir="$gitdir/__WASTE"
1620
mkdir -p "$wastedir"
1621
1622 1547:bca3b5e5bbf2 Chris
echo "Extracting author maps..."
1623 1546:248c402992ba Chris
1624 1550:7d825cbd76c8 Chris
# Delete any existing authormap files, because we want to ensure we
1625
# don't have an authormap for any project that was exportable but has
1626
# become non-exportable (e.g. has gone private)
1627 1551:36dddb6755f6 Chris
rm -f "$authordir/*"
1628 1550:7d825cbd76c8 Chris
1629 1546:248c402992ba Chris
"$rails" runner -e "$environment" "$progdir/create-repo-authormaps.rb" \
1630 1543:05d639e5d59b Chris
	 -s "$hgdir" -o "$authordir"
1631
1632
for hgrepo in "$hgdir"/*; do
1633
1634
    if [ ! -d "$hgrepo/.hg" ]; then
1635
	echo "Directory $hgrepo does not appear to be a Mercurial repo, skipping"
1636
	continue
1637
    fi
1638
1639
    reponame=$(basename "$hgrepo")
1640
    authormap="$authordir/authormap_$reponame"
1641
    gitrepo="$gitdir/$reponame"
1642
1643
    if [ ! -f "$authormap" ]; then
1644 1547:bca3b5e5bbf2 Chris
	echo "No authormap file was created for repo $reponame, skipping"
1645 1550:7d825cbd76c8 Chris
1646
	# If there is no authormap file, then we should not have a git
1647
	# mirror -- this is a form of access control, not just an
1648
	# optimisation (authormap files are expected to exist for all
1649
	# exportable projects, even if empty). So if a git mirror
1650
	# exists, we move it away
1651
	if [ -d "$gitrepo" ]; then
1652
	    mv "$gitrepo" "$wastedir/$(date +%s).$reponame"
1653
	fi
1654
1655 1543:05d639e5d59b Chris
	continue
1656
    fi
1657
1658
    if [ ! -d "$gitrepo" ]; then
1659
	git init "$gitrepo"
1660
    fi
1661
1662 1547:bca3b5e5bbf2 Chris
    echo
1663 1546:248c402992ba Chris
    echo "About to run fast export for repo $reponame..."
1664 1543:05d639e5d59b Chris
1665
    (
1666
	cd "$gitrepo"
1667 1549:28cde511f312 Chris
1668
        # Force is necessary because git-fast-import (or git) can't handle
1669
        # branches having more than one head ("Error: repository has at
1670
        # least one unnamed head"), which happens from time to time in
1671
        # valid Hg repos. With --force apparently it will just pick one
1672
        # of the two heads arbitrarily, which is also alarming but is
1673
        # more likely to be useful
1674
	"$fastexport" --quiet -r "$hgrepo" -A "$authormap" --hg-hash --force
1675 1543:05d639e5d59b Chris
    )
1676
1677
    echo "Fast export done"
1678
1679
done
1680
1681
echo "All done"
1682
1683 203:1e55195bca45 chris
#!/bin/bash
1684
1685
# Run this script from anywhere
1686
1687
# Enumerate Hg repos; make sure they're up to date; extract docs for
1688
# each
1689
1690
hgdir="/var/hg"
1691
docdir="/var/doc"
1692 223:c3544e9fd588 chris
logfile="/var/www/test-cannam/log/extract-docs.log"
1693
1694
redgrp="redmine"
1695 203:1e55195bca45 chris
1696 218:292cde42265a chris
apikey=""
1697 339:5410d82c12df chris
apischeme="https"
1698 218:292cde42265a chris
apihost=""
1699
apiuser=""
1700
apipass=""
1701
1702 203:1e55195bca45 chris
progdir=$(dirname $0)
1703
case "$progdir" in
1704
    /*) ;;
1705
    *) progdir="$(pwd)/$progdir" ;;
1706
esac
1707
1708 411:e7ba81c8dc5a chris
types="doxygen javadoc matlabdocs" # Do Doxygen first (it can be used for Java too)
1709 203:1e55195bca45 chris
1710
for x in $types; do
1711
    if [ ! -x "$progdir/extract-$x.sh" ]; then
1712
	echo "Helper script not available: $progdir/extract-$x.sh"
1713
	exit 1
1714
    fi
1715
done
1716
1717 218:292cde42265a chris
enable_embedded()
1718
{
1719
    p="$1"
1720 228:3c084a25d8ab chris
    if [ -n "$apikey" ]; then
1721
	if [ -n "$apiuser" ]; then
1722 339:5410d82c12df chris
	    sudo -u docgen curl -u "$apiuser":"$apipass" "$apischeme://$apihost/sys/projects/$p/embedded.xml?enable=1&key=$apikey" -d ""
1723 228:3c084a25d8ab chris
	else
1724 339:5410d82c12df chris
	    sudo -u docgen curl "$apischeme://$apihost/sys/projects/$p/embedded.xml?enable=1&key=$apikey" -d ""
1725 228:3c084a25d8ab chris
	fi
1726
    else
1727
	echo "Can't enable Embedded, API not configured" 1>&2
1728 218:292cde42265a chris
    fi
1729
}
1730
1731 223:c3544e9fd588 chris
# We want to ensure the doc extraction is done by the unprivileged
1732
# user docgen, which is not a member of any interesting group
1733
#
1734
# To this end, we create the tmpdir with user docgen and group
1735
# www-data, and use the www-data user to pull out an archive of the Hg
1736
# repo tip into a location beneath that, before using the docgen user
1737
# to extract docs from that location and write them into the tmpdir
1738
1739
# Same tmpdir for each project: we delete and recreate to avoid
1740
# cleanup duty from lots of directories being created
1741
#
1742
tmpdir=$(mktemp -d "$docdir/tmp_XXXXXX")
1743
1744
fail()
1745
{
1746
    message="$1"
1747
    echo "$message" 1>&2
1748
    case "$tmpdir" in
1749
	*/tmp*) rm -rf "$tmpdir";;
1750
	*);;
1751
    esac
1752
    exit 1
1753
}
1754
1755
case "$tmpdir" in
1756
    /*) ;;
1757
    *) fail "Temporary directory creation failed";;
1758
esac
1759
1760
chown docgen.www-data "$tmpdir" || fail "Temporary directory ownership change failed"
1761
chmod g+rwx "$tmpdir" || fail "Temporary directory permissions change failed"
1762
1763 203:1e55195bca45 chris
for projectdir in "$hgdir"/* ; do
1764
1765
    if [ -d "$projectdir" ] && [ -d "$projectdir/.hg" ]; then
1766
1767 223:c3544e9fd588 chris
	if ! sudo -u www-data hg -R "$projectdir" -q update; then
1768
	    echo "Failed to update Hg in $projectdir, skipping" 1>&2
1769
	    continue
1770
	fi
1771
1772 203:1e55195bca45 chris
	project=$(basename "$projectdir")
1773
1774 223:c3544e9fd588 chris
	tmptargetdir="$tmpdir/doc"
1775
	snapshotdir="$tmpdir/hgsnapshot"
1776 203:1e55195bca45 chris
1777 223:c3544e9fd588 chris
	rm -rf "$tmptargetdir" "$snapshotdir"
1778
1779 226:5b028aef59a7 chris
	mkdir -m 770 "$tmptargetdir" || fail "Temporary target directory creation failed"
1780
	chown docgen.www-data "$tmptargetdir" || fail "Temporary target directory ownership change failed"
1781 223:c3544e9fd588 chris
1782
	mkdir -m 770 "$snapshotdir" || fail "Snapshot directory creation failed"
1783
	chown docgen.www-data "$snapshotdir" || fail "Snapshot directory ownership change failed"
1784
1785
	hgparents=$(sudo -u www-data hg -R "$projectdir" parents)
1786
	if [ -z "$hgparents" ]; then
1787
	    echo "Hg repo at $projectdir has no working copy (empty repo?), skipping"
1788
	    continue
1789
	else
1790
	    echo "Found non-empty Hg repo: $projectdir for project $project"
1791
	fi
1792
1793
	if ! sudo -u www-data hg -R "$projectdir" archive -r tip -t files "$snapshotdir"; then
1794
	    echo "Failed to pick archive from $projectdir, skipping" 1>&2
1795
	    continue
1796
	fi
1797 203:1e55195bca45 chris
1798
	targetdir="$docdir/$project"
1799
1800 223:c3544e9fd588 chris
	echo "Temporary dir is $tmpdir, temporary doc dir is $tmptargetdir, snapshot dir is $snapshotdir, eventual target is $targetdir"
1801 203:1e55195bca45 chris
1802
	for x in $types; do
1803 226:5b028aef59a7 chris
	    if sudo -u docgen "$progdir/extract-$x.sh" "$project" "$snapshotdir" "$tmptargetdir" >> "$logfile" 2>&1; then
1804
		break
1805
	    else
1806 203:1e55195bca45 chris
		echo "Failed to extract via type $x"
1807
	    fi
1808
	done
1809
1810 223:c3544e9fd588 chris
        if [ -f "$tmptargetdir/index.html" ]; then
1811 203:1e55195bca45 chris
	    echo "Processing resulted in an index.html being created, looks good!"
1812
	    if [ ! -d "$targetdir" ] || [ ! -f "$targetdir/index.html" ]; then
1813 223:c3544e9fd588 chris
		echo "This project hasn't had doc extracted before: enabling Embedded"
1814 218:292cde42265a chris
		enable_embedded "$project"
1815 203:1e55195bca45 chris
	    fi
1816
1817
	    if [ -d "$targetdir" ]; then
1818
		mv "$targetdir" "$targetdir"_"$$" && \
1819 223:c3544e9fd588 chris
		    mv "$tmptargetdir" "$targetdir" && \
1820 203:1e55195bca45 chris
		    rm -rf "$targetdir"_"$$"
1821 223:c3544e9fd588 chris
		chgrp -R "$redgrp" "$targetdir"
1822 203:1e55195bca45 chris
	    else
1823 223:c3544e9fd588 chris
		mv "$tmptargetdir" "$targetdir"
1824
		chgrp -R "$redgrp" "$targetdir"
1825 203:1e55195bca45 chris
	    fi
1826 228:3c084a25d8ab chris
	else
1827
	    echo "Processing did not result in an index.html being created"
1828 203:1e55195bca45 chris
	fi
1829
    fi
1830
done
1831
1832 223:c3544e9fd588 chris
rm -rf "$tmpdir"
1833 203:1e55195bca45 chris
#!/bin/bash
1834
1835
docdir="/var/doc"
1836
1837 228:3c084a25d8ab chris
progdir=$(dirname $0)
1838
case "$progdir" in
1839
    /*) ;;
1840
    *) progdir="$(pwd)/$progdir" ;;
1841
esac
1842
1843 203:1e55195bca45 chris
project="$1"
1844 223:c3544e9fd588 chris
projectdir="$2"
1845
targetdir="$3"
1846 203:1e55195bca45 chris
1847 223:c3544e9fd588 chris
if [ -z "$project" ] || [ -z "$targetdir" ] || [ -z "$projectdir" ]; then
1848
    echo "Usage: $0 <project> <projectdir> <targetdir>"
1849 203:1e55195bca45 chris
    exit 2
1850
fi
1851
1852 223:c3544e9fd588 chris
if [ ! -d "$projectdir" ]; then
1853
    echo "Project directory $projectdir not found"
1854 203:1e55195bca45 chris
    exit 1
1855
fi
1856
1857
if [ ! -d "$targetdir" ]; then
1858
    echo "Target dir $targetdir not found"
1859
    exit 1
1860
fi
1861
1862
if [ -f "$targetdir/index.html" ]; then
1863
    echo "Target dir $targetdir already contains index.html"
1864
    exit 1
1865
fi
1866
1867
doxyfile=$(find "$projectdir" -type f -name Doxyfile -print | head -1)
1868
1869
if [ -z "$doxyfile" ]; then
1870
    echo "No Doxyfile found for project $project"
1871
    exit 1
1872
fi
1873
1874
echo "Project $project contains a Doxyfile at $doxyfile"
1875
1876
cd "$projectdir" || exit 1
1877
1878 228:3c084a25d8ab chris
"$progdir/doxysafe.pl" "$doxyfile" | \
1879
    sed -e '$a OUTPUT_DIRECTORY='"$targetdir" | \
1880 203:1e55195bca45 chris
    doxygen -
1881
1882
#!/bin/bash
1883 168:c1e9f2dab1d5 chris
1884 203:1e55195bca45 chris
docdir="/var/doc"
1885 168:c1e9f2dab1d5 chris
1886 203:1e55195bca45 chris
project="$1"
1887 223:c3544e9fd588 chris
projectdir="$2"
1888
targetdir="$3"
1889 168:c1e9f2dab1d5 chris
1890 223:c3544e9fd588 chris
if [ -z "$project" ] || [ -z "$targetdir" ] || [ -z "$projectdir" ]; then
1891
    echo "Usage: $0 <project> <projectdir> <targetdir>"
1892 203:1e55195bca45 chris
    exit 2
1893 168:c1e9f2dab1d5 chris
fi
1894
1895 223:c3544e9fd588 chris
if [ ! -d "$projectdir" ]; then
1896
    echo "Project directory $projectdir not found"
1897 203:1e55195bca45 chris
    exit 1
1898
fi
1899 168:c1e9f2dab1d5 chris
1900 203:1e55195bca45 chris
if [ ! -d "$targetdir" ]; then
1901
    echo "Target dir $targetdir not found"
1902
    exit 1
1903
fi
1904 168:c1e9f2dab1d5 chris
1905 203:1e55195bca45 chris
if [ -f "$targetdir/index.html" ]; then
1906
    echo "Target dir $targetdir already contains index.html"
1907
    exit 1
1908 178:2cec5c53cd68 chris
fi
1909 168:c1e9f2dab1d5 chris
1910 191:0d1c6fa50d3a chris
# Identify Java files whose packages match the trailing parts of their
1911
# paths, and list the resulting packages and the path prefixes with
1912
# the packages removed (so as to find code in subdirs,
1913
# e.g. src/com/example/...)
1914
1915
# Regexp match is very rough; check what is actually permitted for
1916
# package declarations
1917
1918 203:1e55195bca45 chris
find "$projectdir" -type f -name \*.java \
1919 989:3549525ba22a Chris
    -exec egrep '^ *package +[a-zA-Z][a-zA-Z0-9\._-]*;.*$' \{\} /dev/null \; |
1920
    sed -e 's/\/[^\/]*: *package */:/' -e 's/;.*$//' |
1921 191:0d1c6fa50d3a chris
    sort | uniq | (
1922
	current_prefix=
1923
	current_packages=
1924
	while IFS=: read filepath package; do
1925
	    echo "Looking at $package in $filepath"
1926
	    packagepath=${package//./\/}
1927
	    prefix=${filepath%$packagepath}
1928 203:1e55195bca45 chris
	    prefix=${prefix:=$projectdir}
1929 191:0d1c6fa50d3a chris
	    if [ "$prefix" = "$filepath" ]; then
1930
		echo "Package $package does not match suffix of path $filepath, skipping"
1931
		continue
1932
	    fi
1933
	    if [ "$prefix" != "$current_prefix" ]; then
1934 450:73401a15037b Chris
		echo "Package $package matches file path and has new prefix $prefix"
1935 191:0d1c6fa50d3a chris
		if [ -n "$current_packages" ]; then
1936
		    echo "Running Javadoc for packages $current_packages from prefix $current_prefix"
1937 450:73401a15037b Chris
		    echo "Command is: javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages"
1938 203:1e55195bca45 chris
		    javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages
1939 191:0d1c6fa50d3a chris
		fi
1940
		current_prefix="$prefix"
1941 450:73401a15037b Chris
		current_packages="$package"
1942 191:0d1c6fa50d3a chris
	    else
1943 450:73401a15037b Chris
		echo "Package $package matches file path with same prefix as previous file"
1944 191:0d1c6fa50d3a chris
		current_packages="$current_packages $package"
1945
	    fi
1946
	done
1947 203:1e55195bca45 chris
	prefix=${prefix:=$projectdir}
1948 191:0d1c6fa50d3a chris
	if [ -n "$current_packages" ]; then
1949
	    echo "Running Javadoc for packages $current_packages in prefix $current_prefix"
1950 450:73401a15037b Chris
  	    echo "Command is: javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages"
1951 203:1e55195bca45 chris
	    javadoc -sourcepath "$current_prefix" -d "$targetdir" -subpackages $current_packages
1952 191:0d1c6fa50d3a chris
	fi
1953
    )
1954
1955 450:73401a15037b Chris
if [ -f "$targetdir"/overview-tree.html ]; then
1956
    cp "$targetdir"/overview-tree.html "$targetdir"/index.html
1957
fi
1958
1959 203:1e55195bca45 chris
# for exit code:
1960
[ -f "$targetdir/index.html" ]
1961 168:c1e9f2dab1d5 chris
1962 411:e7ba81c8dc5a chris
#!/bin/bash
1963
1964
docdir="/var/doc"
1965
1966
progdir=$(dirname $0)
1967
case "$progdir" in
1968
    /*) ;;
1969
    *) progdir="$(pwd)/$progdir" ;;
1970
esac
1971
1972
project="$1"
1973
projectdir="$2"
1974
targetdir="$3"
1975
1976
if [ -z "$project" ] || [ -z "$targetdir" ] || [ -z "$projectdir" ]; then
1977
    echo "Usage: $0 <project> <projectdir> <targetdir>"
1978
    exit 2
1979
fi
1980
1981
if [ ! -d "$projectdir" ]; then
1982
    echo "Project directory $projectdir not found"
1983
    exit 1
1984
fi
1985
1986
if [ ! -d "$targetdir" ]; then
1987
    echo "Target dir $targetdir not found"
1988
    exit 1
1989
fi
1990
1991
if [ -f "$targetdir/index.html" ]; then
1992
    echo "Target dir $targetdir already contains index.html"
1993
    exit 1
1994
fi
1995
1996
mfile=$(find "$projectdir" -type f -name \*.m -print0 | xargs -0 grep -l '^% ' | head -1)
1997
1998
if [ -z "$mfile" ]; then
1999
    echo "No MATLAB files with comments found for project $project"
2000
    exit 1
2001
fi
2002
2003
echo "Project $project contains at least one MATLAB file with comments"
2004
2005
cd "$projectdir" || exit 1
2006
2007
perl "$progdir/matlab-docs.pl" -c "$progdir/matlab-docs.conf" -d "$targetdir"
2008
2009 978:bbb88c44f805 Chris
2010 980:9b4919de5317 Chris
# Read an Apache log file in SoundSoftware site format from stdin and
2011
# produce some per-project stats.
2012 978:bbb88c44f805 Chris
#
2013
# Invoke with e.g.
2014
#
2015
# cat /var/log/apache2/code-access.log | \
2016
#   script/runner -e production extra/soundsoftware/get-apache-log-stats.rb
2017
2018 975:198f764e734c Chris
2019
# Use the ApacheLogRegex parser, a neat thing
2020
# See http://www.simonecarletti.com/blog/2009/02/apache-log-regex-a-lightweight-ruby-apache-log-parser/
2021
require 'apachelogregex'
2022
2023
# This is the format defined in our httpd.conf
2024
vhost_combined_format = '%v:%p %h %{X-Forwarded-For}i %l %u %t \"%r\" %>s %O \"%{Referer}i\" \"%{User-Agent}i\"'
2025
2026
parser = ApacheLogRegex.new(vhost_combined_format)
2027
2028
# project name -> count of hg clones
2029
clones = Hash.new(0)
2030
2031
# project name -> count of hg pulls
2032
pulls = Hash.new(0)
2033
2034 978:bbb88c44f805 Chris
# project name -> count of hg pushes
2035
pushes = Hash.new(0)
2036 975:198f764e734c Chris
2037
# project name -> count of hg archive requests (i.e. Download as Zip)
2038
zips = Hash.new(0)
2039
2040
# project name -> count of hits to pages under /projects/projectname
2041
hits = Hash.new(0)
2042
2043 978:bbb88c44f805 Chris
# project name -> Project object
2044
@projects = Hash.new
2045
2046 975:198f764e734c Chris
parseable = 0
2047
unparseable = 0
2048
2049 979:56a38a9f6204 Chris
def is_public_project?(project)
2050 978:bbb88c44f805 Chris
  if !project
2051
    false
2052 983:a97e573d7f87 Chris
  elsif project =~ /^\d+$/
2053
    # ignore numerical project ids, they are only used when editing projects
2054
    false
2055 978:bbb88c44f805 Chris
  elsif @projects.key?(project)
2056 979:56a38a9f6204 Chris
    @projects[project].is_public?
2057 978:bbb88c44f805 Chris
  else
2058
    pobj = Project.find_by_identifier(project)
2059
    if pobj
2060
      @projects[project] = pobj
2061 979:56a38a9f6204 Chris
      pobj.is_public?
2062 978:bbb88c44f805 Chris
    else
2063 979:56a38a9f6204 Chris
      print "Project not found: ", project, "\n"
2064 978:bbb88c44f805 Chris
      false
2065
    end
2066
  end
2067
end
2068
2069 980:9b4919de5317 Chris
def print_stats(h)
2070
  h.keys.sort { |a,b| h[b] <=> h[a] }.each do |p|
2071 982:6edb748be064 Chris
    if h[p] > 0
2072 983:a97e573d7f87 Chris
      print h[p], " ", @projects[p].name, " [", p, "]\n"
2073 982:6edb748be064 Chris
    end
2074 980:9b4919de5317 Chris
  end
2075
end
2076
2077 979:56a38a9f6204 Chris
STDIN.each do |line|
2078 975:198f764e734c Chris
2079
  record = parser.parse(line)
2080
2081
  # most annoyingly, the parser can't handle the comma-separated list
2082
  # in X-Forwarded-For where it has more than one element. If it has
2083 983:a97e573d7f87 Chris
  # failed, remove any IP addresses or the word "unknown" with
2084
  # trailing commas and try again
2085 975:198f764e734c Chris
  if not record
2086 983:a97e573d7f87 Chris
    filtered = line.gsub(/(unknown|([0-9]+\.){3}[0-9]+),\s*/, "")
2087 975:198f764e734c Chris
    record = parser.parse(filtered)
2088
  end
2089
2090
  # discard, but count, unparseable lines
2091
  if not record
2092 979:56a38a9f6204 Chris
    print "Line not parseable: ", line, "\n"
2093 975:198f764e734c Chris
    unparseable += 1
2094
    next
2095
  end
2096
2097
  # discard everything that isn't a 200 OK response
2098
  next if record["%>s"] != "200"
2099
2100
  # discard anything apparently requested by a crawler
2101
  next if record["%{User-Agent}i"] =~ /(bot|slurp|crawler|spider|Redmine)\b/i
2102
2103
  # pull out request e.g. GET / HTTP/1.0
2104
  request = record["%r"]
2105
2106
  # split into method, path, protocol
2107
  if not request =~ /^[^\s]+ ([^\s]+) [^\s]+$/
2108 979:56a38a9f6204 Chris
    print "Line not parseable (bad method, path, protocol): ", line, "\n"
2109 975:198f764e734c Chris
    unparseable += 1
2110
    next
2111
  end
2112
2113
  # get the path e.g. /projects/weevilmatic and split on /
2114
  path = $~[1]
2115
  components = path.split("/")
2116
2117
  # should have at least two elements unless path is "/"; first should
2118
  # be empty (begins with /)
2119
  if path != "/" and (components.size < 2 or components[0] != "")
2120 979:56a38a9f6204 Chris
    print "Line not parseable (degenerate path): ", line, "\n"
2121 975:198f764e734c Chris
    unparseable += 1
2122
    next
2123
  end
2124
2125
  if components[1] == "hg"
2126
2127
    # path is /hg/project?something or /hg/project/something
2128
2129
    project = components[2].split("?")[0]
2130 979:56a38a9f6204 Chris
    if not is_public_project?(project)
2131 978:bbb88c44f805 Chris
      next
2132
    end
2133 975:198f764e734c Chris
2134
    if components[2] =~ /&roots=00*$/
2135
      clones[project] += 1
2136
    elsif components[2] =~ /cmd=capabilities/
2137
      pulls[project] += 1
2138 978:bbb88c44f805 Chris
    elsif components[2] =~ /cmd=unbundle/
2139
      pushes[project] += 1
2140 975:198f764e734c Chris
    elsif components[3] == "archive"
2141
      zips[project] += 1
2142
    end
2143
2144
  elsif components[1] == "projects"
2145
2146
    # path is /projects/project or /projects/project/something
2147
2148
    project = components[2]
2149 979:56a38a9f6204 Chris
    project = project.split("?")[0] if project
2150
    if not is_public_project?(project)
2151 978:bbb88c44f805 Chris
      next
2152 975:198f764e734c Chris
    end
2153
2154 978:bbb88c44f805 Chris
    hits[project] += 1
2155
2156 975:198f764e734c Chris
  end
2157
2158
  parseable += 1
2159
end
2160
2161
# Each clone is also a pull; deduct it from the pulls hash, because we
2162
# want that to contain only non-clone pulls
2163
2164
clones.keys.each do |project|
2165
  pulls[project] -= 1
2166
end
2167
2168 982:6edb748be064 Chris
print parseable, " parseable\n"
2169
print unparseable, " unparseable\n"
2170
2171
2172 980:9b4919de5317 Chris
print "\nMercurial clones:\n"
2173
print_stats clones
2174
2175
print "\nMercurial pulls (excluding clones):\n"
2176
print_stats pulls
2177
2178
print "\nMercurial pushes:\n"
2179
print_stats pushes
2180
2181
print "\nMercurial archive (zip file) downloads:\n"
2182
print_stats zips
2183
2184 982:6edb748be064 Chris
print "\nProject page hits (excluding crawlers):\n"
2185 980:9b4919de5317 Chris
print_stats hits
2186 975:198f764e734c Chris
2187
2188 1536:e2a3230f61fa Chris
2189
# Print out an authormap file for hg-to-git conversion using
2190
# hg-fast-export
2191
#
2192
# Invoke with the project identifier as argument, e.g.
2193
#
2194
# ./script/rails runner -e production extra/soundsoftware/get-repo-authormap.rb soundsoftware-site
2195
2196 1537:e55cbb9ba8bf Chris
proj_ident = ARGV.last
2197 1536:e2a3230f61fa Chris
proj = Project.find_by_identifier(proj_ident)
2198
repo = Repository.where(:project_id => proj.id).first
2199
csets = Changeset.where(:repository_id => repo.id)
2200
committers = csets.map do |c| c.committer end.sort.uniq
2201
committers.each do |c|
2202 1537:e55cbb9ba8bf Chris
  if not c =~ /[^<]+<.*@.*>/ then
2203
    u = repo.find_committer_user c
2204
    print "#{c}=#{u.name} <#{u.mail}>\n" unless u.nil?
2205
  end
2206 1536:e2a3230f61fa Chris
end
2207 970:6bd8364eafae luis
2208 1453:b554eb79ec7b luis
# Log user and project information
2209
#
2210
# Invoke with e.g.
2211
#
2212
# ./script/rails runner -e production extra/soundsoftware/get-statistics.rb
2213 970:6bd8364eafae luis
#
2214
2215 1454:02a05da0bedc luis
projectStats =  {
2216
        :all => Project.active.all.count,
2217
        :private => Project.active.find(:all, :conditions => {:is_public => false}).count,
2218
        :top_level => Project.active.find(:all, :conditions => {:parent_id => nil}).count,
2219
        :top_level_and_private => Project.active.find(:all, :conditions => {:is_public => false, :parent_id => nil}).count
2220
      }
2221 970:6bd8364eafae luis
2222 1453:b554eb79ec7b luis
userStats = {:all => User.active.all.count}
2223 1002:f6ede18f3e6e Chris
2224 1453:b554eb79ec7b luis
stats = {:date => Date.today, :projects => projectStats, :users => userStats}.to_json
2225 1002:f6ede18f3e6e Chris
2226 1453:b554eb79ec7b luis
print "#{stats}\n"
2227 1002:f6ede18f3e6e Chris
2228 383:47ae83ce8db8 Chris
<div style="clear: both; float: right"><small><i>Produced by mtree2html by Hartmut Pohlheim</i></small></div>
2229
# configuration file for generation of html-docu from m-files
2230
#
2231
# Author:   Hartmut Pohlheim
2232
# History:  05.11.2000  file created (parameters for mtree2html2001)
2233
#
2234
# The following options/variables must be changed/adapted:
2235
#   dirmfiles
2236
#   dirhtml
2237
#   csslink
2238
#   texttitleframelayout
2239
#   texttitlefiles
2240
#
2241
# The following options/variables should be adapted:
2242
#   authorfile
2243
#   filenametopframe
2244
#   codeheadmeta
2245
2246
#========================================================================
2247
# Variables (possible keywords: set)
2248
# to use the built-in settings, comment the line using # in first column
2249
#========================================================================
2250
2251
#------------------------------------------------------------------------
2252
# dirmfiles: name of directory containing Matlab m-files
2253
# dirhtml: name of directory to place the html-files into
2254
# exthtml: extension used for the html files (.html or .htm)
2255
#          don't forget the point in front of the extension
2256
#------------------------------------------------------------------------
2257
set dirmfiles = .
2258
set dirhtml = doc-output
2259
set exthtml = .html
2260
2261
#------------------------------------------------------------------------
2262
# authorfile:   name of file containing info about author (in html)
2263
#               if defined, this text is included at the bottom of the
2264
#               html files
2265
#------------------------------------------------------------------------
2266 410:675de8e6becf chris
set authorfile = matlab-docs-credit.html
2267 383:47ae83ce8db8 Chris
2268
#------------------------------------------------------------------------
2269
# csslink:   text for linking to css file (style sheets)
2270
#            the text defined here is directly included into the head
2271
#            of the html file
2272
#------------------------------------------------------------------------
2273 410:675de8e6becf chris
#set csslink = <link rel=stylesheet type="text/css" href="CSSFILENAME.css" />
2274 383:47ae83ce8db8 Chris
2275
#------------------------------------------------------------------------
2276
# links2filescase: this is a bit difficult
2277
#                  Matlab is case sensitive on UNIX, but case insensitive
2278
#                  on Windows. Under UNIX Matlab function calls work
2279
#                  only, when the case of file name and function call are
2280
#                  identical, under Windows you can do what you want.
2281
#                  This scripts help you, to keep an exact case in your
2282
#                  project.
2283
#          exact - internal links are only generated, when case of file
2284
#                  name and in source code are identical
2285
#            all - case doesn't matter
2286
#     exactupper - same as exact, additionally links are also vreated to
2287
#                  all upper case function names in source code (often
2288
#                  used by Mathworks)
2289
#      exactvery - same as exact, additionally info about not matching
2290
#                  case is written to screen (stdout), this can be very
2291
#                  helpful in cleaning up the case in a project
2292
#------------------------------------------------------------------------
2293
set links2filescase = all
2294
2295
#------------------------------------------------------------------------
2296
# texttitleframelayout:    text of title for frame layout file (whole docu)
2297
#------------------------------------------------------------------------
2298 389:0bc92382a86b chris
set texttitleframelayout = MATLAB Function Documentation
2299 383:47ae83ce8db8 Chris
2300
#------------------------------------------------------------------------
2301
# texttitle/headerindexalldirs: text of title and header for directory index
2302
#------------------------------------------------------------------------
2303
set texttitleindexalldirs = Index of Directories
2304
set textheaderindexalldirs = Index of Directories
2305
2306
#------------------------------------------------------------------------
2307
# texttitle/headerindex:    text of title and header for index file
2308
#------------------------------------------------------------------------
2309
set texttitleindex = A-Z Index of Functions
2310
set textheaderindex = A-Z Index of Functions
2311
2312
#------------------------------------------------------------------------
2313
# texttitle/headerfiles:    text of title and header for files
2314
#                           name of file will be added at the end
2315
#------------------------------------------------------------------------
2316 389:0bc92382a86b chris
set texttitlefiles = Function
2317 383:47ae83ce8db8 Chris
set textheaderfiles = Documentation of
2318
2319
#------------------------------------------------------------------------
2320
# frames: whether to use frames in layout (yes or no)
2321
#------------------------------------------------------------------------
2322
set frames = no
2323
2324
#------------------------------------------------------------------------
2325
# filenametopframe: name of file including frame layout (highest level file)
2326
# [default: index]
2327
#------------------------------------------------------------------------
2328
set filenametopframe = index
2329
2330
#------------------------------------------------------------------------
2331
# textjumpindexglobal: text displayed for jump to index of all files
2332
#                      (global)
2333
# textjumpindexlocal:  text displayed for jump to index of files in actual
2334
#                      directory (local)
2335
#------------------------------------------------------------------------
2336 389:0bc92382a86b chris
set textjumpindexglobal = <b>Index of</b> all files:
2337
set textjumpindexlocal = this subdirectory only:
2338 383:47ae83ce8db8 Chris
2339
#------------------------------------------------------------------------
2340
# includesource: include source of m-files in documentation [YES|no]
2341
#------------------------------------------------------------------------
2342
set includesource = yes
2343
2344
#------------------------------------------------------------------------
2345
# usecontentsm: use contents.m files as well for structured
2346
#               (hopefully) index [YES|no]
2347
#------------------------------------------------------------------------
2348
set usecontentsm = no
2349
2350
#------------------------------------------------------------------------
2351
# includesource: write/update contents.m files [yes|NO]
2352
#------------------------------------------------------------------------
2353
set writecontentsm = no
2354
2355
#------------------------------------------------------------------------
2356
# processtree:  parse whole directory tree recursively [YES|no]
2357
#------------------------------------------------------------------------
2358
set processtree = yes
2359
2360
#------------------------------------------------------------------------
2361
# producetree:  produce tree for html-files in same structure than
2362
#		          tree of m-files [yes|NO]
2363
#               if no, all files are saved in the same directory, often
2364
#               easier for outside linking to files
2365
#------------------------------------------------------------------------
2366 401:a0f6e994657f chris
set producetree = yes
2367 383:47ae83ce8db8 Chris
2368
#------------------------------------------------------------------------
2369
# codebodyindex/files: HTML-code for adding to BODY tag
2370
#                      can be used for defining colors and
2371
#                      backgroundimages of the files
2372
#                      No longer recommended, use the css file
2373
#------------------------------------------------------------------------
2374
set codebodyindex =
2375
set codebodyfiles =
2376
2377
#------------------------------------------------------------------------
2378
# codeheadmeta: HTML-code added in HEAD area, use for supplying META info
2379
#------------------------------------------------------------------------
2380
set codeheadmeta =
2381
2382
#------------------------------------------------------------------------
2383
# codehr: HTML-code used to define a <HR>, do what you want
2384
#------------------------------------------------------------------------
2385 411:e7ba81c8dc5a chris
set codehr = <hr>
2386 383:47ae83ce8db8 Chris
2387
#------------------------------------------------------------------------
2388
# codeheader: HTML-code added to <H*> tags, use for centering header text
2389
#             or changing the colour/size/font of the header text
2390
#------------------------------------------------------------------------
2391 389:0bc92382a86b chris
set codeheader =
2392 383:47ae83ce8db8 Chris
2393
2394
# End of parameter file
2395 381:2dc8163e9150 Chris
@rem = '--*-Perl-*--';
2396
@rem = '
2397
@echo off
2398
perl -w -S %0.bat %1 %2 %3 %4 %5 %6 %7 %8 %9
2399
goto endofperl
2400
@rem ';
2401
# perl -w -S %0.bat "$@"
2402 382:baff1c482d98 Chris
#!/usr/bin/perl
2403 381:2dc8163e9150 Chris
#
2404
# mtree2html_2000 - produce html files from Matlab m-files.
2405
#                   use configuration file for flexibility
2406
#                   can process tree of directories
2407
#
2408
# Copyright (C) 1996-2000 Hartmut Pohlheim.  All rights reserved.
2409
# includes small parts of m2html from Jeffrey C. Kantor 1995
2410
#
2411
# Author:  Hartmut Pohlheim
2412
# History: 06.03.1996  file created
2413
#          07.03.1996  first working version
2414
#          08.03.1996  modularized, help text only once included
2415
#          11.03.1996  clean up, some functions rwritten
2416
#          18.04.1996  silent output with writing in one line only
2417
#                      version 0.20 fixed
2418
#          14.05.1996  start of adding tree structure, could create tree
2419
#          15.05.1996  creating of index files for every directory
2420
#          17.05.1996  first working version except compact A-Z index
2421
#          20.05.1996  cleanup of actual version, more variables and
2422
#                      configurable settings
2423
#          21.05.1996  reading, update and creation of contents.m added
2424
#          22.05.1996  creation of short index started
2425
#          28.05.1996  jump letters for short index,
2426
#                      3 different directory indexes (short/long/contents)
2427
#          29.05.1996  major cleanup, short and long index created from one function
2428
#                      links for HTML and Indexes from 1 function,
2429
#                      version 0.9
2430
#          30.05.1996  contents.m changed to Contents.m (because unix likes it)
2431
#                      function definition can be in first line of m file before comments
2432
#                      version 0.91 fixed
2433
#          03.06.1996  contents file can be written as wanted, the links will be correct
2434
#                      cross references in help block of m-file will be found and
2435
#                      converted, even if the name of the function is written upper case
2436
#                      version 0.92 fixed
2437
#          05.06.1996  construction of dependency matrix changed, is able now to process
2438
#                      even the whole matlab tree (previous version needed to much memory)
2439
#                      removed warning for contents files in different directories
2440
#                      version 0.94 fixed
2441
#          06.06.1996  new link name matrices for ConstructHTMLFile created,
2442
#                      everything is done in ConstructDependencyMatrix,
2443
#                      both dependencies (calls and called) and matrix
2444
#                      with all mentioned names in this m-file, thus, much
2445
#                      less scanning in html construction
2446
#                      script is now (nearly) linear scalable, thus, matlab-toolbox
2447
#                      tree takes less than 1 hour on a Pentium120, with source
2448
#                      version 0.96 fixed
2449
#          10.06.1996  order of creation changed, first all indexes (includes
2450
#                      update/creation of contents.m) and then ConstructDepency
2451
#                      thus, AutoAdd section will be linked as well
2452
#                      excludenames extended, some more common word function names added
2453
#                      version 0.97 fixed
2454
#          17.02.1998  writecontentsm as command line parameter added
2455
#                      error of file not found will even appear when silent
2456
#                      version 1.02
2457
#          21.05.2000  mark comments in source code specially (no fully correct,
2458
#                      can't handle % in strings)
2459
#                      version 1.11
2460
#          05.11.2000  link also to upper and mixed case m-files
2461
#                      searching for .m files now really works (doesn't find grep.com any longer)
2462
#                      file renamed to mtree2html2001
2463
#                      generated html code now all lower case
2464
#                      inclusion of meta-description and meta-keywords in html files
2465
#                      HTML4 compliance done (should be strict HTML4.0, quite near XHTML)
2466
#                      version 1.23
2467
#
2468 383:47ae83ce8db8 Chris
#	   29.03.2011  (Chris Cannam) add frames option.
2469 381:2dc8163e9150 Chris
2470
$VERSION  = '1.23';
2471
($PROGRAM = $0) =~ s@.*/@@; $PROGRAM = "\U$PROGRAM\E";
2472 411:e7ba81c8dc5a chris
$debug = 1;
2473 381:2dc8163e9150 Chris
2474
#------------------------------------------------------------------------
2475
# Define platform specific things
2476
#------------------------------------------------------------------------
2477
# suffix for files to search is defined twice
2478
# the first ($suffix) is for string creation and contains the . as well
2479
# the second ($suffixforsearch) is for regular expression, handling of . is quite special
2480
$suffix = ".m";
2481
$suffixforsearch = "m";
2482
# the directory separator
2483
$dirsep = "/";
2484
# what is the current directory
2485
$diract = ".";
2486
2487
#------------------------------------------------------------------------
2488 382:baff1c482d98 Chris
#  Define all variables and their standard settings
2489 381:2dc8163e9150 Chris
#  documentation of variables is contained in accompanying rc file
2490
#------------------------------------------------------------------------
2491
%var =
2492
(
2493
   'authorfile',                '',
2494
   'codebodyfiles',             '',
2495
   'codebodyindex',             '',
2496
   'codeheadmeta',              '<meta name="author of conversion perl script" content="Hartmut Pohlheim" />',
2497
   'codehr',                    '<hr size="3" noshade="noshade" />',
2498
   'codeheader',                '',
2499 383:47ae83ce8db8 Chris
   'configfile',                'matlab-docs.conf',
2500 381:2dc8163e9150 Chris
   'csslink',                   '',
2501
   'dirmfiles',                 $diract,
2502
   'dirhtml',                   $diract,
2503
   'exthtml',                   '.html',
2504 382:baff1c482d98 Chris
   'frames',                    'yes',
2505 381:2dc8163e9150 Chris
   'filenametopframe',          'index',
2506
   'filenameindexlongglobal',   'indexlg',
2507
   'filenameindexlonglocal',    'indexll',
2508
   'filenameindexshortglobal',  'indexsg',
2509
   'filenameindexshortlocal',   'indexsl',
2510
   'filenameextensionframe',    'f',
2511
   'filenameextensionindex',    'i',
2512
   'filenameextensionjump',     'j',
2513
   'filenamedirshort',          'dirtops',
2514
   'filenamedirlong',           'dirtopl',
2515
   'filenamedircontents',       'dirtopc',
2516
   'includesource',             'yes',
2517
   'links2filescase',           'all',
2518
   'processtree',               'yes',
2519
   'producetree',               'yes',
2520
   'textjumpindexlocal',        'Local Index',
2521
   'textjumpindexglobal',       'Global Index',
2522
   'texttitleframelayout',      'Documentation of Matlab Files',
2523
   'texttitleindexalldirs',     'Index of Directories',
2524
   'textheaderindexalldirs',    'Index of Directories',
2525
   'texttitleindex',            '',
2526
   'textheaderindex',           '',
2527
   'texttitlefiles',            'Documentation of ',
2528
   'textheaderfiles',           'Documentation of ',
2529
   'usecontentsm',              'yes',
2530
   'writecontentsm',            'no'
2531
);
2532
2533
2534
# define all m-file names, that should be excluded from linking
2535
# however, files will still be converted
2536
@excludenames = ( 'all','ans','any','are',
2537
                  'cs',
2538
                  'demo','dos',
2539
                  'echo','edit','else','elseif','end','exist',
2540
                  'flag','for','function',
2541
                  'global',
2542
                  'help',
2543
                  'i','if','inf','info',
2544
                  'j',
2545
                  'more',
2546
                  'null',
2547
                  'return',
2548
                  'script','strings',
2549
                  'what','which','while','who','whos','why',
2550
                );
2551
2552
# Text for inclusion in created HTML/Frame files: Doctype and Charset
2553
$TextDocTypeHTML  = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN" "http://www.w3.org/TR/REC-html40/strict.dtd">';
2554
$TextDocTypeFrame = '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Frameset//EN" "http://www.w3.org/TR/REC-html40/frameset.dtd">';
2555
$TextMetaCharset = '<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />';
2556
2557
#------------------------------------------------------------------------
2558
# Read the command line arguments
2559
#------------------------------------------------------------------------
2560
if (@ARGV == 0) {
2561
   &DisplayHelp()  if &CheckFileName($var{'configfile'}, 'configuration file');
2562
}
2563
2564
# Print provided command line arguments on screen
2565
foreach (@ARGV) { print "   $_\n      "; }
2566
2567
# Get the options
2568
use Getopt::Long;
2569
@options = ('help|h', 'todo|t', 'version|v',
2570
            'authorfile|a=s', 'configfile|c=s', 'dirhtml|html|d=s',
2571
            'dirmfiles|mfiles|m=s', 'includesource|i=s',
2572
            'processtree|r=s', 'producetree|p=s',
2573
            'silent|quiet|q', 'writecontentsm|w=s');
2574
&GetOptions(@options) || die "use -h switch to display help statement\n";
2575
2576
2577
# Display help or todo list, when requested
2578
&DisplayHelp()                         if $opt_help;
2579
&DisplayTodo()                         if $opt_todo;
2580
die "$PROGRAM v$VERSION\n"             if $opt_version;
2581
2582
$exit_status = 0;
2583
2584
#------------------------------------------------------------------------
2585
# Read the config file
2586
#------------------------------------------------------------------------
2587
$var{'configfile'} = $opt_configfile         if $opt_configfile;
2588
&GetConfigFile($var{'configfile'});
2589
2590
2591
#------------------------------------------------------------------------
2592
# Process/Check the command line otions
2593
#------------------------------------------------------------------------
2594
$var{'dirhtml'}   = $opt_dirhtml              if $opt_dirhtml;
2595
if (!(substr($var{'dirhtml'}, -1, 1) eq $dirsep)) { $var{'dirhtml'} = $var{'dirhtml'}.$dirsep; }
2596
$var{'dirmfiles'} = $opt_dirmfiles            if $opt_dirmfiles;
2597
if (!(substr($var{'dirmfiles'}, -1, 1) eq $dirsep)) { $var{'dirmfiles'} = $var{'dirmfiles'}.$dirsep; }
2598
2599
$var{'authorfile'} = $opt_author              if $opt_author;
2600
$var{'includesource'} = $opt_includesource    if $opt_includesource;
2601
if ($var{'includesource'} ne 'no') { $var{'includesource'} = 'yes'; }
2602
$var{'processtree'} = $opt_processtree        if $opt_processtree;
2603
if ($var{'processtree'} ne 'no') { $var{'processtree'} = 'yes'; }
2604
$var{'producetree'} = $opt_producetree        if $opt_producetree;
2605
if ($var{'producetree'} ne 'no') { $var{'producetree'} = 'yes'; }
2606
if ($var{'processtree'} eq 'no') { $var{'producetree'} = 'no'; }
2607 382:baff1c482d98 Chris
if ($var{'frames'} ne 'no') { $var{'frames'} = 'yes'; }
2608 381:2dc8163e9150 Chris
# if (($var{'processtree'} eq 'yes') && ($var{'producetree'} eq 'no')) { $var{'usecontentsm'} = 'no'; }
2609
2610
$var{'writecontentsm'} = $opt_writecontentsm  if $opt_writecontentsm;
2611
2612
#------------------------------------------------------------------------
2613
# Do the real stuff
2614
#------------------------------------------------------------------------
2615
2616
# Print variables on screen, when not silent
2617
&ListVariables                          if !$opt_silent;
2618
2619
# Check the author file
2620
if ($var{'authorfile'} ne '') {
2621 410:675de8e6becf chris
    if (!($var{'authorfile'} =~ m,^/,)) {
2622
	# relative path: treat as relative to config file
2623
	my $cfd = $var{'configfile'};
2624
	$cfd =~ s,/[^/]*$,/,;
2625
	$cfd =~ s,^[^/]*$,.,;
2626
	$var{'authorfile'} = "$cfd/" . $var{'authorfile'};
2627
    }
2628
    if (&CheckFileName($var{'authorfile'}, 'author file')) {
2629
	$var{'authorfile'} = '';
2630
	if (!$opt_silent) { print "   Proceeding without author information!\n"; }
2631
    }
2632 381:2dc8163e9150 Chris
}
2633
2634
# Call the function doing all the real work
2635
&ConstructNameMatrix;
2636
2637
&ConstructDependencyMatrix;
2638
2639
&ConstructAllIndexFiles;
2640
2641
&ConstructHTMLFiles;
2642
2643
exit $exit_status;
2644
2645
#------------------------------------------------------------------------
2646
# Construct list of all mfile names and initialize various data arrays.
2647
#------------------------------------------------------------------------
2648
sub ConstructNameMatrix
2649
{
2650
   local(*MFILE);
2651
   local($file, $dirname);
2652
   local(@newdirectories);
2653
   local(%localnames);
2654
2655
   $RecDeep = 0;
2656
   &ParseTreeReadFiles($var{'dirmfiles'}, $RecDeep);
2657
2658
   foreach $dirname (@directories) {
2659
      if ($dirnumbermfiles{$dirname} > 0) {
2660
         push(@newdirectories, $dirname);
2661
         if (! defined($contentsname{$dirname})) {
2662
            $contentsname{$dirname} = 'Contents';
2663
            if (($var{'writecontentsm'} eq 'no') && ($var{'usecontentsm'} eq 'yes')) {
2664
               print "\r ParseTree - for directory  $dirname  no contents file found!\n";
2665
               print   "             create one or enable writing of contents file (writecontentsm = yes)!\n";
2666
            }
2667
         }
2668
      }
2669
   }
2670
   @alldirectories = @directories;
2671
   @directories = @newdirectories;
2672
2673
   foreach $dirname (@directories) {
2674
      if ($debug > 0) { print "Dir: $dirname \t\t $dirnumbermfiles{$dirname} \t$contentsname{$dirname}\n"; }
2675
   }
2676
2677
   @names = sort(keys %mfile);
2678
2679
   # check, if name of directory is identical to name of file
2680
   @dirsinglenames = values(%dirnamesingle);
2681
   grep($localnames{$_}++, @dirsinglenames);
2682
   @dirandfilename = grep($localnames{$_}, @names);
2683
   if (@dirandfilename) {
2684
      print "\r   Name clash between directory and file name: @dirandfilename\n";
2685
      print   "      These files will be excluded from linking!\n";
2686
      push(@excludenames, @dirandfilename);
2687
   }
2688
2689
   # construct names matrix for help text linking
2690
   #    exclude some common words (and at the same time m-functions) from linking in help text
2691
   grep($localnames{$_}++, @excludenames);
2692
   @linknames = grep(!$localnames{$_}, @names);
2693
2694
   if ($debug > 2) { print "linknames (names of found m-files):\n    @linknames\n"; }
2695
2696
}
2697
2698
#------------------------------------------------------------------------
2699
# Parse tree and collect all Files
2700
#------------------------------------------------------------------------
2701
sub ParseTreeReadFiles
2702
{
2703
   local($dirname, $localRecDeep) = @_;
2704
   local($file, $name, $filewosuffix);
2705
   local($dirhtmlname, $dirmode);
2706
   local($relpath, $relpathtoindex, $replacevardir);
2707
   local(*CHECKDIR, *AKTDIR);
2708
   local(@ALLEFILES);
2709
2710
   opendir(AKTDIR, $dirname) || die "ParseTree - Can't open directory $dirname: $!";
2711
   if ($debug > 1) { print "\nDirectory: $dirname\n"; }
2712
2713
   # create relative path
2714
   $_ = $dirname; $replacevardir = $var{'dirmfiles'};
2715
   s/$replacevardir//; $relpath = $_;
2716
   s/[^\/]+/../g; $relpathtoindex = $_;
2717
2718
   # producetree no
2719
   if ($var{'producetree'} eq 'no') { $relpath = ''; $relpathtoindex = ''; }
2720
2721
   # names of directories (top-level and below top-level m-file-directory)
2722
   push(@directories, $dirname);
2723
   $dirnumbermfiles{$dirname} = 0;    # set number of m-files for this dir to zero
2724
   # relative path from top-level directory, depends on directory name
2725
   $dirnamerelpath{$dirname} = $relpath;
2726
   # relative path from actual directory to top-level directory, depends on directory name
2727
   $dirnamerelpathtoindex{$dirname} = $relpathtoindex;
2728
   # recursion level for directory, depends on directory name
2729
   $dirnamerecdeep{$dirname} = $localRecDeep;
2730
2731
   # only the name of the directory, without path
2732
   $rindexprint = rindex($dirname, $dirsep, length($dirname)-2);
2733
   $rindsub = substr($dirname, $rindexprint+1, length($dirname)-$rindexprint-2);
2734
   $dirnamesingle{$dirname} = $rindsub;
2735
2736
   # create name of html-directories
2737
   $_ = $dirname;
2738
   s/$var{'dirmfiles'}/$var{'dirhtml'}/;
2739
   $dirhtmlname = $_;
2740
   if ($var{'producetree'} eq 'no') { $dirhtmlname = $var{'dirhtml'}; }
2741
   # try to open html directory, if error, then create directory,
2742
   # use same mode as for corresponding m-file directory
2743
   opendir(CHECKDIR,"$dirhtmlname") || do {
2744
      $dirmode = (stat($dirname))[2]; # print "$dirmode\n";
2745
      mkdir("$dirhtmlname", $dirmode) || die ("Cannot create directory $dirhtmlname: $! !");
2746
   };
2747
   closedir(CHECKDIR);
2748
2749
2750
   # read everything from this directory and process them
2751
   @ALLEFILES = readdir(AKTDIR);
2752
2753
   foreach $file (@ALLEFILES) {
2754
      # exclude . and .. directories
2755
      next if $file eq '.';  next if $file eq '..';
2756
2757
      # test for existense of entry (redundant, used for debugging)
2758
      if (-e $dirname.$file) {
2759
         # if it's a directory, call this function recursively
2760
         if (-d $dirname.$file) {
2761
            if ($var{'processtree'} eq 'yes') {
2762
               &ParseTreeReadFiles($dirname.$file.$dirsep, $localRecDeep+1);
2763
            }
2764
         }
2765
         # if it's a file - test for m-file, save name and create some arrays
2766
         elsif (-f $dirname.$file) {
2767
            if ($file =~ /\.$suffixforsearch$/i) {
2768
               # Remove the file suffix to establish the matlab identifiers
2769
               $filewosuffix = $file;
2770
               $filewosuffix =~ s/\.$suffixforsearch$//i;
2771
               # $filename = $name;
2772
2773
               # Contents file in unix must start with a capital letter (Contents.m)
2774
               # ensure, that m-file name is lower case, except the contents file
2775
               if (! ($filewosuffix =~ /^contents$/i)) {
2776 388:dad587ecb8d0 chris
		   # if ($var{'links2filescase'}  eq 'low') { $filewosuffix = "\L$filewosuffix\E"; }
2777 381:2dc8163e9150 Chris
                  $filewosuffixlow = "\L$filewosuffix\E";
2778
               }
2779
               else { $contentsname{$dirname} = $filewosuffix; }
2780
2781
               # internal handle name is always lower case
2782
               $name     = $filewosuffixlow;
2783
               # file name is not lower case
2784
               $filename = $filewosuffix;
2785
2786
               # if don't use C|contents.m, then forget all C|contents.m
2787
               if ($var{'usecontentsm'} eq 'no') { if ($name =~ /contents/i) { next; } }
2788
2789
               # if m-file with this name already exists, use directory and name for name
2790
               # only the first occurence of name will be used for links
2791
               if (defined $mfile{$name}) {
2792
                  if (! ($name =~ /^contents$/i) ) {
2793
                     print "\r ParseTree - Name conflict:  $name in $dirname already exists: $mfile{$name} !\n";
2794
                     print   "             $mfile{$name}  will be used for links!\n";
2795
                  }
2796
                  $name = $dirname.$name;
2797
               }
2798
               # mfile name with path
2799
               $mfile{$name} = $dirname.$file;
2800
               # mfile name (without path)
2801
               $mfilename{$name} = $filename;
2802
               # mfile directory
2803
               $mfiledir{$name} = $dirname;
2804
2805
               # html file name and full path, special extension of Contents files
2806
               if ($name =~ /contents/i) { $extrahtmlfilename = $dirnamesingle{$dirname}; }
2807
               else { $extrahtmlfilename = ''; }
2808
               $hfile{$name} = $dirhtmlname.$mfilename{$name}.$extrahtmlfilename.$var{'exthtml'};
2809
2810
               # save relative html path
2811
               # if ($var{'producetree'} eq 'yes') {
2812
               $hfilerelpath{$name} = $relpath;
2813
               # } else { # if no tree to produce, relative path is empty
2814
               #    $hfilerelpath{$name} = '';
2815
               # }
2816
2817
               # create relative path from html file to directory with global index file
2818
               $hfileindexpath{$name} = $relpathtoindex;
2819
2820
               # Function declaration, if one exists, set default to script
2821
               $synopsis{$name} = "";
2822
               $mtype{$name} = "script";
2823
2824
               # First comment line
2825
               $apropos{$name} = "";
2826
2827
               # count number of m-files in directories
2828
               $dirnumbermfiles{$dirname}++;
2829
2830
               if ($debug > 1) {
2831
                  if ($opt_silent) { print "\r"; }
2832
                  print "   ParseTree: $name \t\t $mfile{$name} \t\t $hfile{$name}\t\t";
2833
                  if (!$opt_silent) { print "\n"; }
2834
               }
2835
            }
2836
         }
2837
         else {
2838
            print "Unknown type of file in $dirname: $file\n";
2839
         }
2840
      }
2841
      else { print "Error: Not existing file in $dirname: $file\n"; }
2842
   }
2843
2844
   closedir(AKTDIR)
2845
2846
}
2847
2848
#------------------------------------------------------------------------
2849
# Construct Dependency matrix
2850
#    $dep{$x,$y} > 0 if $x includes a reference to $y.
2851
#------------------------------------------------------------------------
2852
sub ConstructDependencyMatrix
2853
{
2854
   &ConstructDependencyMatrixReadFiles('all');
2855
   &ConstructDependencyMatrixReally;
2856
}
2857
2858
2859
#------------------------------------------------------------------------
2860
# Construct Dependency matrix
2861
#    $dep{$x,$y} > 0 if $x includes a reference to $y.
2862
#------------------------------------------------------------------------
2863
sub ConstructDependencyMatrixReadFiles
2864
{
2865
   local($whatstring) = @_;
2866
   local(*MFILE);
2867
   local($name, $inames);
2868
   local(%symbolsdep, %symbolsall);
2869
2870
   # Initialize as all zeros.
2871
   # foreach $name (@names) { grep($dep{$name,$_}=0,@names); if ($debug > 0) { print "\r   DepMatrix anlegen: $name\t$#names\t"; } }
2872
2873
   # Compute the dependency matrix
2874
   $inames = -1;
2875
   foreach $name (@names) {
2876
      # Read each file and tabulate the distinct alphanumeric identifiers in
2877
      # an array of symbols. Also scan for:
2878
      #   synopsis: The function declaration line
2879
      #   apropos:  The first line of the help text
2880
2881
      # look for whatstring, if all: process every file, if contents: process only contents files
2882
      if ($whatstring eq 'contents') { if (! ($name =~ /contents$/i) ) { next; } }
2883
      elsif ($whatstring eq 'all') { }    # do nothing
2884
      else { print "\r   ConstructDependency: Unknown parameter whatstring: $whatstring \n"; }
2885
2886
      undef %symbolsall; undef %symbolsdep;
2887
      open(MFILE,"<$mfile{$name}") || die("Can't open $mfile{$name}: $!\n");
2888
      while (<MFILE>) {
2889
         chop;
2890
2891
         # Split on nonalphanumerics, then look for all words, used for links later
2892
         # this one for all references
2893
         @wordsall = grep(/[a-zA-Z]\w*/, split('\W',$_));
2894
         # set all words to lower case for link checking
2895
         undef @wordsall2;
2896
         # do case conversion not, case checking is done later
2897
         foreach (@wordsall) { push(@wordsall2, "\L$_\E"); }
2898
         # @wordsall2 = @wordsall;
2899
         grep($symbolsall{$_}++, @wordsall2);
2900
2901
         # Store first comment line, skip all others.
2902
         if (/^\s*%/) {
2903
            if (!$apropos{$name}) {
2904
               s/^\s*%\s*//;   # remove % and leading white spaces on line
2905
               $_ = &SubstituteHTMLEntities($_);
2906
               $apropos{$name} = $_;
2907
            }
2908
            next;
2909
         }
2910
2911
         # If it's the function declaration line, then store it and skip
2912
         # but only, when first function definition (multiple function lines when private subfunctions in file
2913
         if ($synopsis{$name} eq '') {
2914
            if (/^\s*function/) {
2915
               s/^\s*function\s*//;
2916
               $synopsis{$name} = $_;
2917
               $mtype{$name} = "function";
2918
               next;
2919
            }
2920
         }
2921
2922
         # Split off any trailing comments
2923
         if ($_ ne '') {
2924
            # this one for references in program code only
2925
            # when syntax parsing, here is a working place
2926
            ($statement) = split('%',$_,1);
2927
            @wordsdep = grep(/[a-zA-Z]\w*/,split('\W',$statement));
2928
            # do case conversion not, case checking is done later
2929
            undef @wordsdep2;
2930
            foreach (@wordsdep) { push(@wordsdep2, "\L$_\E"); }
2931
            grep($symbolsdep{$_}++, @wordsdep2);
2932
         }
2933
      }
2934
      close MFILE;
2935
2936
      # compute intersection between %symbolsall and @linknames
2937
      delete($symbolsall{$name});
2938
      # foreach $localsumall ($symbolsall) {
2939
      #    $localsumall = "\L$localsumall\E";
2940
      # }
2941
      @{'all'.$name} = grep($symbolsall{$_}, @linknames);
2942
2943
      # compute intersection between %symbolsdep and @linknames
2944
      delete($symbolsdep{$name});
2945
      @{'depcalls'.$name} = grep($symbolsdep{$_}, @linknames);
2946
2947
      $inames++; print "\r   DepCallsMatrix: $inames/$#names\t $name\t";
2948
      if ($debug > 2) { print "\n      depnames: @{'depcalls'.$name}\n      all: @{'all'.$name}\n"; }
2949
   }
2950
}
2951
2952
2953
#------------------------------------------------------------------------
2954
# Construct Dependency matrix
2955
#    $dep{$x,$y} > 0 if $x includes a reference to $y.
2956
#------------------------------------------------------------------------
2957
sub ConstructDependencyMatrixReally
2958
{
2959
   local($inames, $name);
2960
2961
   $inames = -1;
2962
   foreach $name (@names) { undef %{'depint'.$name}; }
2963
   foreach $name (@names) {
2964
      grep(${'depint'.$_}{$name}++, @{'depcalls'.$name});
2965
      $inames++; print "\r   DepCalledMatrix1: $inames/$#names\t $name\t";
2966
   }
2967
   $inames = -1;
2968
   foreach $name (@names) {
2969
      # compute intersection between %depint.name{$_} and @linknames
2970
      if (defined (%{'depint'.$name})) { @{'depcalled'.$name} = grep(${'depint'.$name}{$_}, @linknames); }
2971
      $inames++; print "\r   DepCalledMatrix2: $inames/$#names\t $name\t";
2972
      if ($debug > 2) { print "\n      depcalled: @{'depcalled'.$name}\n"; }
2973
   }
2974
2975
}
2976
2977
2978
#========================================================================
2979
# Construct all index files
2980
#========================================================================
2981
sub ConstructAllIndexFiles
2982
{
2983
   local(@localnames);
2984
   local($ActDir);
2985
   local($name);
2986
2987
   # define variables and names for frame target
2988
   $GlobalNameFrameMainLeft = 'Cont_Main';
2989
   $GlobalNameFrameMainRight = 'Cont_Lower';
2990
   $GlobalNameFrameAZIndexsmall = 'IndexAZindex';
2991
   $GlobalNameFrameAZIndexjump = 'IndexAZjump';
2992
2993
   $indexcreated = 0;
2994
2995
   &ConstructHighestIndexFile;
2996
   $indexcreated++;
2997
2998
   # if ($var{'producetree'} eq 'yes') {
2999
      # moved next 2 lines out of if for producetree no
3000
      # &ConstructHighestIndexFile;
3001
      # $indexcreated++;
3002
3003
      foreach $ActDir (@directories) {
3004
         undef @localnames;
3005
         foreach $name (@names) {
3006
            local($pathsubstr) = substr($mfile{$name}, 0, rindex($mfile{$name}, "/")+1);
3007
            if ($ActDir eq $pathsubstr) {
3008
               if ($debug > 1) { print "IndexFile: $pathsubstr    ActDir: $ActDir   Hfilerelpath: $hfilerelpath{$name}\n"; }
3009
               push(@localnames, $name);
3010
            }
3011
         }
3012
         if ($debug > 2) { print "localnames: @localnames\n"; }
3013
         # create contents file and short|long index of files in local directory
3014
         &ConstructContentsmFile($ActDir, @localnames);
3015
         &ConstructAZIndexFile($ActDir, 'short', 'local', @localnames);
3016
         &ConstructAZIndexFile($ActDir, 'long', 'local', @localnames);
3017
         $indexcreated+=2;
3018
      }
3019
   # } else {
3020
   #    &ConstructContentsmFile($var{'dirmfiles'}, @names);
3021
   # }
3022
3023
   # create short|long index of files in all directory
3024
   &ConstructAZIndexFile($var{'dirmfiles'}, 'short', 'global', @names);
3025
   &ConstructAZIndexFile($var{'dirmfiles'}, 'long', 'global', @names);
3026
   $indexcreated+=2;
3027
3028
   # if contents.m were created or updated, the dependency matrices should
3029
   # be updated as well
3030
   if ($var{'writecontentsm'} eq 'yes') { &ConstructDependencyMatrixReadFiles('contents');; }
3031
}
3032
3033
3034
#========================================================================
3035
# Construct the highest level index file
3036
#========================================================================
3037
sub ConstructHighestIndexFile
3038
{
3039
   local(*IFILE);
3040
   local($indexfile, $filename);
3041
3042
   # Build the frame layout file, this files includes the layout of the frames
3043
   # Build the frame layout file name (highest one)
3044
   $indexfile = $var{'dirhtml'}.$var{'filenametopframe'}.$var{'exthtml'};
3045
3046 382:baff1c482d98 Chris
   if ($var{'frames'} eq 'yes') {
3047 381:2dc8163e9150 Chris
3048 382:baff1c482d98 Chris
       open(IFILE,">$indexfile") || die("Cannot open frame layout file $indexfile\n");
3049 381:2dc8163e9150 Chris
3050 382:baff1c482d98 Chris
       # Write the header of frame file
3051
       print IFILE "$TextDocTypeFrame\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n";
3052
       print IFILE "   <title>$var{'texttitleframelayout'}</title>\n";
3053
       print IFILE "</head>\n";
3054 381:2dc8163e9150 Chris
3055 382:baff1c482d98 Chris
       # definition of 2 frames, left the tree of directories,
3056
       # right the index of that directory or the docu of a file
3057
       print IFILE "<frameset  cols=\"25%,75%\">\n";
3058
       print IFILE "   <frame src=\"$var{'filenamedirshort'}$var{'exthtml'}\" name=\"$GlobalNameFrameMainLeft\" />\n";
3059
       print IFILE "   <frame src=\"$var{'filenameindexshortglobal'}$var{'filenameextensionframe'}$var{'exthtml'}\" name=\"$GlobalNameFrameMainRight\" />\n";   print IFILE "</frameset>\n";
3060 381:2dc8163e9150 Chris
3061 382:baff1c482d98 Chris
       print IFILE "</html>\n";
3062
3063
       close(IFILE);
3064
3065
       if ($opt_silent) { print "\r"; }
3066
       print "   Frame layout file created: $indexfile\t";
3067
       if (!$opt_silent) { print "\n"; }
3068
   }
3069 381:2dc8163e9150 Chris
3070
   for($irun=0; $irun <= 2; $irun++) {
3071
      # Build the top directory index file, these files include the directory tree
3072
      # Build the directory tree index file name
3073
3074
      # Create no directory file for contents, when no contents to use
3075
      if (($irun == 2) && ($var{'usecontentsm'} eq 'no')) { next; }
3076
3077
      # Assign the correct index file name
3078
      if ($irun == 0) { $filename = $var{'filenamedirshort'}; }
3079
      elsif ($irun == 1) { $filename = $var{'filenamedirlong'}; }
3080
      elsif ($irun == 2) { $filename = $var{'filenamedircontents'}; }
3081
3082
      $indexfile = $var{'dirhtml'}.$filename.$var{'exthtml'};
3083
3084
      open(IFILE,">$indexfile") || die("Cannot open directory tree index file $indexfile\n");
3085
      # Write header of HTML file
3086
      print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3087
3088
      if ($var{'texttitleindexalldirs'} eq '') {
3089
         print IFILE "<title>Index of Directories of $var{'dirmfiles'}</title>\n";
3090
      } else {
3091
         print IFILE "<title>$var{'texttitleindexalldirs'}</title>\n";
3092
      }
3093 382:baff1c482d98 Chris
3094
      if ($var{'frames'} eq 'yes') {
3095
	  print IFILE "<base target=\"$GlobalNameFrameMainRight\" />\n";
3096
      }
3097
3098 381:2dc8163e9150 Chris
      print IFILE "</head>\n";
3099
      print IFILE "<body $var{'codebodyindex'}>\n";
3100 410:675de8e6becf chris
      print IFILE "<div id=\"matlabdoc\">\n";
3101 381:2dc8163e9150 Chris
      if ($var{'textheaderindexalldirs'} eq '') {
3102
         print IFILE "<h1 $var{'codeheader'}>Index of Directories of <em>$var{'dirmfiles'}</em></h1>\n";
3103
      } else {
3104
         print IFILE "<h1 $var{'codeheader'}>$var{'textheaderindexalldirs'}</h1>\n";
3105
      }
3106 389:0bc92382a86b chris
      print IFILE "<p>\n";
3107 382:baff1c482d98 Chris
3108
      if ($var{'frames'} eq 'yes') {
3109
	  if ($irun == 0) { print IFILE "<strong>short</strong>\n"; }
3110
	  else { print IFILE "<a href=\"$var{'filenamedirshort'}$var{'exthtml'}\" target=\"$GlobalNameFrameMainLeft\">short</a>\n"; }
3111
	  if ($irun == 1) { print IFILE " | <strong>long</strong>\n"; }
3112
	  else { print IFILE " | <a href=\"$var{'filenamedirlong'}$var{'exthtml'}\" target=\"$GlobalNameFrameMainLeft\">long</a>\n"; }
3113
	  if ($var{'usecontentsm'} eq 'yes') {
3114
	      if ($irun == 2) { print IFILE " | <strong>contents</strong>\n"; }
3115
	      else { print IFILE " | <a href=\"$var{'filenamedircontents'}$var{'exthtml'}\" target=\"$GlobalNameFrameMainLeft\">contents</a>\n"; }
3116
	  }
3117
      } else {
3118
	  if ($irun == 0) { print IFILE "<strong>short</strong>\n"; }
3119
	  else { print IFILE "<a href=\"$var{'filenamedirshort'}$var{'exthtml'}\">short</a>\n"; }
3120
	  if ($irun == 1) { print IFILE " | <strong>long</strong>\n"; }
3121
	  else { print IFILE " | <a href=\"$var{'filenamedirlong'}$var{'exthtml'}\">long</a>\n"; }
3122
	  if ($var{'usecontentsm'} eq 'yes') {
3123
	      if ($irun == 2) { print IFILE " | <strong>contents</strong>\n"; }
3124
	      else { print IFILE " | <a href=\"$var{'filenamedircontents'}$var{'exthtml'}\">contents</a>\n"; }
3125
	  }
3126 381:2dc8163e9150 Chris
      }
3127
3128
      print IFILE "</p><br />\n\n";
3129
      print IFILE "<ul>\n";
3130
3131
      # go through all directories and create a list entry for each one,
3132
      # depending on recursion level create sublists
3133
      $prevrecdeeplevel = 0;
3134
      foreach $name (@alldirectories) {
3135
         $actrecdeeplevel = $dirnamerecdeep{$name};
3136
         for( ; $prevrecdeeplevel < $actrecdeeplevel; $prevrecdeeplevel++ ) { print IFILE "<ul>\n"; }
3137
         for( ; $prevrecdeeplevel > $actrecdeeplevel; $prevrecdeeplevel-- ) { print IFILE "</ul>\n"; }
3138
         if ($irun == 0) { $indexfilenameused = $var{'filenameindexshortlocal'}.$var{'filenameextensionframe'}; }
3139
         elsif ($irun == 1) { $indexfilenameused = $var{'filenameindexlonglocal'}.$var{'filenameextensionframe'}; }
3140
         elsif ($irun == 2) { $indexfilenameused = $contentsname{$name}; }
3141
         else { die "ConstructHighestIndexFile: Unknown value of irun"; }
3142
         if ($dirnumbermfiles{$name} > 0) {
3143
            # producetree no
3144
            # if ($var{'producetree'} eq 'no') { $dirnamehere = ''; }
3145
            # else { $dirnamehere = '$dirnamerelpath{$name}'; }
3146
            # print IFILE "<LI><A HREF=\"$dirnamehere$indexfilenameused_$dirnamesingle{$name}$var{'exthtml'}\">$dirnamesingle{$name}</A>\n";
3147
            print IFILE "<li><a href=\"$dirnamerelpath{$name}$indexfilenameused$dirnamesingle{$name}$var{'exthtml'}\">$dirnamesingle{$name}</a></li>\n";
3148
         } else {
3149
            # print directories with no m-files inside not
3150
            # print IFILE "<li>$dirnamesingle{$name}</li>\n";
3151
         }
3152
      }
3153
      $actrecdeeplevel = 0;
3154
      for( ; $prevrecdeeplevel > $actrecdeeplevel; $prevrecdeeplevel-- ) { print IFILE "</ul>\n"; }
3155
      print IFILE "</ul>\n<br />$var{'codehr'}\n";
3156
3157
      # Include info about author from authorfile
3158
      &WriteFile2Handle($var{'authorfile'}, IFILE);
3159
3160
      print IFILE "<!--navigate-->\n";
3161
      print IFILE "<!--copyright-->\n";
3162 410:675de8e6becf chris
      print IFILE "</div>\n</body>\n</html>\n";
3163 381:2dc8163e9150 Chris
3164
      close(IFILE);
3165
3166
      if ($opt_silent) { print "\r"; }
3167
      print "   Directory - Indexfile created: $indexfile\t";
3168
      if (!$opt_silent) { print "\n"; }
3169
   }
3170
}
3171
3172
3173
#========================================================================
3174
# Construct the A-Z index file (global/local and/or short/long)
3175
#========================================================================
3176
sub ConstructAZIndexFile
3177
{
3178
   local($LocalActDir, $LocalShortLong, $LocalGlobalLocal, @localnames) = @_;
3179
   local(*IFILE);
3180
   local($name, $indexfilename, $dirpath);
3181
   local($firstletter, $firstone);
3182
3183
   if ($debug > 2) { print "localnames in AZ small: @localnames\n"; print "     ActDir in A-Z: $LocalActDir\n"; }
3184
3185
   # extract filename of index file from parameters of function
3186
   if ($LocalShortLong eq 'short') {
3187
      if ($LocalGlobalLocal eq 'global') { $indexfilename = $var{'filenameindexshortglobal'}; }
3188
      elsif ($LocalGlobalLocal eq 'local') { $indexfilename = $var{'filenameindexshortlocal'}; }
3189
      else { die "wrong parameter for LocalGlobalLocal in ConstructAZIndexFile: $LocalGlobalLocal."; }
3190
   } elsif ($LocalShortLong eq 'long') {
3191
      if ($LocalGlobalLocal eq 'global') { $indexfilename = $var{'filenameindexlongglobal'}; }
3192
      elsif ($LocalGlobalLocal eq 'local') { $indexfilename = $var{'filenameindexlonglocal'}; }
3193
      else { die "wrong parameter for LocalGlobalLocal in ConstructAZIndexFile: $LocalGlobalLocal."; }
3194
   } else { die "wrong parameter for LocalShortLong in ConstructAZIndexFile: $LocalShortLong."; }
3195
3196
   # producetree no
3197
   # if ($var{'producetree'} eq 'no') { $dirnamehere = ''; }
3198
   # else { $dirnamehere = '$dirnamerelpath{$LocalActDir}'; }
3199
   # Build the index file name
3200
   # handle the global index file case separately (no extra directory name in file)
3201
   #    the local index file name must be extended by the name of the directory
3202
   if ($LocalGlobalLocal eq 'global') { $extradirfilename = ''; }
3203
   else { $extradirfilename = $dirnamesingle{$LocalActDir}; }
3204
   $indexfile = $var{'dirhtml'}.$dirnamerelpath{$LocalActDir}.$indexfilename.$var{'filenameextensionindex'}.$extradirfilename.$var{'exthtml'};
3205 382:baff1c482d98 Chris
3206 401:a0f6e994657f chris
   if ($LocalShortLong eq 'short' and $extradirfilename eq '' and $var{'frames'} ne 'yes') {
3207
       # With no frames and no subdir path, this must go in the
3208
       # top-level index file instead
3209 382:baff1c482d98 Chris
       $indexfile = $var{'dirhtml'}.$var{'filenametopframe'}.$var{'exthtml'};
3210
   }
3211
3212 381:2dc8163e9150 Chris
   if ($debug > 2) { print "   indexfilename (a-z small): $indexfile\n"; }
3213
3214
   open(IFILE,">$indexfile") || die("Cannot open index file $indexfile: $!\n");
3215
3216
   # Write the header of HTML file
3217
   print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3218
3219 410:675de8e6becf chris
   my $dirToPrint = $LocalActDir;
3220
   $dirToPrint =~ s,^./,,;
3221
3222 381:2dc8163e9150 Chris
   if ($var{'texttitleindex'} eq '') {
3223 410:675de8e6becf chris
      print IFILE "<title>Index of Matlab Files in Directory $dirToPrint</title>\n";
3224 381:2dc8163e9150 Chris
   } else {
3225
      if ($LocalGlobalLocal eq 'global') { print IFILE "<title>$var{'texttitleindex'}</title>\n"; }
3226 410:675de8e6becf chris
      else { print IFILE "<title>$var{'texttitleindex'} in Directory $dirToPrint</title>\n"; }
3227 381:2dc8163e9150 Chris
   }
3228 382:baff1c482d98 Chris
3229
   if ($var{'frames'} eq 'yes') {
3230
       print IFILE "<base target=\"$GlobalNameFrameMainRight\" />\n";
3231
   }
3232 381:2dc8163e9150 Chris
   print IFILE "</head>\n";
3233 382:baff1c482d98 Chris
3234 381:2dc8163e9150 Chris
   print IFILE "<body $var{'codebodyindex'}>\n";
3235 410:675de8e6becf chris
   print IFILE "<div id=\"matlabdoc\">\n";
3236 381:2dc8163e9150 Chris
   if ($var{'textheaderindex'} eq '') {
3237 410:675de8e6becf chris
      print IFILE "<h1 $var{'codeheader'}>Index of Matlab Files in Directory $dirToPrint</h1>\n";
3238 381:2dc8163e9150 Chris
   } else {
3239
      if ($LocalGlobalLocal eq 'global') { print IFILE "<h1 $var{'codeheader'}>$var{'textheaderindex'}</h1>\n"; }
3240 410:675de8e6becf chris
      else { print IFILE "<h1 $var{'codeheader'}>$var{'textheaderindex'} in Directory $dirToPrint</h1>\n"; }
3241 381:2dc8163e9150 Chris
   }
3242
3243
   # include links to indexes
3244
   &ConstructLinks2Index(IFILE, $dirnamerelpathtoindex{$LocalActDir}, $LocalActDir, $LocalGlobalLocal);
3245
3246
   # Collect the starting letters of m files in this directory or all m-files
3247
   for('a'..'z') { undef @{$_}; }
3248
   foreach $name (@localnames) {
3249
      if (! ($mfilename{$name} =~ /contents/i)) {
3250
         $firstletter = substr($mfilename{$name}, 0, 1);
3251
         # convert first letter always to lower case
3252
         # needed for reference to lower and upper case m-files
3253
         $firstletter = "\L$firstletter\E";
3254
         push(@{$firstletter}, $name);
3255
      }
3256
   }
3257
3258
   if ($LocalShortLong eq 'short') {
3259
      # begin create short index
3260
      print IFILE "<table width=\"100%\">\n";
3261
3262
      for('a'..'z') {
3263
         # print "   $_: @{$_}\n";
3264
         $numberofletter = $#{$_}+1;
3265 410:675de8e6becf chris
	 $cols = 3;
3266 381:2dc8163e9150 Chris
         if ($numberofletter > 0) {
3267 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";
3268
            for ($count = 0; $count < $numberofletter; $count++) {
3269
		if (($count % $cols) == 0) {
3270
		    if ($count > 0) {
3271
			print IFILE "</tr><tr>\n";
3272
		    }
3273
		    print IFILE "<tr><td></td>";
3274
		}
3275
		$name = @{$_}[$count];
3276
		if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3277
		print IFILE "<td><a href=\"$dirpath$mfilename{$name}$var{'exthtml'}\">$mfilename{$name}</a></td>";
3278
	    }
3279
3280
	    print IFILE "</tr>\n";
3281
3282
            # $numberhalf = ($numberofletter + 1 - (($numberofletter+1) % 2))/2;
3283
            # if ($debug > 2) { print "   $_: @{$_} \t $numberhalf \t $numberofletter\n"; }
3284
            # for($count = 0; $count < $numberhalf; $count++) {
3285
            #    $name = @{$_}[$count];
3286
            #    if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3287
            #    print IFILE "<tr><td width=\"50%\"><a href=\"$dirpath$mfilename{$name}$var{'exthtml'}\">$mfilename{$name}</a></td>";
3288
            #    if (($count + $numberhalf) < $numberofletter) {
3289
            #       $name = @{$_}[$count + $numberhalf];
3290
            #       if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3291
            #       print IFILE "<td width=\"50%\"><a href=\"$dirpath$mfilename{$name}$var{'exthtml'}\">$mfilename{$name}</a></td></tr>\n";
3292
            #    } else {
3293
            #       print IFILE "<td width=\"50%\"></td></tr>\n";
3294
            #    }
3295
            # }
3296 381:2dc8163e9150 Chris
         }
3297
      }
3298
      print IFILE "</table>\n<br />$var{'codehr'}\n";
3299
3300
   } elsif ($LocalShortLong eq 'long') {
3301
      # begin create long index
3302 410:675de8e6becf chris
      print IFILE "<table width=\"100%\">\n";
3303 401:a0f6e994657f chris
      print IFILE "<tr><th>Name</th><th>Synopsis</th></tr>\n";
3304 381:2dc8163e9150 Chris
3305
      for('a'..'z') {
3306
         # print "   $_: @{$_}\n";
3307
         $numberofletter = $#{$_}+1;
3308
         if ($numberofletter > 0) {
3309
            $firstone = 1;
3310
            foreach $name (@{$_}) {
3311
               if ($debug > 1) { print "   AZinforeach1: $name \t\t $hfilerelpath{$name} \t\t $dirnamerelpath{$LocalActDir}\n"; }
3312
               if ($LocalGlobalLocal eq 'global') { $dirpath = $hfilerelpath{$name}; } else { $dirpath = ""; }
3313
               if (! ($mfilename{$name} =~ /contents/i)) {
3314 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; }
3315 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";
3316
               }
3317
            }
3318
         }
3319
      }
3320
      print IFILE "</table>\n<br />$var{'codehr'}\n";
3321
   } else { die "wrong parameter for LocalShortLong in ConstructAZIndexFile: $LocalShortLong."; }
3322
3323
   # Include info about author from authorfile
3324
   &WriteFile2Handle($var{'authorfile'}, IFILE);
3325
3326
   print IFILE "<!--navigate-->\n";
3327
   print IFILE "<!--copyright-->\n";
3328 410:675de8e6becf chris
   print IFILE "</div>\n</body>\n</html>\n";
3329 381:2dc8163e9150 Chris
3330
   close(IFILE);
3331
3332
   if ($opt_silent) { print "\r"; }
3333
   print "   Indexfile small (A-Z) created: $indexfile\t";
3334
   if (!$opt_silent) { print "\n"; }
3335
3336
3337
   # Build the A-Z jump index file name
3338
   # handle the global index file case separately (no extra directory name in file)
3339
   if ($LocalGlobalLocal eq 'global') { $extradirfilename = ''; }
3340
   else { $extradirfilename = $dirnamesingle{$LocalActDir}; }
3341
3342 382:baff1c482d98 Chris
   if ($var{'frames'} eq 'yes') {
3343
3344
       $indexfile = $var{'dirhtml'}.$dirnamerelpath{$LocalActDir}.$indexfilename.$var{'filenameextensionjump'}.$extradirfilename.$var{'exthtml'};
3345
       if ($debug > 2) { print "   indexfilename (a-z jump): $indexfile\n"; }
3346
       open(IFILE,">$indexfile") || die("Cannot open jump index file $indexfile: $!\n");
3347
3348
       # Write the header of HTML file
3349
       print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3350
3351
       if ($var{'texttitleindex'} eq '') {
3352 410:675de8e6becf chris
	   print IFILE "<title>A-Z jump index in directory $dirToPrint</title>\n";
3353 382:baff1c482d98 Chris
       } else {
3354
	   if ($LocalGlobalLocal eq 'global') { print IFILE "<title>$var{'texttitleindex'}</title>\n"; }
3355 410:675de8e6becf chris
	   else { print IFILE "<title>$var{'texttitleindex'} in Directory $dirToPrint</title>\n"; }
3356 382:baff1c482d98 Chris
       }
3357
3358
       if ($var{'frames'} eq 'yes') {
3359
	   print IFILE "<base target=\"$GlobalNameFrameAZIndexsmall\" />\n";
3360
       }
3361
       print IFILE "</head>\n";
3362
       print IFILE "<body $var{'codebodyindex'}>\n";
3363 410:675de8e6becf chris
       print IFILE "<div id=\"matlabdoc\">\n";
3364 382:baff1c482d98 Chris
3365
       # Write the A-Z jump line, generate link for letters with files starting with this letter
3366
       # and only letters for no files starting with this letter
3367
       # use previously generated arrays with names of files sorted by starting letter
3368
       for('a'..'z') {
3369
	   $numberofletter = $#{$_}+1;
3370
	   if ($numberofletter > 0) {
3371
	       print IFILE "<strong><a href=\"$indexfilename$var{'filenameextensionindex'}$extradirfilename$var{'exthtml'}#\U$_\E$_\">\U$_\E</a> </strong>\n";
3372
	   } else {
3373
	       print IFILE "\U$_\E \n";
3374
	   }
3375
       }
3376
3377 410:675de8e6becf chris
       print IFILE "</div></body>\n</html>\n";
3378 382:baff1c482d98 Chris
3379
       close(IFILE);
3380
3381
       if ($opt_silent) { print "\r"; }
3382
       print "   Indexfile small (A-Z jump) created: $indexfile\t";
3383
       if (!$opt_silent) { print "\n"; }
3384 381:2dc8163e9150 Chris
   }
3385
3386
3387
   # Build the frame layout file, this file includes the layout of the frames
3388
   # Build the frame layout file name (for small/compact A-Z index)
3389
   # handle the global index file case separately (no extra directory name in file)
3390
   if ($LocalGlobalLocal eq 'global') { $extradirfilename = ''; }
3391
   else { $extradirfilename = $dirnamesingle{$LocalActDir}; }
3392
3393 382:baff1c482d98 Chris
   if ($var{'frames'} eq 'yes') {
3394 381:2dc8163e9150 Chris
3395 382:baff1c482d98 Chris
       $indexfile = $var{'dirhtml'}.$dirnamerelpath{$LocalActDir}.$indexfilename.$var{'filenameextensionframe'}.$extradirfilename.$var{'exthtml'};
3396
       if ($debug > 2) { print "   indexfilename (a-z frame): $indexfile\n"; }
3397 381:2dc8163e9150 Chris
3398 382:baff1c482d98 Chris
       open(IFILE,">$indexfile") || die("Cannot open jump index frame file $indexfile: $!\n");
3399
3400
       # Write the header of Frame file
3401
       print IFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3402
3403
       if ($var{'texttitleindex'} eq '') {
3404 410:675de8e6becf chris
	   print IFILE "<title>Index of Matlab Files in Directory $dirToPrint</title>\n";
3405 382:baff1c482d98 Chris
       } else {
3406
	   if ($LocalGlobalLocal eq 'global') { print IFILE "<title>$var{'texttitleindex'}</title>\n"; }
3407 410:675de8e6becf chris
	   else { print IFILE "<title>$var{'texttitleindex'} in Directory $dirToPrint</title>\n"; }
3408 382:baff1c482d98 Chris
       }
3409
       print IFILE "</head>\n";
3410
3411
       # definition of 2 frames, top the A-Z index, below the jump letter line
3412
       print IFILE "<frameset  rows=\"90%,10%\">\n";
3413
       print IFILE "   <frame src=\"$indexfilename$var{'filenameextensionindex'}$extradirfilename$var{'exthtml'}\" name=\"$GlobalNameFrameAZIndexsmall\" />\n";
3414
       print IFILE "   <frame src=\"$indexfilename$var{'filenameextensionjump'}$extradirfilename$var{'exthtml'}\" name=\"$GlobalNameFrameAZIndexjump\" />\n";
3415
       print IFILE "</frameset>\n";
3416
3417
       print IFILE "</html>\n";
3418
3419
       close(IFILE);
3420
3421
       if ($opt_silent) { print "\r"; }
3422
       print "   Frame layout file created: $indexfile\t";
3423
       if (!$opt_silent) { print "\n"; }
3424 381:2dc8163e9150 Chris
   }
3425
}
3426 382:baff1c482d98 Chris
3427 381:2dc8163e9150 Chris
3428
#========================================================================
3429
# Construct the links to all indexes
3430
#========================================================================
3431
sub ConstructLinks2Index
3432
{
3433
   local(*WRITEFILE, $LocalPath2Index, $PathContents, $LocalGlobalLocal) = @_;
3434
3435
   # include links to short/long - local/global index and C|contents.m
3436 389:0bc92382a86b chris
   print WRITEFILE "\n<p>";
3437
   print WRITEFILE "$var{'textjumpindexglobal'} ";
3438 382:baff1c482d98 Chris
3439
   if ($var{'frames'} eq 'yes') {
3440
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenameindexshortglobal'}$var{'filenameextensionframe'}$var{'exthtml'}\">short</a> | ";
3441 389:0bc92382a86b chris
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenameindexlongglobal'}$var{'filenameextensionframe'}$var{'exthtml'}\">long</a>\n";
3442 382:baff1c482d98 Chris
   } else {
3443 387:f89765996ef9 Chris
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenametopframe'}$var{'exthtml'}\">short</a> | ";
3444 389:0bc92382a86b chris
       print WRITEFILE "<a href=\"$LocalPath2Index$var{'filenameindexlongglobal'}$var{'filenameextensionindex'}$var{'exthtml'}\">long</a>\n";
3445 382:baff1c482d98 Chris
   }
3446
3447 381:2dc8163e9150 Chris
   if ($LocalGlobalLocal eq 'local') {
3448
      if ($var{'usecontentsm'} eq 'yes') {
3449
         print WRITEFILE " | <a href=\"$contentsname{$PathContents}$dirnamesingle{$PathContents}$var{'exthtml'}\">Local contents</a>\n";
3450
      }
3451 389:0bc92382a86b chris
      if ($var{'frames'} eq 'yes') {
3452
         print WRITEFILE " | $var{'textjumpindexlocal'} ";
3453 382:baff1c482d98 Chris
         print WRITEFILE "<a href=\"$var{'filenameindexshortlocal'}$var{'filenameextensionframe'}$dirnamesingle{$PathContents}$var{'exthtml'}\">short</a> | ";
3454 389:0bc92382a86b chris
         print WRITEFILE "<a href=\"$var{'filenameindexlonglocal'}$var{'filenameextensionframe'}$dirnamesingle{$PathContents}$var{'exthtml'}\">long</a>\n";
3455
      } else {
3456
         print WRITEFILE " | $var{'textjumpindexlocal'} ";
3457
         print WRITEFILE "<a href=\"$var{'filenameindexshortlocal'}$var{'filenameextensionindex'}$dirnamesingle{$PathContents}$var{'exthtml'}\">short</a> | ";
3458
         print WRITEFILE "<a href=\"$var{'filenameindexlonglocal'}$var{'filenameextensionindex'}$dirnamesingle{$PathContents}$var{'exthtml'}\">long</a>\n";
3459
      }
3460 381:2dc8163e9150 Chris
   }
3461
   print WRITEFILE "</p>\n\n";
3462
   print WRITEFILE "$var{'codehr'}\n";
3463
}
3464
3465
3466
#========================================================================
3467
# Construct the contents.m files or update
3468
#========================================================================
3469
sub ConstructContentsmFile
3470
{
3471
   local($LocalActDir, @localnames) = @_;
3472
   local(*CFILE, $name,$newline);
3473
   local($contentsfile, $isincontentsonly);
3474
   local(@lines, @autoaddlines, @emptylines);
3475
   local($autoadd) = 'AutoAdd';
3476
   local($autoaddsection) = 0;
3477
   local($emptylineflag) = 0;
3478
   local(%nameincontents);
3479
3480
   # Build the contents file name
3481
   $contentsfile = $LocalActDir.$contentsname{$LocalActDir}.$suffix;
3482
3483
   if (-e $contentsfile) {
3484
      open(CFILE,"<$contentsfile") || die("Cannot open contents file $contentsfile: $!\n");
3485
      while (<CFILE>) {
3486
         # Search for the specified string pattern
3487
         @words = split;
3488
         if ((@words >= 3) && ($words[2] eq '-')) {
3489
            $isincontentsonly = 0;
3490
            foreach $name (@localnames) {
3491
               if ($name eq $words[1]) {    # old
3492
               # if ($mfilename{$name} eq $words[1]) {
3493
                  $isincontentsonly = 1;
3494
                  $nameincontents{$name} = 1;
3495
                  $newline = sprintf("%% %-13s - %s\n", $mfilename{$name}, $apropos{$name});
3496
                  push(@lines, $newline);
3497
               }
3498
            }
3499
            # issue a warning, if file is in contents, but not as file in the directory
3500
            if ($isincontentsonly == 0) {
3501
               print "\rConstructContents: Obsolete entry  $words[1]  in  $contentsfile ! Entry not used.\n";
3502
            }
3503
         } else {
3504
            # look for the AutoAdd section, should be the second word
3505
            if ((@words >= 2) && ($words[1] eq $autoadd)) { $autoaddsection = 1; }
3506
            # push the red line in an array
3507
            push(@lines, $_);
3508
         }
3509
      }
3510
      close(CFILE);
3511
   } else {
3512
      $newline = "% MATLAB Files in directory  $LocalActDir\n%\n";
3513
      push(@lines, $newline);
3514
3515
   }
3516
3517
   # collect the file names, that were not included in original C|contents.m
3518
   foreach $name (@localnames) {
3519
      if (! defined $nameincontents{$name}) {
3520
         if (! ($mfilename{$name} =~ /contents/i)) {
3521
            $newline = sprintf("%% %-13s - %s\n", $mfilename{$name}, $apropos{$name});
3522
            push(@autoaddlines, $newline);
3523
         }
3524
      }
3525
   }
3526
3527
   # write/update C|contents.m only if variable is set
3528
   if ($var{'writecontentsm'} eq 'yes') {
3529
      unlink($contentsfile);
3530
      open(CFILE,">$contentsfile") || die("Cannot open contents file $contentsfile: $!\n");
3531
      # write old C|contents.m or header of new file, as long as comment lines
3532
      foreach $line (@lines) {
3533
         if ($emptylineflag == 0) {
3534
            if ($line =~ /^\s*%/) { print CFILE $line; }
3535
            else { $emptylineflag = 1; push(@emptylines, $line); }
3536
         } else { push(@emptylines, $line); }
3537
      }
3538
      # add header of AutoAdd section
3539
      if (($autoaddsection == 0) && (@autoaddlines > 0)) { print CFILE "%\n% $autoadd\n"; }
3540
      # add autoadd section lines (previously undocumented files
3541
      foreach $line (@autoaddlines) { print CFILE $line; }
3542
      # add tail of original C|contents.m (everything behind first non-comment line)
3543
      foreach $line (@emptylines)   { print CFILE $line; }
3544
      print CFILE "\n";
3545
      close CFILE;
3546
      if ($opt_silent) { print "\r"; }
3547
      print "   Contents file created/updated: $contentsfile\t";
3548
      if (!$opt_silent) { print "\n"; }
3549
   }
3550
}
3551
3552
3553
#========================================================================
3554
# Replace found special characters with their HTMl Entities
3555
#========================================================================
3556
sub SubstituteHTMLEntities {
3557
   local($_) = @_;
3558
3559
   # Replace & <-> &amp;  < <-> &lt;  > <-> &gt;  " <-> &quot;
3560
   s/&/&amp;/g; s/\</&lt;/g; s/\>/&gt;/g; s/\"/&quot;/g;
3561
   return $_;
3562
}
3563
3564
#========================================================================
3565
# Replace found m-filenamestring with full link.
3566
#========================================================================
3567
sub SubstituteName2Link {
3568
   local($_, $funname) = @_;
3569
   local($refstr1, $refstr2, $reffound);
3570
3571
   # Look for something matching in the line
3572
   if ( /(\W+)($funname)(\W+)/i ) {
3573
      $reffound = $2;
3574 388:dad587ecb8d0 chris
      $refstr1 = "<a class=\"mfun\" href=\"$hfileindexpath{$name}$hfilerelpath{$funname}$mfilename{$funname}$var{'exthtml'}\">";
3575 381:2dc8163e9150 Chris
      $refstr2 = "<\/a>";
3576
      # Do links only for exact case match
3577
      if ( ($var{'links2filescase'}  eq 'exact') || ($var{'links2filescase'}  eq 'exactvery') ) {
3578
         if ( /(\W+)($funname)(\W+)/g ) {
3579
            s/(\W+)($funname)(\W+)/$1$refstr1$funname$refstr2$3/g;
3580
         }
3581
         else {
3582
            # Print info for not matching case in references, good for check up of files
3583
            if ( ($var{'links2filescase'}  eq 'exactvery') ) {
3584
               print "Diff in case found: $funname  (case of file name)   <->  $reffound  (case in source code)\n";
3585
               print "     (source line)  $_ \n";
3586
            }
3587
         }
3588
      }
3589
      # Do links for exact match and additionally for all upper case (often used in original matlab help text)
3590
      elsif ( ($var{'links2filescase'}  eq 'exactupper') ) {
3591
         s/(\W+)($funname)(\W+)/$1$refstr1$2$refstr2$3/g;
3592
         $funname2 = "\U$funname\E";
3593
         s/(\W+)($funname2)(\W+)/$1$refstr1$2$refstr2$3/g;
3594
      }
3595
      # Do links for all case mixes, this calls for trouble under LINUX/UNIX
3596
      else {  #elsif ( ($var{'links2filescase'}  eq 'all') )
3597
         s/(\W+)($funname)(\W+)/$1$refstr1$2$refstr2$3/ig;
3598
      }
3599
   }
3600
3601
   return $_;
3602
}
3603
3604
#========================================================================
3605
# Construct the html files for each matlab file.
3606
#    Need to reread each matlab file to find the help text.
3607
#    Note that we can't do this in a single loop because sometimes
3608
#    the help text maybe before the function declaration.
3609
#========================================================================
3610
sub ConstructHTMLFiles
3611
{
3612
   local(*MFILE);
3613
   local(*HFILE);
3614
3615
   local($filescreated) = 0;
3616
   local($functionline);
3617
3618
   foreach $name (@names) {
3619
      # Create cross reference information already here, used for keywords as well
3620
      # Construct list of referenced functions
3621
      @xref = @{'depcalls'.$name};    # the functions, that this m-file calls
3622
      @yref = @{'depcalled'.$name};   # the functions, that this m-file is called from
3623
      # print "   depcalls: @{'depcalls'.$name}\n   depcalled: @{'depcalled'.$name}\n";
3624
      # foreach $cname (@names) { next if $cname eq $name; push(@yref,$cname) if grep(/$name/,@{'depcalls'.$cname}); }
3625
3626
3627
      # Open m-file and html-file
3628
      open(MFILE,"<$mfile{$name}");
3629
      open(HFILE,">$hfile{$name}");
3630
3631
      # Write the header of HTML file
3632
      print HFILE "$TextDocTypeHTML\n<html>\n<head>\n$var{'codeheadmeta'}\n$TextMetaCharset\n$var{'csslink'}\n";
3633
3634
      # Write meta tags: use apropos (one line function description) for description
3635
      # and cross reference function names for keywords (any better ideas?)
3636
      print HFILE "<meta name=\"description\" content=\" $apropos{$name} \" />\n";
3637
      print HFILE "<meta name=\"keywords\" content=\" @xref @yref \" />\n";
3638
3639
      # Write Title and start body of html-file
3640
      print HFILE "<title>$var{'texttitlefiles'} $mfilename{$name}</title>\n</head>\n";
3641
      print HFILE "<body $var{'codebodyfiles'}>\n";
3642 410:675de8e6becf chris
      print HFILE "<div id=\"matlabdoc\">\n";
3643 381:2dc8163e9150 Chris
      print HFILE "<h1 $var{'codeheader'}>$var{'textheaderfiles'} $mfilename{$name}</h1>\n";
3644 401:a0f6e994657f chris
3645
# http://test.soundsoftware.ac.uk/cannam/projects/smallbox/repository/annotate/DL/RLS-DLA/SolveFISTA.m
3646 410:675de8e6becf chris
#      print HFILE "<a href=\"" . $hfileindexpath{$name} . "../../projects/smallbox/repository/annotate/" . $mfiledir{$name}  . $mfilename{$name} . ".m\">View in repository</a>\n";
3647 401:a0f6e994657f chris
3648 381:2dc8163e9150 Chris
      print HFILE "$var{'codehr'}\n";
3649
3650
      # include links to short/long - local/global index and C|contents.m
3651
      &ConstructLinks2Index(HFILE, $hfileindexpath{$name}, $mfiledir{$name}, 'local');
3652
3653
      # If this is a function, then write out the first line as a synopsis
3654
      if ($mtype{$name} eq "function") {
3655
         print HFILE "<h2 $var{'codeheader'}>Function Synopsis</h2>\n";
3656
         print HFILE "<pre>$synopsis{$name}</pre>\n$var{'codehr'}\n";
3657
      }
3658
3659
      # Look for the matlab help text block
3660
      $functionline = "\n";
3661
      do {
3662
         $_ = <MFILE>;
3663
         # remember functionline, if before help text block
3664
         if (/^\s*function/) { $functionline = $_; }
3665
      } until (/^\s*%/ || eof);
3666
      if (! (eof(MFILE))) {
3667
         print HFILE "<h2 $var{'codeheader'}>Help text</h2>\n";
3668
         print HFILE "<pre>\n";
3669
         while (/^\s*%/) {
3670
            # First remove leading % and white space, then Substitute special characlers
3671
            s/^\s*%//;
3672
            $_ = &SubstituteHTMLEntities($_);
3673
3674
            # check/create cross references
3675
            foreach $funname (@{'all'.$name}) {
3676
               if ($funname =~ /simulink/) { print "\n Simulink - Filename: $name;  scanname: $funname\n"; }
3677
               next if $funname eq $name;
3678
               $_ = &SubstituteName2Link($_, $funname);
3679
            }
3680
            print HFILE $_;
3681
            if (! eof) { $_ = <MFILE>; }
3682
         }
3683
         print HFILE "</pre>\n$var{'codehr'}\n";
3684
      }
3685
3686
      # Write the cross reference information
3687
      if (@xref || @yref) {
3688
         print HFILE "<h2 $var{'codeheader'}>Cross-Reference Information</H2>\n";
3689
         print HFILE "<table border=\"0\" width=\"100%\">\n<tr align=\"left\">\n<th width=\"50%\">";
3690
         if (@xref) {
3691
            print HFILE "This $mtype{$name} calls";
3692
         }
3693
         print HFILE "</th>\n<th width=\"50%\">";
3694
         if (@yref) {
3695
            print HFILE "This $mtype{$name} is called by";
3696
         }
3697
         print HFILE "</th>\n</tr>\n<tr valign=\"top\"><td>";
3698
         if (@xref) {
3699
            print HFILE "\n<ul>\n";
3700
            foreach $cname (sort @xref) {
3701
               print HFILE "<li><a class=\"mfun\" href=\"$hfileindexpath{$name}$hfilerelpath{$cname}$mfilename{$cname}$var{'exthtml'}\">$mfilename{$cname}</a></li>\n";
3702
            }
3703
            print HFILE "</ul>\n";
3704
         }
3705
         print HFILE "</td><td>";
3706
         if (@yref) {
3707
            print HFILE "\n<ul>\n";
3708
            foreach $cname (sort @yref) {
3709
               print HFILE "<li><a class=\"mfun\" href=\"$hfileindexpath{$name}$hfilerelpath{$cname}$mfilename{$cname}$var{'exthtml'}\">$mfilename{$cname}</a></li>\n";
3710
            }
3711
            print HFILE "</ul>\n";
3712
         }
3713
         print HFILE "</td>\n</tr>\n</table>\n";
3714
         print HFILE "$var{'codehr'}\n";
3715
      }
3716
3717
      # Include source text if requested
3718
      if (($var{'includesource'} eq 'yes') && (! ($mfilename{$name} =~ /^contents$/i))) {
3719
         print HFILE "<h2 $var{'codeheader'}>Listing of $mtype{$name} $mfilename{$name}</h2>\n";
3720
         seek(MFILE,0,0);
3721
         print HFILE "<pre>\n";
3722
         $IsStillHelp = 2;
3723
         print HFILE $functionline;    # functionline from scanning of help
3724
         while (<MFILE>) {
3725
            if ($IsStillHelp == 2) {
3726
               next     if (/^\s*$/);
3727
               next     if (/^\s*function/);
3728
               if (/^\s*%/) { $IsStillHelp = 1; next; }
3729
            } elsif ($IsStillHelp == 1) {
3730
               next     if (/^\s*%/);
3731
               $IsStillHelp = 0;
3732
            }
3733
3734
            # Substritute special characters
3735
            $_ = &SubstituteHTMLEntities($_);
3736
3737
            # check for comment in line and format with css em
3738 400:4ad6499d7998 chris
            s/^(.*)%(.*?)([\s\r\n]+)$/$1<em class=\"mcom\">%$2<\/em>$3/;
3739 381:2dc8163e9150 Chris
3740
            # check/create cross references
3741
            foreach $funname (@{'all'.$name}) {
3742
               next if $funname eq $name;
3743
               $_ = &SubstituteName2Link($_, $funname);
3744
            }
3745
            print HFILE $_;
3746
         }
3747
         print HFILE "</pre>\n$var{'codehr'}\n";
3748
      }
3749
3750
      # Include info about author from authorfile
3751
      &WriteFile2Handle($var{'authorfile'}, HFILE)   ;
3752
3753
      print HFILE "<!--navigate-->\n";
3754
      print HFILE "<!--copyright-->\n";
3755 410:675de8e6becf chris
      print HFILE "</div>\n</body>\n</html>\n";
3756 381:2dc8163e9150 Chris
      close(MFILE);
3757
      close(HFILE);
3758
3759
      # Print name of finished file
3760
      if ($opt_silent) { print "\r"; }
3761
      print "   HTML-File created: $hfile{$name}\t";
3762
      if (!$opt_silent) { print "\n"; }
3763
      $filescreated++;
3764
   }
3765
3766
   print "\n$PROGRAM: $indexcreated index and $filescreated files created.\n";
3767
}
3768
3769
#========================================================================
3770
# Function:	CheckFileName
3771
# Purpose:	.
3772
#========================================================================
3773
sub CheckFileName {
3774
   local($filename, $description) = @_;
3775
   local(*CHECKFILE);
3776
3777
   open(CHECKFILE,"<$filename") || do {
3778
      if ($description eq '') {$description = 'file';}
3779
      # if (!$opt_silent) { print "Cannot open $description $filename: $!\n"; }
3780
      print "Cannot open $description $filename: $!\n";
3781
      return 1;
3782
   };
3783
   close(CHECKFILE);
3784
   return 0;
3785
3786
}
3787
3788
#========================================================================
3789
# Function:	CheckDirName
3790
# Purpose:	.
3791
#========================================================================
3792
sub CheckDirName {
3793
   local($dirname, $description) = @_;
3794
   local(*CHECKDIR);
3795
3796
   opendir(CHECKDIR,"$dirname") || die ("Cannot open $description directory $dirname: $!\n");
3797
   closedir(CHECKDIR);
3798
}
3799
3800
#========================================================================
3801
# Function:	WriteFile2Handle
3802
# Purpose:	.
3803
#========================================================================
3804
sub WriteFile2Handle {
3805
   local($filename, *WRITEFILE) = @_;
3806
   local(*READFILE);
3807
3808
   if ($filename ne '') {
3809
      open(READFILE,"<$filename");
3810
      @filecontents = <READFILE>;
3811
      close(READFILE);
3812
      print WRITEFILE "@filecontents\n";
3813
      # if (!$opt_silent) {print "      Contents of $filename added\n"};
3814
   }
3815
}
3816
3817
3818
#========================================================================
3819
# Function:	GetConfigFile
3820
# Purpose:	Read user's configuration file, if such exists.
3821
#========================================================================
3822
sub GetConfigFile
3823
{
3824
   local($filename) = @_;
3825
   local(*CONFIG);
3826
   local($value);
3827
3828
   if (&CheckFileName($filename, 'configuration file')) {
3829
      # if (!$opt_silent) { print "   Proceeding using built-in defaults for configuration.\n"; }
3830
      print "   Proceeding using built-in defaults for configuration.\n";
3831
      return 0;
3832
   };
3833
3834
   open(CONFIG,"< $filename");
3835
   while (<CONFIG>) {
3836
      s/#.*$//;
3837
      next if /^\s*$/o;
3838
3839
      # match keyword: process one or more arguments
3840
      # keyword set
3841
      if (/^\s*set\s+(\S+)\s*=\s*(.*)/) {
3842
         # setting a configuration variable
3843
         if (defined $var{$1}) {
3844
            $var{$1} = $2;
3845
            if ($debug > 3) { print "$1:   $var{$1}\n"; }
3846
         }
3847
         else {
3848
            print "$PROGRAM: unknown variable `$1' in configuration file\n"
3849
         }
3850
      } else {
3851
         chop($_);
3852
         print "$PROGRAM: unknown keyword in configuration file in line: `$_'\n"
3853
      }
3854
   }
3855
   close CONFIG;
3856
   1;
3857
}
3858
3859
3860
#------------------------------------------------------------------------
3861
# DisplayHelp - display help text using -h or -help command-line switch
3862
#------------------------------------------------------------------------
3863
sub DisplayHelp
3864
{
3865
   $help=<<EofHelp;
3866
   $PROGRAM v$VERSION - generate html documentation from Matlab m-files
3867
3868
   Usage: $PROGRAM [-h] [-c config_file] [-m|dirmfiles matlab_dir] [-d|dirhtml html_dir]
3869
                   [-i yes|no] [-r yes|no] [-p yes|no] [-quiet|q] [-a authorfile]
3870
3871
   $PROGRAM is a perl script that reads each matlab .m file in a directory
3872
   to produce a corresponding .html file of help documentation and cross
3873
   reference information. An index file is written with links to all of
3874
   the html files produced. The options are:
3875
3876
      -quiet         or -q : be silent, no status information during generation
3877
      -help          or -h : display this help message
3878
      -todo          or -t : print the todo list for $PROGRAM
3879
      -version       or -v : display version
3880
3881
      -configfile    or -c : name of configuration file (default to $var{'configfile'}).
3882
      -dirmfiles     or -m : top level directory containing matlab files to generate html for;
3883
                             default to actual directory.
3884
      -dirhtml       or -d : top level directory for generated html files;
3885
                             default to actual directory.
3886
3887
      -includesource or -i : Include matlab source in the html documentation [yes|no]
3888
                             default to yes.
3889
      -processtree   or -r : create docu for m-file directory and all subdirectories [yes|no];
3890
                             default to yes.
3891
      -producetree   or -p : create multi-level docu identical to directory structure
3892
                             of m-files [yes|no]; default to yes.
3893
      -writecontentsm or -w: update or write contents.m files into the matlab source
3894
                             directories [yes|no]; default to no.
3895
3896
      -authorfile    or -a : name of file including author information, last element in html;
3897
                             default to empty.
3898
3899
   The command line setting overwrite all other settings (built-in and configuration file).
3900
   The configuration file settings overwrite the built-in settings (and not the command
3901
   line settings).
3902
3903
   Typical usages are:
3904
     $PROGRAM
3905
        (use default parameters from perl script, if configuration
3906
         file is found -> generation of docu, else display of help)
3907
3908
     $PROGRAM -dirmfiles matlab -dirhtml html
3909
        (generate html documentation for all m-files in directory matlab,
3910
         place html files in directory html, use built-in defaults for
3911
         all other parameters, this way all m-files in the directory
3912
         matlab and below are converted and the generated html-files are
3913
         placed in the directory html and below producing the same
3914
         directory structure than below matlab)
3915
3916
     $PROGRAM -quiet
3917
        (use built-in parameters from perl script, if configuration
3918
         file is found use these settings as well, do generation,
3919
         no display except critical errors, status of conversion and result)
3920
3921
     $PROGRAM -m toolbox -dirhtml doc/html -r yes -p no
3922
        (convert all m-files in directory toolbox and below and place
3923
         the generated html files in directory doc/html, read all m-files
3924
         recursively, however, the generated html files are placed in one
3925
         directory)
3926
3927
     $PROGRAM -m toolbox -dirhtml doc/html -i no -r no
3928
        (convert all m-files in directory toolbox and place
3929
         the generated html files in directory doc/html, do not read m-files
3930
         recursively, do not include source code in documentation)
3931
3932
EofHelp
3933
3934
   die "$help";
3935
}
3936
3937
#------------------------------------------------------------------------
3938
# DisplayTodo - display ToDo list using -t or -todo command-line switch
3939
#------------------------------------------------------------------------
3940
sub DisplayTodo
3941
{
3942
   $todo=<<EofToDo;
3943
      $PROGRAM v$VERSION - ToDo list
3944
3945
       o	use more than one high level directory
3946
3947
       o	what should/could be done here???
3948
3949
EofToDo
3950
3951
   die "$todo";
3952
}
3953
3954
3955
#------------------------------------------------------------------------
3956
# ListVariables - list all defined variables and their values
3957
#------------------------------------------------------------------------
3958
sub ListVariables
3959
{
3960
   local($value);
3961
3962
   if ($debug > 0) {
3963
      print "List of all variables and their values\n";
3964
      foreach (sort keys %var)
3965
      {
3966
         if ($var{$_} eq '') {
3967
            $value = "empty";
3968
         } else {
3969
            $value = $var{$_};
3970
         }
3971
         print "   $_\n      $value\n";
3972
      }
3973
      print "\n\n";
3974
   }
3975
}
3976
3977
3978
__END__
3979
:endofperl
3980 0:513646585e45 Chris
#!/usr/bin/env ruby
3981
3982
# == Synopsis
3983
#
3984
# reposman: manages your repositories with Redmine
3985
#
3986
# == Usage
3987
#
3988
#    reposman [OPTIONS...] -s [DIR] -r [HOST]
3989 441:cbce1fd3b1b7 Chris
#
3990 0:513646585e45 Chris
#  Examples:
3991 241:7658d21a1493 chris
#    reposman --scm-dir=/var/svn --redmine-host=redmine.example.net --scm subversion
3992 0:513646585e45 Chris
#    reposman -s /var/git -r redmine.example.net -u http://svn.example.net --scm git
3993
#
3994
# == Arguments (mandatory)
3995
#
3996 241:7658d21a1493 chris
#   -s, --scm-dir=DIR         use DIR as base directory for repositories
3997 0:513646585e45 Chris
#   -r, --redmine-host=HOST   assume Redmine is hosted on HOST. Examples:
3998
#                             -r redmine.example.net
3999
#                             -r http://redmine.example.net
4000
#                             -r https://example.net/redmine
4001 909:cbb26bc654de Chris
#   -k, --key=KEY             use KEY as the Redmine API key (you can use the
4002
#                             --key-file option as an alternative)
4003 0:513646585e45 Chris
#
4004
# == Options
4005
#
4006
#   -o, --owner=OWNER         owner of the repository. using the rails login
4007
#                             allow user to browse the repository within
4008
#                             Redmine even for private project. If you want to
4009
#                             share repositories through Redmine.pm, you need
4010
#                             to use the apache owner.
4011
#   -g, --group=GROUP         group of the repository. (default: root)
4012
#   --scm=SCM                 the kind of SCM repository you want to create (and
4013
#                             register) in Redmine (default: Subversion).
4014
#                             reposman is able to create Git and Subversion
4015
#                             repositories. For all other kind, you must specify
4016
#                             a --command option
4017
#   -u, --url=URL             the base url Redmine will use to access your
4018
#                             repositories. This option is used to automatically
4019
#                             register the repositories in Redmine. The project
4020
#                             identifier will be appended to this url. Examples:
4021
#                             -u https://example.net/svn
4022
#                             -u file:///var/svn/
4023 28:12420e46bed9 chris
#                             if this option isn't set, reposman will register
4024
#                             the repositories with local file paths in Redmine
4025 0:513646585e45 Chris
#   -c, --command=COMMAND     use this command instead of "svnadmin create" to
4026
#                             create a repository. This option can be used to
4027
#                             create repositories other than subversion and git
4028
#                             kind.
4029
#                             This command override the default creation for git
4030
#                             and subversion.
4031 13:80433603a2cd Chris
#   --http-user=USER          User for HTTP Basic authentication with Redmine WS
4032
#   --http-pass=PASSWORD      Password for Basic authentication with Redmine WS
4033 909:cbb26bc654de Chris
#       --key-file=PATH       path to a file that contains the Redmine API key
4034
#                             (use this option instead of --key if you don't
4035
#                             the key to appear in the command line)
4036 0:513646585e45 Chris
#   -t, --test                only show what should be done
4037
#   -h, --help                show help and exit
4038
#   -v, --verbose             verbose
4039
#   -V, --version             print version and exit
4040
#   -q, --quiet               no log
4041
#
4042
# == References
4043 441:cbce1fd3b1b7 Chris
#
4044 0:513646585e45 Chris
# You can find more information on the redmine's wiki : http://www.redmine.org/wiki/redmine/HowTos
4045
4046
4047
require 'getoptlong'
4048 1332:1d1cb01c0417 Chris
#require 'rdoc/usage'
4049 0:513646585e45 Chris
require 'find'
4050
require 'etc'
4051
4052
Version = "1.3"
4053
SUPPORTED_SCM = %w( Subversion Darcs Mercurial Bazaar Git Filesystem )
4054
4055
opts = GetoptLong.new(
4056 241:7658d21a1493 chris
                      ['--scm-dir',      '-s', GetoptLong::REQUIRED_ARGUMENT],
4057 0:513646585e45 Chris
                      ['--redmine-host', '-r', GetoptLong::REQUIRED_ARGUMENT],
4058
                      ['--key',          '-k', GetoptLong::REQUIRED_ARGUMENT],
4059 909:cbb26bc654de Chris
                      ['--key-file',           GetoptLong::REQUIRED_ARGUMENT],
4060 0:513646585e45 Chris
                      ['--owner',        '-o', GetoptLong::REQUIRED_ARGUMENT],
4061
                      ['--group',        '-g', GetoptLong::REQUIRED_ARGUMENT],
4062
                      ['--url',          '-u', GetoptLong::REQUIRED_ARGUMENT],
4063
                      ['--command' ,     '-c', GetoptLong::REQUIRED_ARGUMENT],
4064
                      ['--scm',                GetoptLong::REQUIRED_ARGUMENT],
4065 13:80433603a2cd Chris
                      ['--http-user',          GetoptLong::REQUIRED_ARGUMENT],
4066
                      ['--http-pass',          GetoptLong::REQUIRED_ARGUMENT],
4067 0:513646585e45 Chris
                      ['--test',         '-t', GetoptLong::NO_ARGUMENT],
4068
                      ['--verbose',      '-v', GetoptLong::NO_ARGUMENT],
4069
                      ['--version',      '-V', GetoptLong::NO_ARGUMENT],
4070
                      ['--help'   ,      '-h', GetoptLong::NO_ARGUMENT],
4071
                      ['--quiet'  ,      '-q', GetoptLong::NO_ARGUMENT]
4072
                      )
4073
4074
$verbose      = 0
4075
$quiet        = false
4076
$redmine_host = ''
4077
$repos_base   = ''
4078 13:80433603a2cd Chris
$http_user    = ''
4079
$http_pass    = ''
4080 0:513646585e45 Chris
$svn_owner    = 'root'
4081
$svn_group    = 'root'
4082
$use_groupid  = true
4083
$svn_url      = false
4084
$test         = false
4085
$scm          = 'Subversion'
4086
4087
def log(text, options={})
4088
  level = options[:level] || 0
4089
  puts text unless $quiet or level > $verbose
4090
  exit 1 if options[:exit]
4091
end
4092
4093
def system_or_raise(command)
4094
  raise "\"#{command}\" failed" unless system command
4095
end
4096
4097 1332:1d1cb01c0417 Chris
def usage
4098
  puts "See source code for supported options"
4099
  exit
4100
end
4101
4102 0:513646585e45 Chris
module SCM
4103
4104
  module Subversion
4105
    def self.create(path)
4106
      system_or_raise "svnadmin create #{path}"
4107
    end
4108
  end
4109
4110
  module Git
4111
    def self.create(path)
4112
      Dir.mkdir path
4113
      Dir.chdir(path) do
4114
        system_or_raise "git --bare init --shared"
4115
        system_or_raise "git update-server-info"
4116
      end
4117
    end
4118
  end
4119
4120
end
4121
4122
begin
4123
  opts.each do |opt, arg|
4124
    case opt
4125 241:7658d21a1493 chris
    when '--scm-dir';        $repos_base   = arg.dup
4126 0:513646585e45 Chris
    when '--redmine-host';   $redmine_host = arg.dup
4127
    when '--key';            $api_key      = arg.dup
4128 909:cbb26bc654de Chris
    when '--key-file'
4129
      begin
4130
        $api_key = File.read(arg).strip
4131
      rescue Exception => e
4132
        $stderr.puts "Unable to read the key from #{arg}: #{e.message}"
4133
        exit 1
4134
      end
4135 0:513646585e45 Chris
    when '--owner';          $svn_owner    = arg.dup; $use_groupid = false;
4136
    when '--group';          $svn_group    = arg.dup; $use_groupid = false;
4137
    when '--url';            $svn_url      = arg.dup
4138
    when '--scm';            $scm          = arg.dup.capitalize; log("Invalid SCM: #{$scm}", :exit => true) unless SUPPORTED_SCM.include?($scm)
4139 13:80433603a2cd Chris
    when '--http-user';      $http_user    = arg.dup
4140
    when '--http-pass';      $http_pass    = arg.dup
4141 0:513646585e45 Chris
    when '--command';        $command =      arg.dup
4142
    when '--verbose';        $verbose += 1
4143
    when '--test';           $test = true
4144
    when '--version';        puts Version; exit
4145 1332:1d1cb01c0417 Chris
    when '--help';           usage
4146 0:513646585e45 Chris
    when '--quiet';          $quiet = true
4147
    end
4148
  end
4149
rescue
4150
  exit 1
4151
end
4152
4153
if $test
4154
  log("running in test mode")
4155
end
4156
4157
# Make sure command is overridden if SCM vendor is not handled internally (for the moment Subversion and Git)
4158
if $command.nil?
4159
  begin
4160
    scm_module = SCM.const_get($scm)
4161
  rescue
4162
    log("Please use --command option to specify how to create a #{$scm} repository.", :exit => true)
4163
  end
4164
end
4165
4166
$svn_url += "/" if $svn_url and not $svn_url.match(/\/$/)
4167
4168
if ($redmine_host.empty? or $repos_base.empty?)
4169 1332:1d1cb01c0417 Chris
  usage
4170 0:513646585e45 Chris
end
4171
4172
unless File.directory?($repos_base)
4173 217:ed8222a04634 chris
  log("directory '#{$repos_base}' doesn't exist", :exit => true)
4174 0:513646585e45 Chris
end
4175
4176
begin
4177
  require 'active_resource'
4178
rescue LoadError
4179
  log("This script requires activeresource.\nRun 'gem install activeresource' to install it.", :exit => true)
4180
end
4181
4182 37:94944d00e43c chris
class Project < ActiveResource::Base
4183 217:ed8222a04634 chris
  self.headers["User-agent"] = "SoundSoftware repository manager/#{Version}"
4184 909:cbb26bc654de Chris
  self.format = :xml
4185 37:94944d00e43c chris
end
4186 0:513646585e45 Chris
4187
log("querying Redmine for projects...", :level => 1);
4188
4189
$redmine_host.gsub!(/^/, "http://") unless $redmine_host.match("^https?://")
4190
$redmine_host.gsub!(/\/$/, '')
4191
4192
Project.site = "#{$redmine_host}/sys";
4193 13:80433603a2cd Chris
Project.user = $http_user;
4194
Project.password = $http_pass;
4195 0:513646585e45 Chris
4196
begin
4197
  # Get all active projects that have the Repository module enabled
4198
  projects = Project.find(:all, :params => {:key => $api_key})
4199 909:cbb26bc654de Chris
rescue ActiveResource::ForbiddenAccess
4200
  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.")
4201 0:513646585e45 Chris
rescue => e
4202
  log("Unable to connect to #{Project.site}: #{e}", :exit => true)
4203
end
4204
4205
if projects.nil?
4206 909:cbb26bc654de Chris
  log('No project found, perhaps you forgot to "Enable WS for repository management"', :exit => true)
4207 0:513646585e45 Chris
end
4208
4209 1107:4f45ab104990 Chris
log("found #{projects.size} projects at " + Time.now.inspect);
4210 0:513646585e45 Chris
4211
def set_owner_and_rights(project, repos_path, &block)
4212 441:cbce1fd3b1b7 Chris
  if mswin?
4213 0:513646585e45 Chris
    yield if block_given?
4214
  else
4215
    uid, gid = Etc.getpwnam($svn_owner).uid, ($use_groupid ? Etc.getgrnam(project.identifier).gid : Etc.getgrnam($svn_group).gid)
4216 34:09b1d4349da3 Chris
    right = project.is_public ? 02775 : 02770
4217 0:513646585e45 Chris
    yield if block_given?
4218
    Find.find(repos_path) do |f|
4219
      File.chmod right, f
4220
      File.chown uid, gid, f
4221
    end
4222
  end
4223
end
4224
4225
def other_read_right?(file)
4226
  (File.stat(file).mode & 0007).zero? ? false : true
4227
end
4228
4229
def owner_name(file)
4230
  mswin? ?
4231
    $svn_owner :
4232 441:cbce1fd3b1b7 Chris
    Etc.getpwuid( File.stat(file).uid ).name
4233 0:513646585e45 Chris
end
4234 441:cbce1fd3b1b7 Chris
4235 0:513646585e45 Chris
def mswin?
4236
  (RUBY_PLATFORM =~ /(:?mswin|mingw)/) || (RUBY_PLATFORM == 'java' && (ENV['OS'] || ENV['os']) =~ /windows/i)
4237
end
4238
4239
projects.each do |project|
4240 1107:4f45ab104990 Chris
  log("inspecting project #{project.name}", :level => 1)
4241 0:513646585e45 Chris
4242
  if project.identifier.empty?
4243 1107:4f45ab104990 Chris
    log("\tno identifier for project #{project.name}!")
4244 0:513646585e45 Chris
    next
4245 1445:0c7b3bb73517 Chris
  elsif not project.identifier.match(/^[a-z0-9_\-]+$/)
4246 1107:4f45ab104990 Chris
    log("\tinvalid identifier for project #{project.name} : #{project.identifier}!");
4247 0:513646585e45 Chris
    next;
4248
  end
4249
4250
  repos_path = File.join($repos_base, project.identifier).gsub(File::SEPARATOR, File::ALT_SEPARATOR || File::SEPARATOR)
4251
4252 28:12420e46bed9 chris
  create_repos = false
4253
  # Logic required for SoundSoftware.ac.uk repositories:
4254
  #
4255
  # * If the project has a repository path declared already,
4256
  #   - if it's a local path,
4257
  #     - if it does not exist
4258
  #       - if it has the right root
4259
  #         - create it
4260
  #   - else
4261
  #     - leave alone (remote repository)
4262
  # * else
4263
  #   - create repository with same name as project
4264
  #   - set to project
4265
4266
  if project.respond_to?(:repository)
4267
4268
    repos_url = project.repository.url;
4269 1107:4f45ab104990 Chris
    log("\texisting url for project #{project.identifier} is #{repos_url}", :level => 2);
4270 28:12420e46bed9 chris
4271
    if repos_url.match(/^file:\//) || repos_url.match(/^\//)
4272
4273
      repos_url = repos_url.gsub(/^file:\/*/, "/");
4274 1107:4f45ab104990 Chris
      log("\tthis is a local file path, at #{repos_url}", :level => 2);
4275 28:12420e46bed9 chris
4276
      if repos_url.slice(0, $repos_base.length) != $repos_base
4277
        # leave repos_path set to our original suggestion
4278 1107:4f45ab104990 Chris
        log("\tpreparing to replace incorrect repo location #{repos_url} for #{project.name} with #{repos_path}");
4279 28:12420e46bed9 chris
        create_repos = true
4280
      else
4281
        if !File.directory?(repos_url)
4282 1107:4f45ab104990 Chris
          log("\tpreparing to create repo for #{project.name} at #{repos_url}");
4283 28:12420e46bed9 chris
          repos_path = repos_url
4284
          create_repos = true
4285
        else
4286 1107:4f45ab104990 Chris
          log("\tit exists and is in the right place", :level => 2);
4287 28:12420e46bed9 chris
        end
4288
      end
4289
    else
4290 1107:4f45ab104990 Chris
      log("\tthis is a remote path, leaving alone", :level => 2);
4291 28:12420e46bed9 chris
    end
4292
  else
4293 1107:4f45ab104990 Chris
    log("\tpreparing to set repo location and create for #{project.name} at #{repos_url}")
4294 28:12420e46bed9 chris
#    if File.directory?(repos_path)
4295
#      log("\trepository path #{repos_path} already exists, not creating")
4296
#    else
4297
      create_repos = true
4298
#    end
4299
  end
4300
4301
  if create_repos
4302
4303
    registration_url = repos_path
4304
    if $svn_url
4305
      registration_url = "#{$svn_url}#{project.identifier}"
4306
    end
4307 0:513646585e45 Chris
4308
    if $test
4309 28:12420e46bed9 chris
      log("\tproposal: create repository #{repos_path}")
4310
      log("\tproposal: register repository #{repos_path} in Redmine with vendor #{$scm}, url #{registration_url}")
4311 0:513646585e45 Chris
      next
4312
    end
4313
4314 52:8c3409528d3a Chris
# No -- we need "other" users to be able to read it.  Access control
4315
# is not handled through Unix user id anyway
4316
#    project.is_public ? File.umask(0002) : File.umask(0007)
4317
    File.umask(0002)
4318
4319 28:12420e46bed9 chris
    log("\taction: create repository #{repos_path}")
4320 0:513646585e45 Chris
4321
    begin
4322 28:12420e46bed9 chris
      if !File.directory?(repos_path)
4323
        set_owner_and_rights(project, repos_path) do
4324
          if scm_module.nil?
4325
            log("\trunning command: #{$command} #{repos_path}")
4326
            system_or_raise "#{$command} #{repos_path}"
4327
          else
4328
            scm_module.create(repos_path)
4329
          end
4330 0:513646585e45 Chris
        end
4331
      end
4332
    rescue => e
4333
      log("\tunable to create #{repos_path} : #{e}\n")
4334
      next
4335
    end
4336
4337 28:12420e46bed9 chris
    begin
4338
      log("\taction: register repository #{repos_path} in Redmine with vendor #{$scm}, url #{registration_url}");
4339
      project.post(:repository, :vendor => $scm, :repository => {:url => "#{registration_url}"}, :key => $api_key)
4340
    rescue => e
4341
      log("\trepository #{repos_path} not registered in Redmine: #{e.message}");
4342 0:513646585e45 Chris
    end
4343
    log("\trepository #{repos_path} created");
4344
  end
4345 37:94944d00e43c chris
end
4346 0:513646585e45 Chris
4347 1107:4f45ab104990 Chris
log("project review completed at " + Time.now.inspect);
4348
4349 241:7658d21a1493 chris
#!/bin/sh
4350
4351 242:bde4f47b6427 chris
mirrordir="/var/mirror"
4352 1336:b61a51fb42b9 Chris
hg="/usr/bin/hg"
4353 242:bde4f47b6427 chris
4354 241:7658d21a1493 chris
project="$1"
4355
local_repo="$2"
4356
remote_repo="$3"
4357
4358
if [ -z "$project" ] || [ -z "$local_repo" ] || [ -z "$remote_repo" ]; then
4359
    echo "Usage: $0 <project> <local-repo-path> <remote-repo-url>"
4360
    exit 2
4361
fi
4362
4363
  # We need to handle different source repository types separately.
4364
  #
4365
  # The convert extension cannot convert directly from a remote git
4366
  # repo; we'd have to mirror to a local repo first.  Incremental
4367
  # conversions do work though.  The hg-git plugin will convert
4368
  # directly from remote repositories, but not via all schemes
4369
  # (e.g. https is not currently supported).  It's probably easier to
4370
  # use git itself to clone locally and then convert or hg-git from
4371
  # there.
4372
  #
4373
  # We can of course convert directly from remote Subversion repos,
4374
  # but we need to keep track of that -- you can ask to convert into a
4375
  # repo that has already been used (for Mercurial) and it'll do so
4376
  # happily; we don't want that.
4377
  #
4378
  # Converting from a remote Hg repo should be fine!
4379
  #
4380
  # One other thing -- we can't actually tell the difference between
4381
  # the various SCM types based on URL alone.  We have to try them
4382
  # (ideally in an order determined by a guess based on the URL) and
4383
  # see what happens.
4384
4385 242:bde4f47b6427 chris
project_mirror="$mirrordir/$project"
4386
mkdir -p "$project_mirror"
4387
project_repo_mirror="$project_mirror/repo"
4388 241:7658d21a1493 chris
4389 242:bde4f47b6427 chris
  # Some test URLs:
4390
  #
4391
  # http://aimc.googlecode.com/svn/trunk/
4392
  # http://aimc.googlecode.com/svn/
4393
  # http://vagar.org/git/flam
4394
  # https://github.com/wslihgt/IMMF0salience.git
4395
  # http://hg.breakfastquay.com/dssi-vst/
4396
  # git://github.com/schacon/hg-git.git
4397
  # http://svn.drobilla.net/lad (externals!)
4398
4399
# If we are importing from another distributed system, then our aim is
4400
# to create either a Hg repo or a git repo at $project_mirror, which
4401
# we can then pull from directly to the Hg repo at $local_repo (using
4402
# hg-git, in the case of a git repo).
4403
4404
# Importing from SVN, we should use hg convert directly to the target
4405
# hg repo (or should we?) but keep a record of the last changeset ID
4406
# we brought in, and test each time whether it matches the last
4407
# changeset ID actually in the repo
4408
4409
success=""
4410
4411 436:4eb486dbf730 Chris
# If we have a record of the last successfully updated remote repo
4412
# URL, check it against our current remote URL: if it has changed, we
4413
# will need to start again with a new clone rather than pulling
4414
# updates into the existing local mirror
4415
4416
successfile="$project_mirror/last_successful_url"
4417
if [ -f "$successfile" ]; then
4418
    last=$(cat "$successfile")
4419 437:102056ec2de9 chris
    if [ x"$last" = x"$remote_repo" ]; then
4420 436:4eb486dbf730 Chris
	echo "$$: Remote URL is unchanged from last successful update"
4421
    else
4422
	echo "$$: Remote URL has changed since last successful update:"
4423
	echo "$$: Last URL was $last, current is $remote_repo"
4424
	suffix="$$.$(date +%s)"
4425
	echo "$$: Moving existing repos to $suffix suffix and starting afresh"
4426
	mv "$project_repo_mirror" "$project_repo_mirror"."$suffix"
4427
	mv "$local_repo" "$local_repo"."$suffix"
4428
	mv "$successfile" "$successfile"."$suffix"
4429 437:102056ec2de9 chris
	touch "$project_mirror/url_changed"
4430 436:4eb486dbf730 Chris
    fi
4431
fi
4432
4433 242:bde4f47b6427 chris
if [ -d "$project_repo_mirror" ]; then
4434
4435
    # Repo mirror exists: update it
4436
    echo "$$: Mirror for project $project exists at $project_repo_mirror, updating" 1>&2
4437
4438
    if [ -d "$project_repo_mirror/.hg" ]; then
4439 433:7fd72f22a42b Chris
	"$hg" --config extensions.convert= convert --datesort "$remote_repo" "$project_repo_mirror" && success=true
4440 439:d3faf348b287 chris
	if [ -z "$success" ]; then
4441
	    ( cd "$project_repo_mirror" && "$hg" pull "$remote_repo" ) && success=true
4442
	fi
4443 242:bde4f47b6427 chris
    elif [ -d "$project_repo_mirror/.git" ]; then
4444 431:d3af621ba9d4 Chris
	( cd "$project_repo_mirror" && git pull "$remote_repo" master ) && success=true
4445 242:bde4f47b6427 chris
    else
4446
	echo "$$: ERROR: Repo mirror dir $project_repo_mirror exists but is not an Hg or git repo" 1>&2
4447
    fi
4448
4449
else
4450
4451
    # Repo mirror does not exist yet
4452
    echo "$$: Mirror for project $project does not yet exist at $project_repo_mirror, trying to convert or clone" 1>&2
4453
4454
    case "$remote_repo" in
4455
	*git*)
4456
	    git clone "$remote_repo" "$project_repo_mirror" ||
4457 433:7fd72f22a42b Chris
	    "$hg" --config extensions.convert= convert --datesort "$remote_repo" "$project_repo_mirror"
4458 242:bde4f47b6427 chris
	    ;;
4459
	*)
4460 433:7fd72f22a42b Chris
	    "$hg" --config extensions.convert= convert --datesort "$remote_repo" "$project_repo_mirror" ||
4461 299:defe55be97b9 chris
	    git clone "$remote_repo" "$project_repo_mirror" ||
4462 433:7fd72f22a42b Chris
	    "$hg" clone "$remote_repo" "$project_repo_mirror"
4463 242:bde4f47b6427 chris
	    ;;
4464
    esac && success=true
4465
4466
fi
4467
4468
echo "Success=$success"
4469
4470
if [ -n "$success" ]; then
4471
    echo "$$: Update successful, pulling into local repo at $local_repo"
4472 436:4eb486dbf730 Chris
    if [ ! -d "$local_repo" ]; then
4473
	"$hg" init "$local_repo"
4474
    fi
4475 242:bde4f47b6427 chris
    if [ -d "$project_repo_mirror/.git" ]; then
4476 436:4eb486dbf730 Chris
	( cd "$local_repo" && "$hg" --config extensions.hggit= pull "$project_repo_mirror" ) && echo "$remote_repo" > "$successfile"
4477 242:bde4f47b6427 chris
    else
4478 436:4eb486dbf730 Chris
	( cd "$local_repo" && "$hg" pull "$project_repo_mirror" ) && echo "$remote_repo" > "$successfile"
4479 242:bde4f47b6427 chris
    fi
4480
fi