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 @ 1537:e55cbb9ba8bf

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