Sch2db.pl 26.7 KB
Newer Older
pfeiffer's avatar
pfeiffer committed
1
2
3
4
5
eval 'exec perl -S $0 ${1+"$@"}' # -*- Mode: perl -*-
    if 0;                         
# the above is a more portable way to find perl
# ! /usr/bin/perl

6
7
8
9
10
11
12
13
14
# Copyright 2015 Helmholtz-Zentrum Berlin für Materialien und Energie GmbH
# <https://www.helmholtz-berlin.de>
#
# Author: Goetz Pfeiffer <Goetz.Pfeiffer@helmholtz-berlin.de>
#
# 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 3 of the License, or (at your option) any later
# version.
15
# 
16
17
18
19
# 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.
20
# 
21
22
# You should have received a copy of the GNU General Public License along with
# this program.  If not, see <http://www.gnu.org/licenses/>.
23
24


pfeiffer's avatar
pfeiffer committed
25
26
27
28
29
30
31
32
33
34
35
36
37
38
# ---------------------------------------------------------------------
# sch2db.p
# converts capfast (*.sch) files to epics database (*.db) format.
# 
# author:                 Goetz Pfeiffer
# mail:                   pfeiffer@mail.bessy.de
# last modification date: 2002-06-13

# ---------------------------------------------------------------------


use strict;
use File::Basename;
use Getopt::Long;
39
use Data::Dumper;
pfeiffer's avatar
pfeiffer committed
40

41
42
use capfast_defaults 1.0;

pfeiffer's avatar
pfeiffer committed
43
44
use vars qw($opt_help $opt_summary $opt_file $opt_out $opt_sympath 
           $opt_warn_miss $opt_warn_double $opt_no_defaults
45
	   $opt_dump_symfile $opt_internal_syms
pfeiffer's avatar
pfeiffer committed
46
	   $opt_name_to_desc $opt_var_to_desc
pfeiffer's avatar
pfeiffer committed
47
48
49
50
51
	   );

# ------------------------------------------------------------------------
# constants

pfeiffer's avatar
pfeiffer committed
52
my $version= "1.6";
pfeiffer's avatar
pfeiffer committed
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67

$opt_sympath= "/home/controls/epics/R3.13.1/support/capfast/1-2/edif";

# ------------------------------------------------------------------------
# global variables
my %struc;    # this will contain the records
my %wires;    # this will contain the wires
my %fields;   # needed to handle connections between record-fields

my %symbols;  # list of used capfast symbols

my %aliases;  # store aliases like : 'username(U0):LOPR'

my %gl_nlist; # contains things like: n#402

68
69
70
71
# ------------------------------------------------------------------------
# internal symbol data

# symbol-defaults:
72
my $r_rec_defaults = \%capfast_defaults::rec_defaults;
73
74
# defaults for record-links:

75
my $r_rec_linkable_fields = \%capfast_defaults::rec_linkable_fields;
76

pfeiffer's avatar
pfeiffer committed
77
78
79
80
81
82
83
# ------------------------------------------------------------------------
# command line options processing:

Getopt::Long::config(qw(no_ignore_case));

if (!GetOptions("help|h","summary","file|f=s","out|o=s",
               "warn_miss|m:s","warn_double|d",
84
85
                "sympath|s=s", "no_defaults|n",
		"dump_symfile",
86
87
		"internal_syms|S",
		"name_to_desc|D",
pfeiffer's avatar
pfeiffer committed
88
		"var_to_desc|V",
89
		))
pfeiffer's avatar
pfeiffer committed
90
91
92
93
94
95
96
97
98
99
100
  { die "parameter error, use \"$0 -h\" to display the online-help\n"; };

if ($opt_help)
  { print_help();
    exit;
  };  

if ($opt_summary)
  { print_summary();
    exit;
  };  
101

Pfeiffer, Götz's avatar
Pfeiffer, Götz committed
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
# GetOptions has a problem:
#  if an option argument is missing, the next
#  option is just taken as option argument. So
#  if you call "Sch2db.pl -s -f [file]", the argument
#  to -s is missing, to -s gets "-f" as value and
#  "-f" is removed as option. So we test all options
#  with argument if the argument starts with "-", if this
#  is found, an error message is printed and the program
#  is aborted. 
foreach my $s ($opt_file, $opt_out, $opt_sympath)
  { next if (!defined $s);
    if ($s=~/^-/)
      { die "option argument missing"; }
  }

117
if ($opt_dump_symfile)
118
119
  { $r_rec_defaults= {};
    $r_rec_linkable_fields= {};
120

121
122
    scan_symbols($opt_sympath,$r_rec_defaults,
        	 $r_rec_linkable_fields);
123

124
    $Data::Dumper::Indent= 1;
125
    print Data::Dumper->Dump([$r_rec_defaults, $r_rec_linkable_fields], 
126
                             [qw(*rec_defaults *rec_linkable_fields)]);
127

128
    #hdump("scanned link defaults:","rec_linkable_fields",
129
130
    #      $r_rec_linkable_fields); 
    #hdump("scanned symbols:","rec_defaults",$r_rec_defaults);   
131
132
133
134
    exit(0);
  }


pfeiffer's avatar
pfeiffer committed
135
136
137
138
139
140
141
142
143
scan_sch($opt_file,\%gl_nlist,\%wires,\%struc,\%symbols);          

#       hdump("after scan_sch():","gl_nlist",\%gl_nlist); exit(1);
#       hdump("after scan_sch():","wires",\%wires);       exit(1);
#       hdump("after scan_sch():","struc",\%struc);       exit(1);
#       hdump("after scan_sch():","aliases",\%aliases);   exit(1);
#       hdump("after scan_sch():","symbols",\%symbols);   exit(1);


144
if (!$opt_internal_syms)
145
146
  { $r_rec_defaults= {};
    $r_rec_linkable_fields= {};
147

148
149
    scan_symbols($opt_sympath,$r_rec_defaults,
        	 $r_rec_linkable_fields, keys %symbols);
150
    #       hdump("scanned link defaults:","rec_linkable_fields",
151
152
    #             $r_rec_linkable_fields); exit(1);
    #       hdump("scanned symbols:","rec_defaults",$r_rec_defaults);     exit(1);
153
  };
pfeiffer's avatar
pfeiffer committed
154
155
156
157

# resolve aliases:
resolve_aliases(\%aliases, \%wires);
#       hdump("after resolve_aliases():","wires",\%wires);  exit(1);
158
159


pfeiffer's avatar
pfeiffer committed
160
161
162
163
# resolve junctions:
resolve_junctions(\%gl_nlist, \%wires);
#       hdump("after resolve_junctions():","wires",\%wires);  exit(1);
#       hdump("after resolve_junctions():","struc",\%struc);  exit(1);
164
165


pfeiffer's avatar
pfeiffer committed
166
167
168
169
170
171
172
173
# resolve wires:
resolve_wires(\%wires, \%fields);
#       hdump("after resolve_wires():","fields",\%fields);  exit(1);
#       hdump("after resolve_wires():","struc",\%struc);    exit(1);

resolve_connections(\%struc, \%fields);
#       hdump("after resolve_connections():","struc",\%struc);  exit(1);

pfeiffer's avatar
pfeiffer committed
174
db_prepare($opt_file,$opt_out,\%struc, $opt_name_to_desc, $opt_var_to_desc); 
pfeiffer's avatar
pfeiffer committed
175
176
177
178
179
180
181
182
183
184
185
186
db_print($opt_out,\%struc); exit(0);

# scanning ---------------------------------------

sub scan_sch
  { my($filename,$r_gl_wirelists,$r_wires,$r_struc,$r_used_symbols)= @_;
    local *F;

    my $part;
    my $segment;
    my $lineno=0;
    my $type;
187

pfeiffer's avatar
pfeiffer committed
188
189
190
191
    if (defined $filename)
      { open(F,$filename) || die "unable to open $filename\n"; }
    else
      { *F= *STDIN; };
192

pfeiffer's avatar
pfeiffer committed
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
    my $line;
    while($line=<F>)
      { $lineno++;
	chomp($line);

	if ($line=~ /^\[([^\]]+)\]/)
	  { $segment= $1; next; };

	if ($segment eq 'detail')
	  { my @f= split(" ",$line);

            next if ($f[0] eq 's');
            next if ($f[0] eq 'f');
            next if ($f[0] eq 'p');

	    if ($f[0] ne 'w') # unexpected: no wire definition
	      { my $st;
	        $st= "file $filename: " if (defined $filename);
	        warn $st . "unexpected format in line-number $lineno:\n" .
	             "\"$line\"\n"; 
	        next; 
	      };


	    my $id= $f[5];
	    die if ($id=~ /^\s*$/); # assertion

	    # make wire-name unique
	    my $no;
	    for($no=0; exists $wires{"$id.$no"} ;$no++) { };
	    my $name= "$id.$no";

	    my($from_type,$from)= wire_dest($f[6]);
	    my($to_type  ,$to  )= wire_dest($f[-1]);

	    if ((!defined $from) || (!defined $to))
	      { die "line $lineno unrecognized!"; };

	    push @{$r_gl_wirelists->{$id}},$name;

	    $r_wires->{$name}->{to}  =  $to;
	    $r_wires->{$name}->{from}=  $from;
	    $r_wires->{$name}->{id}  =  $id;

            next;
	  };


	if ($segment eq 'cell use')
	  {
	    my @f= split(" ",$line);

            if ($f[0] eq 'use')
	      { # a "frame" has nothing to do with epics, ignore it:
	        next if ($f[6] eq 'frame');
248

pfeiffer's avatar
pfeiffer committed
249
250
	        $part= $f[6]; # official part-name
		die if ($part=~ /^\s*$/);
251

pfeiffer's avatar
pfeiffer committed
252
		$type= $f[1];
253

pfeiffer's avatar
pfeiffer committed
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
		# the epics-symbol type, e.g "elongouts"
		$r_struc->{$part}->{symbol_type}= $type;
		# memorize that we need to read the symbol-data file for
		# this symbol later
		$r_used_symbols->{$type}= 1;
		next;
              };

            if ($f[0] eq 'xform')
	      { next; };

            if ($f[0] eq 'p')
	      { 
		my $st= join(" ",@f[6..$#f]); # join field 6 with the rest
		my ($field,$val)=  ($st=~ /^([^:]+):(.*)/);

		next if ($field eq 'Type');
		next if ($field eq 'primitive');

		if ($field=~ /^username\(([^\)]+)\)$/)
		  { # things like $field=username(U0)  $val=LOPR
		    $aliases{$part}->{$1}= $val;
		    next;
		  }
278

pfeiffer's avatar
pfeiffer committed
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
		$r_struc->{$part}->{$field}= $val;
		next;
	      };

	  };

	}; # while       

    if (defined $filename)
      { close(F) || die "unable to close $filename\n"; };

  }

sub wire_dest
  { my($field)= @_;
294

pfeiffer's avatar
pfeiffer committed
295
296
297
298
299
300
301
302
303
    return(undef,$field) if ($field eq 'junction');
    return(undef,$field) if ($field eq 'free');
    return($field =~ /^([^\.]+)\.(.*)/);
  }   

# resolving --------------------------------------

sub resolve_aliases
  { my($r_aliases,$r_wires)= @_;
304

pfeiffer's avatar
pfeiffer committed
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
    foreach my $wire (keys %$r_wires)
    # ^^^ test each wire
      { my $r_wire= $r_wires->{$wire};
        foreach my $tag ('from','to')
        # ^^^ do it for the 'from' and the 'to' tag
          { 
	    if (exists $r_wire->{$tag})
	    # ^^^ if the tag exists
              { 
	        my($rec,$field)= ($r_wire->{$tag} =~ /^([^\.]+)\.(.+)/);
		# ^^^ extract record and field-name
		if (defined $field)
		# ^^^ if they were found, then...
		  { my $alias= $r_aliases->{$rec}->{$field};
		    # ^^^ lookup the alias (if it exists)
	            $r_wire->{$tag}= "$rec.$alias" if (defined $alias);
		    # ^^^ change the field-name, if an alias exists
		  };
	      };
          };
      };	 
  }

sub resolve_wires
  { my($r_wires,$r_fields)= @_;
330

pfeiffer's avatar
pfeiffer committed
331
332
333
334
335
336
    # foreach wire definition:
    foreach my $key (keys %$r_wires)
      { 
	# extract the "to" and "from" field:
	my $from= $r_wires->{$key}->{from};
	my $to  = $r_wires->{$key}->{to};
337

pfeiffer's avatar
pfeiffer committed
338
339
340
341
342
343
344
345
346
347
348
349
	# do nothing if $to or $from is equal to 'free':
	next if (($from eq 'free') || ($to eq 'free'));

	# in the "connections" list of the field, add the 
	# other connected field:
	push @{ $r_fields->{$from}->{connections} }, $to;
	push @{ $r_fields->{$to}  ->{connections} }, $from;
      };
  }

sub resolve_junctions
  { my($r_nodelist, $r_wires)= @_;
350

pfeiffer's avatar
pfeiffer committed
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
    # foreach global wire-key
    foreach my $gkey (keys %$r_nodelist)
      { 
        # take a reference to the list of wires for that global wire-key:
        my $r_wlist= $r_nodelist->{$gkey};

	# do nothing, if there is only one wire in the set:
	next if ($#$r_wlist==0); # not a junction

        my $junction_found;
	my $count;

	# now collect all connected fields (nodes):    
	my @nodelist;
	foreach my $wire (@$r_wlist)
	  { $count++;
	    foreach my $st ($r_wires->{$wire}->{from},$r_wires->{$wire}->{to})
	      { next if ($st eq 'free');
	        if ($st eq 'junction')
		  { $junction_found=1;
		    next;
		  };
		# if it's not 'junction' or 'free' :
		push @nodelist, $st; 
              };
	    # now remove the wire
	    delete $r_wires->{$wire};
	  };

	if (!$junction_found)
	  { print_junction_error('junction',$gkey,$count); }; # fatal
382

pfeiffer's avatar
pfeiffer committed
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
	my $count=0;
	# re-create the wires, so that all fields are connected to each
	# other with a direct wire:

	while($#nodelist>0)
	  { my $first= shift(@nodelist);
            foreach my $n (@nodelist)
	      { my $name= $gkey . '.' . ($count++);
		$r_wires->{$name}->{from}=  $first;
		$r_wires->{$name}->{to}  =  $n;
	      };
	  };	  
      };


  }


sub resolve_connections
# look at the list of connections in the "fields" array and 
# put the appropriate values in the field of the corresponding record
  { my($r_struc, $r_fields) = @_;
405

pfeiffer's avatar
pfeiffer committed
406
407
    foreach my $key (keys %$r_fields)
      { 
408

pfeiffer's avatar
pfeiffer committed
409
410
	my($recname,$field)= ($key=~ /^([^\.]+)\.(.*)/); 
	next if (!defined $field);
411

pfeiffer's avatar
pfeiffer committed
412
413
414
	# get the record field-definitions (a hash-reference):
	my $rec_data= $r_struc->{$recname};
	next if (!defined $rec_data);
415

pfeiffer's avatar
pfeiffer committed
416
417
418
419
420
421
        # this is the record-type:
	my $rec_type= $rec_data->{type};

        # this is the symbol-type:
	my $sym_type= $rec_data->{symbol_type};

422
	next if (!exists $r_rec_linkable_fields->{$sym_type}->{$field});
pfeiffer's avatar
pfeiffer committed
423
424
425
426
427
428
	# ^^^ things like: "BaseCmdCalc.VAL" connected to 
	#     BaseCmdSel.INPC
	# a link-entry cannot be put to the "VAL" field

        next if (!exists $r_fields->{$key}->{connections});
	# ^^^ the field has no connection-entries at all
429

pfeiffer's avatar
pfeiffer committed
430
431
432
433
434
435
436
437
	my @conn= @{$r_fields->{$key}->{connections}};
	# ^^^ the list with all other fields connected to THIS field ($key)

	my($pv,$conn,$conn_type);

	foreach my $c (@conn)
	# scan the list of possible connections, only one is the REAL one
	  { 
438

pfeiffer's avatar
pfeiffer committed
439
440
441
442
            my($cname,$cfield)= ($c=~ /^([^\.]+)\.(.*)/); 

	    next if (!defined $cfield);
	    # ^^^ next if the "AAA.BBB" naming scheme is not found
443
444


pfeiffer's avatar
pfeiffer committed
445
446
447
	    next if (!exists $r_struc->{$cname});
	    # otherwise the following statement would CREATE a
	    # hash-entry if there is not already one
448

pfeiffer's avatar
pfeiffer committed
449
450
451
452
453
454
	    # this is the record-type:
	    my $c_type= $r_struc->{$cname}->{type};

            # this is the symbol-type:
	    my $c_sym_type= $r_struc->{$cname}->{symbol_type};

455
	    next if (exists $r_rec_linkable_fields->{$c_sym_type}->{$cfield});
pfeiffer's avatar
pfeiffer committed
456
457
	    # ^^^ ignore linkable fields where we cannot put an
	    # link-entry into
458

pfeiffer's avatar
pfeiffer committed
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
	    if (defined $conn) # assertion, shouldn't happen ! 
	      { # after testing all possible connections, exactly one REAL
	        # connection should be found
		print_junction_error('many_ports',$recname,$field);
		# fatal error here 
	      }; 


	    # store "PV" field:
	    $pv= $r_struc->{$cname}->{PV};
	    $conn= $c;
	    $conn_type= $c_sym_type;
	  }; # foreach

        # now: connection is in $conn, PV-field content in $pv


	# if $conn is empty, just put the "" string into the 
	# field of the record and proceed with the next
	if ($conn=~ /^\s*$/)
	  { $rec_data->{$field}= ""; 
	    next;
	  };

        # hwin and hwout must be handled separately:
	if (($conn_type eq 'hwin') || ($conn_type eq 'hwout'))
	  { 
	    my($cname,$cfield)= ($conn=~ /^([^\.]+)\.(.*)/); 

	    my $key= 'val(' . $cfield . ')';
	    # ^^^ $key is usually 'val(in)' or 'val(outp)'
490

pfeiffer's avatar
pfeiffer committed
491
492
493
	    my $val= $r_struc->{$cname}->{$key};
	    if (!defined $val)
	      { # if not specified, take the default value:
494
	        $val= $r_rec_defaults->{$conn_type}->{$key}; 
pfeiffer's avatar
pfeiffer committed
495
	      };
496

pfeiffer's avatar
pfeiffer committed
497
498
499
500
501
502
503
504
505
            # store the value in the field:
	    $rec_data->{$field}= $val;
	    # just in case, delete any "def().." entries, these are 
	    # overwritten by the hwout - link:
	    delete $rec_data->{"def($field)"};

	  }
	else
	  { # it's no "hwout" and no "hwin":
506

pfeiffer's avatar
pfeiffer committed
507
	    # pproc and palrm defaults:
508

pfeiffer's avatar
pfeiffer committed
509
510
            my $proc;
	    my $alrm;
511

pfeiffer's avatar
pfeiffer committed
512
513
            # now take the link default-properties from the 
	    # rec_linkable_fields hash:
514
	    my $r_link_defaults= $r_rec_linkable_fields->{$sym_type}->{$field};
pfeiffer's avatar
pfeiffer committed
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
	    if (defined $r_link_defaults)
	      { $proc= $r_link_defaults->{proc};
	        $alrm= $r_link_defaults->{alrm};
	      };	

	    # read pproc, if defined, and overwrite $proc:
	    my $st= "pproc($field)";
	    if (exists $rec_data->{$st})
	      { $proc= $rec_data->{$st}; 
	        delete $rec_data->{$st}; 
	      };
	    # read palrm, if defined, and overwrite $alrm:
	    my $st= "palrm($field)";
	    if (exists $rec_data->{$st})
	      { $alrm= $rec_data->{$st}; 
		delete $rec_data->{$st}; 
	      };
532

pfeiffer's avatar
pfeiffer committed
533
534
535
536
537
538
539
540
541
542
543
544
	    # ensure that $conn ends with a space:  
            if ($conn!~ /\s$/)
	      { $conn.= ' '; };

	    # prepend "." to $proc and $alrm, if defined:
	    $proc= ".$proc" if (defined($proc));
	    $alrm= ".$alrm" if (defined($alrm));


	    # if field is not FLNK, LNK or pproc or palrm was defined: 
	    # add $proc and $alrm
	    $conn.= $proc if (defined($proc)); 
545

pfeiffer's avatar
pfeiffer committed
546
	    $conn.= $alrm if (defined($alrm));
547

pfeiffer's avatar
pfeiffer committed
548
549
550
551
552
553
554
555
556
557
558
559
560
561
            # finally, store the link to the field $field within
	    # the record
	    $rec_data->{$field}= "$pv$conn"; 

	    # delete a "def" definition for the field, if it exists
	    delete $rec_data->{"def($field)"}; # if it exists!
	  };

      };
  }

# printing ---------------------------------------

sub db_prepare
pfeiffer's avatar
pfeiffer committed
562
  { my($in_file,$filename, $r_h, $name_to_desc, $var_to_desc)= @_;
pfeiffer's avatar
pfeiffer committed
563
    my($r_rec,$sym_type);
564

pfeiffer's avatar
pfeiffer committed
565
    my $prefix;
566

pfeiffer's avatar
pfeiffer committed
567
568
569
570
571
572
    if (defined $in_file)
      { $prefix= $in_file;
	$prefix=~ s/^.*\///;
	$prefix=~ s/\..*?$//;
	$prefix.= ':';
      };
573

pfeiffer's avatar
pfeiffer committed
574
575
576
577
578
579
580
581
582
583
    foreach my $recname (keys %$r_h)
      { 
        # handle macros in record-names:
	if ($recname=~ /VAR\(/)
	  { my $old= $recname;
	    $recname=~ s/VAR\(([^\)]*)\)/\$\($1\)/g;
            $r_h->{$recname}= $r_h->{$old};
	    delete $r_h->{$old};
	  };  

584

pfeiffer's avatar
pfeiffer committed
585
586
587
588
589
590
591
592
        $r_rec= $r_h->{$recname};
        $sym_type= $r_rec->{symbol_type};

        # delete hwin- and hwout entries:
	if (($sym_type eq 'hwin') || ($sym_type eq 'hwout'))
          { delete $r_h->{$recname};
	    next;
	  }; 
593

pfeiffer's avatar
pfeiffer committed
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
        handle_misc($r_rec,$recname);	
        handle_defaults($r_rec,$sym_type);

	my $pv= $r_rec->{PV};
	if (defined $pv)
	  { $r_rec->{name} = $pv . $recname;
	    delete $r_rec->{PV};
	  }
	else
	  { if (defined $prefix)
	      { $r_rec->{name} = $prefix . $recname; }
	    else
	      { my $r= $recname;
	        $r=~ s/\$\(([^\)]*)\)/VAR\($1\)/g;
	        warn "\"PV\" not defined in record \"$r\"," .
	             "this is incompatible with pipe-mode\n" .
		     "since I need to know the NAME of the input-file " .
		     "in this case.\n";
		$r_rec->{name}= $recname;
	      };
	  };      	     
615
616
	if ($name_to_desc)
	  { $r_rec->{DESC}= $r_rec->{name};
pfeiffer's avatar
pfeiffer committed
617
618
	    # quote dollar-signs in order to
	    # leave them unchanged:
pfeiffer's avatar
pfeiffer committed
619
	    $r_rec->{DESC}=~ s/\$/VAR/g;
pfeiffer's avatar
pfeiffer committed
620
621
	  };
	if ($var_to_desc)        
pfeiffer's avatar
pfeiffer committed
622
	  { $r_rec->{DESC}= '$(DESCVAR)'; }
623

pfeiffer's avatar
pfeiffer committed
624
625
626
627
628
629
      };	
  }  

sub db_print 
  { my($filename, $r_h)= @_;
    local *F;
630

pfeiffer's avatar
pfeiffer committed
631
632
633
634
635
    my $oldfh;
    if (defined $filename)
      { open(F,">$filename") || die "unable to write to $filename\n"; 
        $oldfh= select(F);
      };
636

pfeiffer's avatar
pfeiffer committed
637
638
639
    foreach my $recname (sort keys %$r_h)
      { 
        my $r_rec= $r_h->{$recname};
640

pfeiffer's avatar
pfeiffer committed
641
642
643
644
645
	print  "record(",$r_rec->{type},",\"",$r_rec->{name},"\") {\n";
	foreach my $f (sort keys %$r_rec)
	  { next if ($f eq 'type');
	    next if ($f eq 'symbol_type');
	    next if ($f eq 'name');
646

pfeiffer's avatar
pfeiffer committed
647
648
649
650
651
652
653
	    print  "    field($f,\"",$r_rec->{$f},"\")\n";
	  };
	print  "}\n";  
      };
    if (defined $filename)
      { select($oldfh);
        close(F) || die "unable to close $filename\n"; 
654

pfeiffer's avatar
pfeiffer committed
655
656
657
      };
  }  

658

pfeiffer's avatar
pfeiffer committed
659
660
661
sub handle_misc
  { my($r_rec,$recname)= @_;

662
    my $recdef= $r_rec_defaults->{$r_rec->{symbol_type}};
pfeiffer's avatar
pfeiffer committed
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679

    foreach my $key (keys %$r_rec)
      { # replace VAR(...) with $(...)

        if ($r_rec->{$key} =~ /\$\(/)
	  { my $st= 'warning:';
   	    $st.= " file \"$opt_file\"," if (defined $opt_file);
     	    $st.= " record \"$recname\": \n";
	    $st.= "possibly wrong field definition: \n";
	    $st.= "  \"$key = $r_rec->{$key}\"\n";
	    $st.= "use VAR(...) instead of \$(...) otherwise sch2edif " .
		  "ignores this \nfield definition\n\n";
	    warn($st);
	    next;
	  };

        $r_rec->{$key}=~ s/VAR\(([^\)]*)\)/\$\($1\)/g;
680

pfeiffer's avatar
pfeiffer committed
681
682
683
684
685
        if ($key=~/^def\(([^\)]+)\)/)
          { $r_rec->{$1}= $r_rec->{$key};
	    delete $r_rec->{$key};
            next;
	  }; 
686

pfeiffer's avatar
pfeiffer committed
687
	$r_rec->{$key}=~ s/\.SLNK\b/\.VAL/;
688

pfeiffer's avatar
pfeiffer committed
689
690
691
692
693
694
695
696
	if ($key =~ /^(typ|username)\(/)
          { delete $r_rec->{$key}; next;	  
	  };
	if ($key=~ /^(pproc|palrm)\(/)
          { delete $r_rec->{$key}; next; 	  
	  };

        next if (!defined $opt_warn_miss);
697

pfeiffer's avatar
pfeiffer committed
698
699
700
701
702
703
	# check for fields that are missing in the definitions in the
	# record's symbol file:

        # skip the 2 special fields 'PV' and 'symbol_type':	
        next if ($key eq 'PV');
        next if ($key eq 'symbol_type');
704

pfeiffer's avatar
pfeiffer committed
705
706
707
708
709
710
711
712
713
	next if (exists $recdef->{$key});
	if ($opt_warn_miss!=2)
	  { my $st= 'warning:';
	    $st.= " file \"$opt_file\"," if (defined $opt_file);
	    $st.= " record \"$recname\": \n";
	    $st.= "field $key is not defined in the symbol-file ";
	    $st.= $r_rec->{symbol_type} . ".sym\n\n";
	    warn($st); 
	  };
714

pfeiffer's avatar
pfeiffer committed
715
716
	if ($opt_warn_miss>0)
	  { delete $r_rec->{$key}; };
717

pfeiffer's avatar
pfeiffer committed
718
719
720
721
722
723
      };
  };

sub handle_defaults
  { my($r_rec,$sym_type)= @_;

724
    my $r_def= $r_rec_defaults->{$sym_type};
pfeiffer's avatar
pfeiffer committed
725
    return if (!defined $r_def);
726

pfeiffer's avatar
pfeiffer committed
727
728
729
730
731
    if (defined $opt_no_defaults)
      { # just take the default for 'type':
        $r_rec->{type}= $r_def->{type} if (!exists $r_rec->{type});
	return;
      };
732

pfeiffer's avatar
pfeiffer committed
733
734
735
736
737
738
739
740
741
742
743
    foreach my $field (keys %$r_def)
      { $r_rec->{$field}= $r_def->{$field} if (!exists $r_rec->{$field});
      };
  };


# scan symbol files ---------------------------------------

sub scan_symbols
  { my($path,$r_defaults,$r_link_defaults,@symbol_list)= @_;
    # if symbol-list is empty, scan all 
744

pfeiffer's avatar
pfeiffer committed
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
    if (!-d $path)
      { die "error: \"$path\" is not a directory\n"; };

    my @files;
    if ($#symbol_list < 0)
      { @files= glob("$path/*.sym"); 
        if ($#files<0)
          { die "error: no symbol files found in \"$path\"\n"; };
      }
    else
      { my $p;
        foreach my $sym (@symbol_list)
          { $p= "$path/$sym.sym";
	    if (-r $p)
              { push @files,$p;
	      }
	    else
Pfeiffer, Götz's avatar
Pfeiffer, Götz committed
762
	      { warn "Warning: no symbol data found for \"$sym\""; };
pfeiffer's avatar
pfeiffer committed
763
764
	  };    
      };
765

pfeiffer's avatar
pfeiffer committed
766
767
768
769
770
    foreach my $file (@files)
      { 
        scan_sym_file($file,$r_defaults,$r_link_defaults);
      };
  }
771
772
773



pfeiffer's avatar
pfeiffer committed
774
775
776
777
sub scan_sym_file
  { my($file,$r_defaults,$r_link_defaults)= @_;
    local *F;
    my $emsg= "warning: symbol-file $file, double entry:\n";
778

pfeiffer's avatar
pfeiffer committed
779
780
781
    my $symname= basename($file);
    $symname=~ s/^(.*)\..*$/$1/;

782

pfeiffer's avatar
pfeiffer committed
783
784
    if (!exists $r_defaults->{$symname})
      { $r_defaults->{$symname}= {}; };
785
    my $r_my_rec_defaults= $r_defaults->{$symname};
786

pfeiffer's avatar
pfeiffer committed
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
    if (!exists $r_link_defaults->{$symname})
      { $r_link_defaults->{$symname}= {}; };
    my $r_rec_link_defaults= $r_link_defaults->{$symname};

    my $segment;
    my $lineno=0;

    open(F, $file) || die;
    my $line;
    my $st;
    my ($flag,$field,$val);
    while($line= <F>)
      { $lineno++;

	if ($line=~ /^\[([^\]]+)\]/)
          { $segment= $1; next; };
803

pfeiffer's avatar
pfeiffer committed
804
	next if ($segment ne 'attributes'); 
805

pfeiffer's avatar
pfeiffer committed
806
807
808
        # here we are in the "attributes" section	

	# chomp($line);
809

pfeiffer's avatar
pfeiffer committed
810
811
812
813
814
	($flag,$field,$val)= 
	       ($line=~ /(\S+)\s+                       # 1st character
	                 \S+\s+\S+\s+\S+\s+\S+\s+\S+\s+ # 5 dummies 
	                 ([^:]+):(.*)
		        /x);
815

pfeiffer's avatar
pfeiffer committed
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831

        if ($flag ne 'p')
	  { 
	    # warn "warning: $file: line $lineno has an unknown format";
	    next;
	  };

	next if ($field eq 'primitive');
	# what is 'gensubA..D ??? 
	next if ($field eq 'name');

	$val= "" if (!defined $val);

	if ($field eq 'Type')
	  { # store the EPICS record-type:
	    if ($opt_warn_double)
832
833
	      { warn $emsg . "Type\n\n" if (exists $r_my_rec_defaults->{type}); };
	    $r_my_rec_defaults->{type}= $val;
pfeiffer's avatar
pfeiffer committed
834
835
836
837
838
839
840
841
842
843
	    # ^^^ this is put later into the record by handle_defaults() 
	    next;
	  };

	if ($field =~ /(\w+)\(([^\)]+)\)/)
	  { if ($1 eq 'val')
	      { # store things like "val(outp):#C0 S0" as they are
	        # found in hwout.sym and hwin.sym:
	        if ($opt_warn_double)
		  { warn $emsg . "$field\n\n" 
844
		         if (exists $r_my_rec_defaults->{$field});
pfeiffer's avatar
pfeiffer committed
845
		  };	
846
	        $r_my_rec_defaults->{$field} = $val;
pfeiffer's avatar
pfeiffer committed
847
848
	        next;
              };
849

pfeiffer's avatar
pfeiffer committed
850
851
852
853
854
855
	    if ($1 eq 'typ')
	      { next if ($val ne 'path');
	        $r_rec_link_defaults->{$2}->{dummy} = 1; 
		next;
	      };
            if ($1 eq 'def')
856
	      { $r_my_rec_defaults->{$2}= $val; 
pfeiffer's avatar
pfeiffer committed
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
	        next;
	      };
            if ($1 eq 'pproc')
	      { $r_rec_link_defaults->{$2}->{proc}= $val; 
	        next;
	      };
            if ($1 eq 'palrm')
	      { $r_rec_link_defaults->{$2}->{alrm}= $val; 
	        next;
	      };
	    next;
	  };

	if ($opt_warn_double)
	  { warn $emsg . "$field\n\n" 
872
	         if (exists $r_my_rec_defaults->{$field});
pfeiffer's avatar
pfeiffer committed
873
	  };	 
874
	$r_my_rec_defaults->{$field}= $val; 
pfeiffer's avatar
pfeiffer committed
875
876
877
878
879
880
881
882
883
884
885

      };
    close(F);
  }

# debugging---------------------------------------

sub hdump
  { my($message,$hash_name,$r_h)= @_;
    my $st= "contents of hash \"$hash_name\":";
    my $ul= '_' x length($st);
886

pfeiffer's avatar
pfeiffer committed
887
888
889
890
891
    print "=" x 70,"\n";
    printf("%-12s%s\n","comment:",$message);
    print "-" x 70,"\n";
    printf("%-12s%s\n","hash:",$hash_name);
    print "-" x 70,"\n\n";
892
893


pfeiffer's avatar
pfeiffer committed
894
895
896
897
898
899
    print_meta_hash($r_h);
    print "=" x 70,"\n";
  }  

sub print_meta_hash
  { my($r_h)= @_;
900

pfeiffer's avatar
pfeiffer committed
901
902
903
904
905
906
    foreach my $key (sort keys %$r_h)
      { my $val= $r_h->{$key};
	if (!ref($val))
	  { print $key,'=>',$val,"\n"; 
	    next;
	  };
907

pfeiffer's avatar
pfeiffer committed
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
        if (ref($val) eq 'ARRAY')
	  { print "$key",'=> [',join(",",@$val),"]\n";
	    next;
	  };

        if (ref($val) eq 'HASH')
          { print "$key:\n---------------------\n";
	    print_hash( $val );
	    print "\n";
	    next;
	  };
	die "unsupported reference-type:" . ref($val) . "!";
      };
  }  


sub print_hash
  { my($r_h)= @_;
926

pfeiffer's avatar
pfeiffer committed
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
    foreach my $key (sort keys %$r_h)
      { my $val= $r_h->{$key};
        print "$key: ";
	if (!ref($val))
	  { print "$val\n"; next; }
	if (ref($val) eq 'ARRAY')
	  { print join("|",@$val),"\n"; next; };
	if (ref($val) eq 'HASH')
	  { foreach my $k (sort keys %$val)
	      { print $k,'=>',$val->{$k},' '; };
	    print "\n";
	    next;
	  }
	else
	  { die "unsupported ref encountered !"; };
      };
  };    

sub print_junction_error
  { my($type) = shift;
947

pfeiffer's avatar
pfeiffer committed
948
949
    my($wire,$count  )= (@_[0..1]);
    my($record,$field)= (@_[0..1]);
950

pfeiffer's avatar
pfeiffer committed
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
    my $p= $0;
    $p=~ s/.*?([^\/]+)$/$1/;
    my $file= (defined $opt_file) ? " in file \"$opt_file\"" : "";

    my $error_junction= <<END
Error with wire "$wire"$file. 
There is more than one wire with this name ($count to be exact) 
although they do not seem to belong to a junction. 
END
;

    my $error_many_ports= <<END
Error in field "$record.$field"$file.
There was more that one possible input-port found that is connected to
that output-port. A possible explanation is:
END
;    
968

pfeiffer's avatar
pfeiffer committed
969
970
971
972
973
974
975
976
977
    my $explain= <<END
Capfast sometimes produces wires that are not connected to each other 
but do have the same name. You have to rename these wires to have a unique 
name for each of them. You can do this by two ways:

1) edit the capfast (*.sch) file
   Look for "[detail]", then search for all occurences of the wire-name in 
   this section. Replace the number in the wire-name with a new, unique 
   number. 
978

pfeiffer's avatar
pfeiffer committed
979
980
981
982
983
984
2) using capfast
   select the wire, then select "text" and "relabel" and give the 
   wire a new name. The name should always be something like "n#xxxx" where 
   'xxxx' is a new, unique number. 
END
;
985

pfeiffer's avatar
pfeiffer committed
986
987
    if ($type eq 'many_ports')
      { die $error_many_ports . $explain; };
988

pfeiffer's avatar
pfeiffer committed
989
990
    if ($type eq 'junction')
      { die $error_junction . $explain; };
991

pfeiffer's avatar
pfeiffer committed
992
993
    die; # perl shouldn't reach this place
  }   
994

pfeiffer's avatar
pfeiffer committed
995
996
997
998
999
1000
sub print_summary
  { my($p)= ($0=~ /([^\/\\]+)$/);
    printf("%-20s: a better sch to db converter\n",$p);
  }

sub print_help
For faster browsing, not all history is shown. View entire blame