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 @ 1550:7d825cbd76c8

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