summaryrefslogtreecommitdiff
path: root/support/genfam/genfam
blob: 81693d0c58645c3c38bbd43cb5f102365f7af4c4 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
#! /usr/local/bin/perl
# $Id: genfam,v 1.7 1991/07/16 12:50:09 tex Exp tex $
#------------------------------------------------------------
# (c) 1991 by Joachim Schrod <schrod@iti.informatik.th-darmstadt.de>.
#
#	genfam device family
#
# creates a font set for device as specified in Table/<family>.
# This file has the following line structure:
#
#	<family table> :-
#		preambel with arbitrary text
#		<header>
#		<font sets>
#
#	<header> :-
#		'::HEADER::' new_line+
#		<directory>
#		[ <command> ]
#		[ { <environment variables> } ]
#	<directory> :- 'DIR' not_white_space+ new_line+
#	<command> :- 'COMMAND' rest_of_line new_line+
#	<environment variables> :- env_var_name not_white_space+ new_line+
#
#	<font sets> :-
#		'::FONTS::' new_line+
#		{ <font set> }
#	<font set> :- <magnification> file_pattern {new line}+
#	<magnification> :- <mag step> | real_number
#	<mag step> :- 's'real_number
#
# Comments start with `%' and end with the last character on the line.
# Unlike in TeX the new_line does NOT belong to the comment.
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 1, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
# $Log: genfam,v $
# Revision 1.7  1991/07/16  12:50:09  tex
# New TFM really stored in tfm/, if different from old one.
# Output (stdout and stderr) to nohup.out is unbuffered.
#
# Revision 1.6  1991/04/12  15:25:01  tex
# Don't look up TFM file in directory "." (it would be found anyhow).
# Create tfm directory for new TFM files in base directory.
# Search this tfm directory first so that warnings for different
# TFM files will only be given once in a run.
#
# Revision 1.5  1991/04/08  13:22:36  tex
# included copyright notice for distribution.
#
# Revision 1.4  1991/02/08  20:32:29  tex
# New TFM file that cannot be found is saved in subdirectory tfm.
#
# Revision 1.3  1991/02/08  20:10:06  tex
# Directory with font sources is always included in MFINPUTS path.
# On differences in dpi values our own value is used for the directory
#    name.
# The TFM file is search in the TEXFONTS path and is compared to if
#    a file is found. If the new TFM differs it is not deleted.
#
# Revision 1.2  1991/02/08  12:41:14  tex
# perl is now in /usr/local/bin instead of /software/bin.
# Include dpi in separator of LOG files to distinguish different fonts.
# $#errors is -1 when no errors were found.
# $real_dpi must be computed with round() instead of trunc().
# Check differences between MF dpi values and own computed values.
#
# Revision 1.1  91/02/01  19:33:42  schrod
# Initial revision
# 
# name:	table_line
# pre:	TABLE is open
# ret:	next non-empty line of TABLE, comments are deleted
#       leading and trailing white space is discarded
#	empty line if eof

sub table_line
{
    if ( eof(TABLE) ) {
        return "";
    }
    while ( <TABLE> ) {
        chop;			    # throw away new_line
        s/%.*$//o;                  # discard comments
	s/^\s*(.*)\s*$/$1/o;        # discard leading and trailing white space
	if ( $_ eq "" ) {           # skip blank lines
	    next;
        }
	return $_;                  # We've found a non-empty line!
    }
    return "";                      # end of file reached.
}


# name:	info()
# pre:	TABLE is open and at beginning
# ret:	(dir, command)
#		dir is family directory
#		command is MF command for create_font()
# post:	set env vars if necessary
#	::FONTS:: is already read
# err:	exits if family directory is not given or does not exist

sub info
{
    local ($line);          # next non-empty line
    local ($key, $value);   # (key, value) pair from table header

    while ( ($line=&table_line()) ne "::HEADER::"  &&  $line ne "" ) {}
    if ( $line eq "" ) {
        print "! There is no header in $table.";
	exit 2;
    }

    $line = &table_line();
    ($key, $value) = split(/\s+/o, $line);
    if ( $key eq "DIR" ) {
        $dir = $value;
	if ( ! -d $dir ) {
	    print "! Directory $dir does not exist.";
	    exit 2;
	}
	if ( $ENV{"MFINPUTS"} ne "" ) {
	    $ENV{"MFINPUTS"} .= ":$dir";
	} else {
	    $ENV{"MFINPUTS"} .= "$dir";
	}
    } else {
        print "! Source directory must be specified in $table.";
	exit 2;
    }

    $line = &table_line();
    ($key, $value) = split(/\s+/o, $line, 2);
    if ( $key eq "COMMAND" ) {
        $command = $value;
	$line = &table_line();
    } else {
        $command = "mf";
    }

    while ( $line ne "::FONTS::"  &&  $line ne "" ) {
	($key, $value) = split(/\s+/o, $line);
	if ( $key eq "MFINPUTS" ) {
	    $value .= ":$dir";
        }
	$ENV{$key} = $value;
	$line = &table_line();
    }
}


# name: resolution(MF_command, mode_def)
# pre:	MF is callable with MF_command
#	mode_def exists with the used base
# ret:	resolution in dpi

sub resolution
{
    local ($command, $mode_def) = @_;
    local (@log, $out_markup, $dpi);

    # First build a MF call:
    #   MF shall not ask the (non-existent) user if an error has occured,
    #   it shall switch to the mode definition,
    #   and shall output the respective resolution.
    #   stdin is /dev/null
    #       -- this will cause an emergency stop if all else fails.
    $command .= " '\\scrollmode;".
                "mode=$mode_def;$mode_def"."_;".
		"show pixels_per_inch;end;' ".
		"</dev/null";

    # Then we execute this call and catch the output in @log.
    # If the command failed we did not have any output.
    @log = `$command`;
    if ( $#log == -1 ) {
        print "! I've had problems in calling METAFONT.";
	exit 2;
    }

    # We look for a line with a show output (starting with `>>')
    # in the MF output. The respective
    # line is stored in $out_markup. If no such line is found, $out_markup
    # is "! Error message", simulating a MF error in this way.
    $out_markup = "! Error message";
    foreach ( @log ) {
        $line_no += 1;
        if ( /^>>/o ) {
	    $out_markup = $_;
	    last;
        }
    }

    # We split the found line. Then $out_mark is hopefully ">>", otherwise
    # it's an error.
    ($out_markup, $dpi) = split(/\s+/, $out_markup);
    if ( $out_markup eq "!"  ||  grep(/^!/, @log) > 0 ) {
        print "! There was an error while calling METAFONT.";
	print "  Perhaps the device is no valid mode definition?";
	print "  Let's have a look at the MF output:";
	print "-" x 70;
	print @log;
	unlink "mfput.log";
	exit 2;
    }

    # Of course the output should be a real number.
    if ( $dpi !~ /\d+(\.\d*)?/o ) {
        print "! METAFONT did not tell me a resolution for this device.";
	print "  I'm stymied. Perhaps you should take a look at the MF output:";
	print "-" x 70;
	print @log;
	unlink "mfput.log";
	exit 2;
    }

    # MF produced mfput.log and mfput.tfm, we will delete them before returning.
    unlink <mfput.*>;
    return($dpi);
}


# name:	create_dir(dir)
# pre:	---
# post:	directory dir exists

sub create_dir
{
    local ($dir) = @_;
    if ( -e $dir ) {
	if ( -d _ ) {
	    return;
	}
	print "! File $dir exists but is no directory.";
	do finish();
    }
    mkdir($dir, 0777)  ||  die "$0: mkdir $dir: $!.\n";
}


# name:	base_dir(mode_def)
# pre:	---
# ret:	full path name of base directory (i.e. new current directory)
# post:	base directory for mode_def is created if necessary
#	is now current directory

sub base_dir
{
    local ($mode_def) = @_;
    do create_dir($mode_def);
    chdir($mode_def);
    chop( $mode_def=`pwd` );
    return $mode_def;
}


# name:	lookup(file, path)
# pre:	$file is a name of a regular file
#	@path is an array with directory names
# ret:	full path name of $file if found in one directory
#	"" if not found

sub lookup
{
    local ($file, @path) = @_;
    local ($dir);

    foreach $dir ( @path ) {
        next if $dir eq "";
        if ( -f "$dir/$file" ) {
	    return "$dir/$file";
	}
    }
    return "";
}


# name:	create_font(mag, file)
# pre:	mag holds the mag string for MF call
#	file is a MF program and is found by $MFINPUTS
#	$command holds the MF call
#	$device holds the mode definition
#	$real_dpi is the dpi value we have computed
#	LOGerror is open for writing
#	LOGwarning is open for writing
# post:	PK file is created in subdir dpi<dpi>/.
#	LOG file is analyzed,
#		errors are appended to LOGerror,
#		warnings are appended to LOGwarning,
#		whole LOG is appended to LOGall.
#	no GF file exists.
#	@font_count[0..1] is incremented;

sub create_font
{
    local ($mag, $file) = @_;
    local (@log, @errors, $error, $dpi);
    local ($font) = split(/\./, $file);
    local ($font_msg) = $font." at ".$real_dpi." dpi";
    local ($separator)= "=" x 20." ".$font_msg." "."=" x (58-length($font_msg));

    $font_count[0] += 1;    # we try the next font
    @log = `$command '\\scrollmode; mode=$device; mag=$mag; input $file`;

    {
	@errors = grep(/^!/, @log);
	if ( ($error=$#errors) == -1 ) {
	    last;
	}

	@errors = grep(!/^! Strange path/, @errors);
	if ( $#errors != $error ) {
	    print LOGwarning $separator;
	    print LOGwarning $error-$#errors, " strange paths have occured.";
        }
        if ( $#errors == -1 ) {
	    last;
        }

        print LOGerror $separator;
	$error = 0;
        foreach ( @log ) {
	    if ( $error ) {
	        chop;  print LOGerror $_;
		if ( $error == 2 ) {
		    $error = 0;
		} elsif ( /^l.\d+/o ) {
		    $error = 2;
		}
	    } elsif ( /^!/o  &&  ! /^! Strange/o ) {
	        chop;  print LOGerror $_;
		$error = 1;
            }
	}
    }

    system "echo '$separator' >>LOGall";
    system "cat $font.log >>LOGall";

    $dpi = $log[$#log - 1];
    if ( $dpi !~ /^Output/o ) {
        print LOGerror "!" x 20, " No output!";
	return;
    }

    ($dpi) = ( $dpi =~ /$font\.(\d+)gf/ );
    if ( $dpi != $real_dpi ) {
    	print "! Dpi-differences between MF ($dpi dpi) and me ($real_dpi dpi).";
    }
    system "gftopk", "$font.${dpi}gf", "dpi$real_dpi/$font"
        ||  print LOGerror "!" x 20," Problems with gftopk on $font.${dpi}gf";

    $old_tfm = &lookup("$font.tfm", @tfm_path);
    if ( $old_tfm eq "" ) {
        print "! New TFM file: tfm/$font.tfm";
        rename("$font.tfm", "tfm/$font.tfm");
    } elsif ( system("cmp", "-s", "$font.tfm", $old_tfm) ) {
	print "! Different TFMs for type $font, new one stored in tfm/.";
        rename("$font.tfm", "tfm/$font.tfm");
    }

    unlink( grep(!/\.mf/, <$font.*>) );

    $font_count[1] += 1;    # well, we succeeded
}


# name:	create_mag(mag, pattern)
# pre:	mag is the magnification of the font set
#	$dpi is the base resolution of the device
#	$cwd is the current directory, i.e., the base directory
#	$dir is the directory where the MF programs reside
#	pattern are files in $dir which shall be created in mag
#	create_font(file) with file from {pattern} is callable
# post:	for all files create_font() is called

sub create_mag
{
    local ($mag, $pattern) = @_;
    local (@files, $file, $MF_mag, $real_dpi);

    chdir $dir;  @files = <${pattern}>;  chdir $cwd;
    if ( $#files == -1 ) {
        return;
    }

    $MF_mag = $mag;
    if ( $MF_mag =~ s/^s(\d+(\.\d*)?)/$1/o ) {
        $real_dpi = 1.2 ** $MF_mag;
	$MF_mag = "magstep(".$MF_mag.")";
    } else {
        $real_dpi = $MF_mag;
    }
    if ( $real_dpi == 0 ) {
        print "! Hmm, the magnification $mag is not valid.";
	return;
    }

    $real_dpi = int( $real_dpi * $dpi  + 0.5 );     # round does not exist...
    do create_dir("dpi".$real_dpi);

    foreach $file ( @files ) {
        do create_font($MF_mag, $file);
    }
}


# name:	finish()
# pre:	$init_phase is set
# post: no return

sub finish
{
    local ($log_msg);


    if ( $init_phase ) {
        exit 2;
    }


    # We are finished and tell now how long we have run.

    $log_msg = "=" x 79;
    print LOGerror $log_msg;
    print LOGwarning $log_msg;
    print LOGall $log_msg;

    ($user, $system, $cuser, $csystem) = times;
    $total = sprintf("%.2f", $user + $system + $cuser + $csystem);
    $user = sprintf("%.2f", $user);
    $system = sprintf("%.2f", $system);
    $cuser = sprintf("%.2f", $cuser);
    $csystem = sprintf("%.2f", $csystem);
    chop( $time = &ctime(time) );

    $log_msg = <<EOT

Well, now it's $time.

I've started MF $font_count[0] times and created $font_count[1] fonts.
All in all, we have needed (u:$user, s:$system) seconds to control the run,
MF and associated programs needed (u:$cuser, s:$csystem) seconds,
in total that makes $total seconds.
        Howdy!
EOT
    ;
    print LOGerror $log_msg;
    print LOGwarning $log_msg;
    print LOGall $log_msg;


    # Send the starter a mail that we are finished
    open(STDOUT, "| /bin/mail $name");
    print <<EOT
Hello,

You have started a $0 script for the creation of the $family fonts
for device $device. This script is finished.

It's error messages are in $cwd/nohup.out.
You should take a look at LOG* in the same directory (especially at LOGerror).

		Virtually, your MF management
EOT
    ;
    close(STDOUT);

    exit 0;
}


# extract basename from $0
# supply new_line at end of line
# and load needed library functions

    $0 =~ s:^.*/([^/]+):$1:o;
    $\ = "\n";
    require "ctime.pl";


# show that we have not done real work up to now

    $init_phase = 1;


# who is the person which wants to make new fonts?

    if ( ! defined $ENV{"LOGNAME"} ) {
        if ( defined $ENV{"USER"} ) {
	    $ENV{"LOGNAME"} = $ENV{"USER"};
	} else {
	    print "Oops, you do not have a logname!";
	    local ($\) = "";    # just for the following print
	    while {
	        print "Who are you? ";
	        ($name=<STDIN>) eq "";
	    } {}
	    $ENV{"LOGNAME"} = $name;
        }
    }
    $name = $ENV{"LOGNAME"};



# check arguments

    if ( $#ARGV != 1 ) {
        print "usage: ",$0," device family";
        exit 1;
    }

# give them names

    ($device, $family) = @ARGV;

# open table file

    $table = "Table/".$family;
    if ( ! -f $table  ||  ! -r _ ) {
        print "! Cannot read $table.";
	exit 2;
    }
    open(TABLE,"<".$table);

# read table header, compute base resolution and generate base directory

    do info();
    $dpi = &resolution($command, $device);
    $cwd = &base_dir($device);

# Now we are in the base directory.


# Set up a search path for TFM files. Use the environment variable
# $TEXFONTS, and as a default /usr/tex/fonts/tfm and tfm. This search
# path is used to detect if created TFM files exist already, and if
# they match the existing ones.
#   We supply a subdirectory tfm; there must be a place where new TFM
# files may be stored.
#   But: The directory `.' must not be part of the search path. In this
# directory a matching TFM file will always be found: the created one...

    do create_dir("tfm");
    @tfm_path = split(/:/, $ENV{"TEXFONTS"});
    @tfm_path = grep( ! /^\.$/, @tfm_path); # delete entry "."
    unshift(@tfm_path, "tfm");    # new versions should be found first
    push(@tfm_path, "/usr/tex/fonts/tfm");




# All initializations are done, MF ran already, and we may now assume that
# the rest is computer's work. So we fork of a process, disconnect it from
# our main process and start the whole stuff ::::

    print <<EOT

OK, I fork myself and get METAFONT running. This will need a while.
You will find my error messages in $device/nohup.out.
EOT
    ;

    if ( fork != 0 ) {  # parent:
        sleep 2;        # wait for child process to establish SIG handler
	exit 0;
    }

    $init_phase = 0;    # start real work

    $SIG{'HUP'} = "IGNORE";     # child: disconnect from parent
    open(STDIN, "</dev/null");
    open(STDOUT, ">nohup.out");  open(STDERR, ">&STDOUT");
    $| = 1;			# print unbuffered



#   Create files LOGerror and LOGwarning because they will be written
# by this script.
#   But delete LOGall as this will be written by cat. This deletion is not
# done by unlink because this file may be linked to somewhere else due to
# space reasons. So we use an open and a close. But before we write a
# header to the LOG files so that the reader will know what we have done.

    $log_msg = "Started creation of family $family on ".&ctime(time).
                "Skript activated by $name\n";  # two NL's !!

    open(LOGerror, ">LOGerror");
    open(LOGwarning, ">LOGwarning");
    open(LOGall, ">LOGall");
    print LOGerror $log_msg;
    print LOGwarning $log_msg;
    print LOGall $log_msg;
    close(LOGall);


# Read each font set from TABLE, split it, setup mag specification
# string for MF, and call create_mag().

    @font_count = (0, 0);
    while ( ($_ = &table_line()) ne "" ) {
        ($mag, $pattern) = split;
	do create_mag($mag, $pattern);
    }


# cleanup

    do finish();