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 @ 1539:22d57b0e0a77

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