Merge lp:~anj/epics-base/compiled-dbd into lp:~epics-core/epics-base/3.15

Proposed by Andrew Johnson on 2012-03-14
Status: Merged
Merged at revision: 12271
Proposed branch: lp:~anj/epics-base/compiled-dbd
Merge into: lp:~epics-core/epics-base/3.15
Diff against target: 4157 lines (+3010/-686) (has conflicts)
43 files modified
configure/CONFIG_BASE (+4/-4)
configure/RULES.Db (+45/-5)
src/Makefile (+3/-0)
src/ioc/db/RULES (+8/-0)
src/ioc/db/dbCommon.dbd (+10/-10)
src/ioc/dbStatic/Makefile (+1/-17)
src/ioc/dbStatic/dbReadTest.c (+0/-90)
src/ioc/dbStatic/dbToMenuH.c (+0/-124)
src/ioc/dbStatic/dbToRecordtypeH.c (+0/-267)
src/ioc/registry/registerRecordDeviceDriver.pl (+167/-168)
src/tools/DBD.pm (+81/-0)
src/tools/DBD/Base.pm (+127/-0)
src/tools/DBD/Breaktable.pm (+32/-0)
src/tools/DBD/Device.pm (+45/-0)
src/tools/DBD/Driver.pm (+9/-0)
src/tools/DBD/Function.pm (+10/-0)
src/tools/DBD/Menu.pm (+66/-0)
src/tools/DBD/Output.pm (+98/-0)
src/tools/DBD/Parser.pm (+197/-0)
src/tools/DBD/Recfield.pm (+436/-0)
src/tools/DBD/Recordtype.pm (+100/-0)
src/tools/DBD/Registrar.pm (+11/-0)
src/tools/DBD/Variable.pm (+36/-0)
src/tools/EPICS/Readfile.pm (+101/-0)
src/tools/EPICS/macLib.pm (+251/-0)
src/tools/Makefile (+22/-1)
src/tools/dbdExpand.pl (+53/-0)
src/tools/dbdReport.pl (+64/-0)
src/tools/dbdToHtml.pl (+252/-0)
src/tools/dbdToMenuH.pl (+80/-0)
src/tools/dbdToRecordtypeH.pl (+231/-0)
src/tools/test/Breaktable.plt (+22/-0)
src/tools/test/DBD.plt (+60/-0)
src/tools/test/Device.plt (+33/-0)
src/tools/test/Driver.plt (+13/-0)
src/tools/test/Function.plt (+13/-0)
src/tools/test/Makefile (+26/-0)
src/tools/test/Menu.plt (+32/-0)
src/tools/test/Recfield.plt (+114/-0)
src/tools/test/Recordtype.plt (+57/-0)
src/tools/test/Registrar.plt (+13/-0)
src/tools/test/Variable.plt (+15/-0)
src/tools/test/macLib.plt (+72/-0)
Text conflict in configure/RULES.Db
Text conflict in src/ioc/db/RULES
Contents conflict in src/ioc/dbStatic/dbExpand.c
To merge this branch: bzr merge lp:~anj/epics-base/compiled-dbd
Reviewer Review Type Date Requested Status
Andrew Johnson Approve on 2012-04-04
Review via email: mp+97525@code.launchpad.net

Description of the change

This branch replaces the dbToMenuH, dbToRecordH and dbExpand programs with Perl versions that perform the same functionality but don't have to be compiled first. This fixes a dependency problem we're having at the moment with parallel builds on the 3.15 branch. The underlying Perl technology will also allow other improvements in DBD file handling, including eventually removing the need for the IOC load a DBD file, although that will need more work.

This also fixes the issue of someone using field names in a record type that happen to be C or C++ keywords.

I have not tested this code on Windows yet.

To post a comment you must log in.
lp:~anj/epics-base/compiled-dbd updated on 2012-04-02
12285. By Andrew Johnson on 2012-03-27

Convert registerRecordDeviceDriver.pl to use DBD module.

The output is now a bit more compact as it uses Text::Wrap on
the declarations and array data.

12286. By Andrew Johnson on 2012-03-28

Use the new DBD processing scripts to generate dependency files.

12287. By Andrew Johnson on 2012-04-02

configure: Clean up some other DBDEPENDS stuff

Andrew Johnson (anj) wrote :

I'm planning to merge this branch into the main trunk (3.15 series) very soon. It needs a little bit of work to merge cleanly, but I'll do that at the time.

- Andrew

Andrew Johnson (anj) :
review: Approve

Preview Diff

[H/L] Next/Prev Comment, [J/K] Next/Prev File, [N/P] Next/Prev Hunk
1=== modified file 'configure/CONFIG_BASE'
2--- configure/CONFIG_BASE 2011-02-27 00:24:51 +0000
3+++ configure/CONFIG_BASE 2012-04-02 20:38:19 +0000
4@@ -57,11 +57,11 @@
5 # Epics base build tools and tool flags
6
7 MAKEBPT = $(call PATH_FILTER, $(TOOLS)/makeBpt$(HOSTEXE))
8-DBEXPAND = $(call PATH_FILTER, $(TOOLS)/dbExpand$(HOSTEXE))
9-DBTORECORDTYPEH = $(call PATH_FILTER, $(TOOLS)/dbToRecordtypeH$(HOSTEXE))
10-DBTOMENUH = $(call PATH_FILTER, $(TOOLS)/dbToMenuH$(HOSTEXE))
11+DBEXPAND = $(PERL) $(TOOLS)/dbdExpand.pl
12+DBTORECORDTYPEH = $(PERL) $(TOOLS)/dbdToRecordtypeH.pl
13+DBTOMENUH = $(PERL) $(TOOLS)/dbdToMenuH.pl
14 REGISTERRECORDDEVICEDRIVER = $(PERL) $(TOOLS)/registerRecordDeviceDriver.pl
15-CONVERTRELEASE=$(PERL) $(TOOLS)/convertRelease.pl
16+CONVERTRELEASE = $(PERL) $(TOOLS)/convertRelease.pl
17
18 #-------------------------------------------------------
19 # tools for installing libraries and products
20
21=== modified file 'configure/RULES.Db'
22--- configure/RULES.Db 2012-04-02 20:36:02 +0000
23+++ configure/RULES.Db 2012-04-02 20:38:19 +0000
24@@ -112,9 +112,6 @@
25 $(patsubst $(COMMON_DIR)/%,%,$(COMMON_DBS)) \
26 $(patsubst $(COMMON_DIR)/%,%,$(COMMON_DBDS)))
27
28-DBDDEPENDS_FLAGS = $(subst -I,,$(filter-out -S%,$(DBDFLAGS)))
29-DBDDEPENDS_CMD = -$(MKMF) -m $(notdir $@)$(DEP) $(DBDDEPENDS_FLAGS) $@ $<
30-
31 MAKEDBDEPENDS = $(PERL) $(TOOLS)/makeDbDepends.pl
32
33 #####################################################
34@@ -226,35 +223,63 @@
35
36 $(COMMON_DIR)/%Record.h: $(COMMON_DIR)/%Record.dbd
37 @$(RM) $(notdir $@)$(DEP)
38+<<<<<<< TREE
39 @$(DBDDEPENDS_CMD)
40 echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
41 @$(RM) $(notdir $@)
42 $(DBTORECORDTYPEH) $(DBDFLAGS) $< $(notdir $@)
43 @$(MV) $(notdir $@) $@
44+=======
45+ @$(DBTORECORDTYPEH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
46+ @echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
47+ @$(RM) $@
48+ $(DBTORECORDTYPEH) $(DBDFLAGS) -o $@ $<
49+>>>>>>> MERGE-SOURCE
50
51 $(COMMON_DIR)/%Record.h: %Record.dbd
52 @$(RM) $(notdir $@)$(DEP)
53+<<<<<<< TREE
54 @$(DBDDEPENDS_CMD)
55 echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
56 @$(RM) $(notdir $@)
57 $(DBTORECORDTYPEH) $(DBDFLAGS) $< $(notdir $@)
58 @$(MV) $(notdir $@) $@
59+=======
60+ @$(DBTORECORDTYPEH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
61+ @echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
62+ @$(RM) $@
63+ $(DBTORECORDTYPEH) $(DBDFLAGS) -o $@ $<
64+>>>>>>> MERGE-SOURCE
65
66 $(COMMON_DIR)/menu%.h: $(COMMON_DIR)/menu%.dbd
67 @$(RM) $(notdir $@)$(DEP)
68+<<<<<<< TREE
69 @$(DBDDEPENDS_CMD)
70 echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
71 @$(RM) $(notdir $@)
72 $(DBTOMENUH) $(DBDFLAGS) $< $(notdir $@)
73 @$(MV) $(notdir $@) $@
74+=======
75+ @$(DBTOMENUH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
76+ @echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
77+ @$(RM) $@
78+ $(DBTOMENUH) $(DBDFLAGS) -o $@ $<
79+>>>>>>> MERGE-SOURCE
80
81 $(COMMON_DIR)/menu%.h: menu%.dbd
82 @$(RM) $(notdir $@)$(DEP)
83+<<<<<<< TREE
84 @$(DBDDEPENDS_CMD)
85 echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
86 @$(RM) $(notdir $@)
87 $(DBTOMENUH) $(DBDFLAGS) $< $(notdir $@)
88 @$(MV) $(notdir $@) $@
89+=======
90+ @$(DBTOMENUH) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
91+ @echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
92+ @$(RM) $@
93+ $(DBTOMENUH) $(DBDFLAGS) -o $@ $<
94+>>>>>>> MERGE-SOURCE
95
96 .PRECIOUS: $(COMMON_DIR)/%.h
97
98@@ -264,10 +289,15 @@
99 $(MAKEBPT) $< $(notdir $@)
100 @$(MV) $(notdir $@) $@
101
102-$(COMMON_DIR)/%.dbd: $(COMMON_DIR)/%Include.dbd
103+$(COMMON_DIR)/%.dbd: $(COMMON_DIR)/%Include.dbd
104 @$(RM) $(notdir $@)$(DEP)
105+<<<<<<< TREE
106 @$(DBDDEPENDS_CMD)
107 echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
108+=======
109+ @$(DBEXPAND) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
110+ @echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
111+>>>>>>> MERGE-SOURCE
112 $(ECHO) "Expanding dbd"
113 @$(RM) $(notdir $@)
114 @$(DBEXPAND) $(DBDFLAGS) -o $(notdir $@) $<
115@@ -275,8 +305,13 @@
116
117 $(COMMON_DIR)/%.dbd: %Include.dbd
118 @$(RM) $(notdir $@)$(DEP)
119+<<<<<<< TREE
120 @$(DBDDEPENDS_CMD)
121 echo "$< : ../Makefile" >> $(notdir $@)$(DEP)
122+=======
123+ @$(DBEXPAND) -D $(DBDFLAGS) -o $@ $< > $(notdir $@)$(DEP)
124+ @echo "$@: ../Makefile" >> $(notdir $@)$(DEP)
125+>>>>>>> MERGE-SOURCE
126 $(ECHO) "Expanding dbd"
127 @$(RM) $(notdir $@)
128 $(DBEXPAND) $(DBDFLAGS) -o $(notdir $@) $<
129@@ -313,8 +348,13 @@
130
131 $(COMMON_DIR)/%.db$(RAW): %.substitutions
132 @$(RM) $(notdir $@)$(DEP)
133+<<<<<<< TREE
134 @$(MAKEDBDEPENDS) $@ $< $(TEMPLATE_FILENAME) >> $(notdir $@)$(DEP)
135 echo "$@ : $(TEMPLATE_FILENAME)" >> $(notdir $@)$(DEP)
136+=======
137+ $(MAKEDBDEPENDS) $@ $< $(TEMPLATE_FILENAME) > $(notdir $@)$(DEP)
138+ @echo "$@: $(TEMPLATE_FILENAME)" >> $(notdir $@)$(DEP)
139+>>>>>>> MERGE-SOURCE
140 $(ECHO) "Inflating database from $< $(TEMPLATE_FILENAME)"
141 @$(RM) $@ $*.tmp
142 $(MSI) $(DBFLAGS) -S$< $(TEMPLATE_FILENAME) > $*.tmp
143@@ -322,7 +362,7 @@
144
145 $(COMMON_DIR)/%.db$(RAW): %.template
146 @$(RM) $(notdir $@)$(DEP)
147- @$(MAKEDBDEPENDS) $@ $^ >> $(notdir $@)$(DEP)
148+ @$(MAKEDBDEPENDS) $@ $< > $(notdir $@)$(DEP)
149 $(ECHO) "Inflating database from $<"
150 @$(RM) $@ $*.tmp
151 $(MSI) $(DBFLAGS) $< > $*.tmp
152
153=== modified file 'src/Makefile'
154--- src/Makefile 2011-02-27 00:24:51 +0000
155+++ src/Makefile 2012-04-02 20:38:19 +0000
156@@ -15,6 +15,9 @@
157
158 DIRS += tools
159
160+DIRS += tools/test
161+tools/test_DEPEND_DIRS = tools
162+
163 DIRS += template/base
164 template/base_DEPEND_DIRS = tools
165
166
167=== modified file 'src/ioc/db/RULES'
168--- src/ioc/db/RULES 2011-11-15 00:25:13 +0000
169+++ src/ioc/db/RULES 2012-04-02 20:38:19 +0000
170@@ -15,6 +15,7 @@
171
172 # $(filter-out $(STATIC_SRCS),$(dbCore_SRCS)) : $(COMMON_DIR)/dbCommon.h
173
174+<<<<<<< TREE
175 dbCommon.h$(DEP): $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd
176 @$(RM) $@
177 @$(MKMF) -m $@ ../db $(COMMON_DIR)/dbCommon.h $<
178@@ -29,3 +30,10 @@
179 $(patsubst %,$(COMMON_DIR)/%.h,$(DBDINC) menuConvert menuGlobal) : \
180 $(COMMON_DIR)/%.h : $(DBTOMENUH)
181
182+=======
183+$(COMMON_DIR)/dbCommon.h: $(IOCDIR)/db/dbCommonRecord.dbd
184+ @$(RM) $(notdir $@)$(DEP)
185+ @$(DBTORECORDTYPEH) -D -I ../db -o $@ $< > $(notdir $@)$(DEP)
186+ $(RM) $@
187+ $(DBTORECORDTYPEH) -I ../db -o $@ $<
188+>>>>>>> MERGE-SOURCE
189
190=== modified file 'src/ioc/db/dbCommon.dbd'
191--- src/ioc/db/dbCommon.dbd 2009-04-23 20:35:02 +0000
192+++ src/ioc/db/dbCommon.dbd 2012-04-02 20:38:19 +0000
193@@ -82,14 +82,14 @@
194 prompt("Monitor lock")
195 special(SPC_NOMOD)
196 interest(4)
197- extra("epicsMutexId mlok")
198+ extra("epicsMutexId mlok")
199 }
200 %#include "ellLib.h"
201 field(MLIS,DBF_NOACCESS) {
202 prompt("Monitor List")
203 special(SPC_NOMOD)
204 interest(4)
205- extra("ELLLIST mlis")
206+ extra("ELLLIST mlis")
207 }
208 field(DISP,DBF_UCHAR) {
209 prompt("Disable putField")
210@@ -167,13 +167,13 @@
211 prompt("Access Security Pvt")
212 special(SPC_NOMOD)
213 interest(4)
214- extra("struct asgMember *asp")
215+ extra("struct asgMember *asp")
216 }
217 field(PPN,DBF_NOACCESS) {
218 prompt("addr of PUTNOTIFY")
219 special(SPC_NOMOD)
220 interest(4)
221- extra("struct putNotify *ppn")
222+ extra("struct putNotify *ppn")
223 }
224 field(PPNR,DBF_NOACCESS) {
225 prompt("pputNotifyRecord")
226@@ -191,19 +191,19 @@
227 prompt("Address of RSET")
228 special(SPC_NOMOD)
229 interest(4)
230- extra("struct rset *rset")
231+ extra("struct rset *rset")
232 }
233 field(DSET,DBF_NOACCESS) {
234 prompt("DSET address")
235 special(SPC_NOMOD)
236 interest(4)
237- extra("struct dset *dset")
238+ extra("struct dset *dset")
239 }
240 field(DPVT,DBF_NOACCESS) {
241 prompt("Device Private")
242 special(SPC_NOMOD)
243 interest(4)
244- extra("void *dpvt")
245+ extra("void *dpvt")
246 }
247 field(RDES,DBF_NOACCESS) {
248 prompt("Address of dbRecordType")
249@@ -215,7 +215,7 @@
250 prompt("Lock Set")
251 special(SPC_NOMOD)
252 interest(4)
253- extra("struct lockRecord *lset")
254+ extra("struct lockRecord *lset")
255 }
256 field(PRIO,DBF_MENU) {
257 prompt("Scheduling Priority")
258@@ -231,7 +231,7 @@
259 prompt("Break Point")
260 special(SPC_NOMOD)
261 interest(1)
262- extra("char bkpt")
263+ extra("char bkpt")
264 }
265 field(UDF,DBF_UCHAR) {
266 prompt("Undefined")
267@@ -245,7 +245,7 @@
268 prompt("Time")
269 special(SPC_NOMOD)
270 interest(2)
271- extra("epicsTimeStamp time")
272+ extra("epicsTimeStamp time")
273 }
274 field(FLNK,DBF_FWDLINK) {
275 prompt("Forward Process Link")
276
277=== modified file 'src/ioc/dbStatic/Makefile'
278--- src/ioc/dbStatic/Makefile 2011-09-15 19:05:05 +0000
279+++ src/ioc/dbStatic/Makefile 2012-04-02 20:38:19 +0000
280@@ -32,26 +32,10 @@
281 dbCore_SRCS += dbStaticIocRegister.c
282
283 dbStaticHost_SRCS += $(STATIC_SRCS)
284-dbStaticHost_SRCS += dbStaticNoRun.c
285+dbStaticHost_SRCS += dbStaticNoRun.c
286
287 LIBRARY_HOST += dbStaticHost
288
289 dbStaticHost_LIBS = Com
290
291-PROD_HOST += dbReadTest dbExpand dbToMenuH dbToRecordtypeH
292-
293-dbReadTest_SRCS = dbReadTest.c
294-dbExpand_SRCS = dbExpand.c
295-dbToMenuH_SRCS = dbToMenuH.c
296-dbToRecordtypeH_SRCS = dbToRecordtypeH.c
297-
298-# Include dbStaticHost objects directly in executables
299-# because of a Circular dependency induced by a rule
300-# $(INSTALL_LIBS): $(INSTALL_SHRLIBS)
301-# in RULES_BUILD
302-dbReadTest_SRCS += $(dbStaticHost_SRCS)
303-dbExpand_SRCS += $(dbStaticHost_SRCS)
304-dbToMenuH_SRCS += $(dbStaticHost_SRCS)
305-dbToRecordtypeH_SRCS += $(dbStaticHost_SRCS)
306-
307 CLEANS += dbLex.c dbYacc.c
308
309=== renamed file 'src/ioc/dbStatic/dbExpand.c' => 'src/ioc/dbStatic/dbExpand.c.THIS'
310=== removed file 'src/ioc/dbStatic/dbReadTest.c'
311--- src/ioc/dbStatic/dbReadTest.c 2004-07-08 14:43:45 +0000
312+++ src/ioc/dbStatic/dbReadTest.c 1970-01-01 00:00:00 +0000
313@@ -1,90 +0,0 @@
314-/*************************************************************************\
315-* Copyright (c) 2002 The University of Chicago, as Operator of Argonne
316-* National Laboratory.
317-* Copyright (c) 2002 The Regents of the University of California, as
318-* Operator of Los Alamos National Laboratory.
319-* EPICS BASE Versions 3.13.7
320-* and higher are distributed subject to a Software License Agreement found
321-* in file LICENSE that is included with this distribution.
322-\*************************************************************************/
323-/* dbReadTest.c */
324-/* Author: Marty Kraimer Date: 13JUL95 */
325-
326-#include <stdlib.h>
327-#include <stddef.h>
328-#include <stdio.h>
329-#include <string.h>
330-
331-#include "dbDefs.h"
332-#include "epicsPrint.h"
333-#include "errMdef.h"
334-#include "dbStaticLib.h"
335-#include "dbStaticPvt.h"
336-#include "dbBase.h"
337-#include "gpHash.h"
338-#include "osiFileName.h"
339-
340-DBBASE *pdbbase = NULL;
341-
342
343-int main(int argc,char **argv)
344-{
345- int i;
346- int strip;
347- char *path = NULL;
348- char *sub = NULL;
349- int pathLength = 0;
350- int subLength = 0;
351- char **pstr;
352- char *psep;
353- int *len;
354- long status;
355- static char *pathSep = OSI_PATH_LIST_SEPARATOR;
356- static char *subSep = ",";
357-
358- /*Look for options*/
359- if(argc<2) {
360- printf("usage: dbReadTest -Idir -Smacsub file.dbd file.db \n");
361- exit(0);
362- }
363- while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
364- if(strncmp(argv[1],"-I",2)==0) {
365- pstr = &path;
366- psep = pathSep;
367- len = &pathLength;
368- } else {
369- pstr = &sub;
370- psep = subSep;
371- len = &subLength;
372- }
373- if(strlen(argv[1])==2) {
374- dbCatString(pstr,len,argv[2],psep);
375- strip = 2;
376- } else {
377- dbCatString(pstr,len,argv[1]+2,psep);
378- strip = 1;
379- }
380- argc -= strip;
381- for(i=1; i<argc; i++) argv[i] = argv[i + strip];
382- }
383- if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
384- printf("usage: dbReadTest -Idir -Idir file.dbd file.dbd \n");
385- exit(0);
386- }
387- for(i=1; i<argc; i++) {
388- status = dbReadDatabase(&pdbbase,argv[i],path,sub);
389- if(!status) continue;
390- fprintf(stderr,"For input file %s",argv[i]);
391- errMessage(status,"from dbReadDatabase");
392- }
393-/*
394- dbDumpRecordType(pdbbase,"ai");
395- dbDumpRecordType(pdbbase,NULL);
396- dbPvdDump(pdbbase,1);
397- gphDump(pdbbase->pgpHash);
398- dbDumpMenu(pdbbase,NULL);
399- dbDumpRecord(pdbbase,NULL,0);
400- dbReportDeviceConfig(pdbbase,stdout);
401-*/
402- dbFreeBase(pdbbase);
403- return(0);
404-}
405
406=== removed file 'src/ioc/dbStatic/dbToMenuH.c'
407--- src/ioc/dbStatic/dbToMenuH.c 2008-08-05 22:48:45 +0000
408+++ src/ioc/dbStatic/dbToMenuH.c 1970-01-01 00:00:00 +0000
409@@ -1,124 +0,0 @@
410-/*************************************************************************\
411-* Copyright (c) 2002 The University of Chicago, as Operator of Argonne
412-* National Laboratory.
413-* Copyright (c) 2002 The Regents of the University of California, as
414-* Operator of Los Alamos National Laboratory.
415-* EPICS BASE Versions 3.13.7
416-* and higher are distributed subject to a Software License Agreement found
417-* in file LICENSE that is included with this distribution.
418-\*************************************************************************/
419-/* dbToMenu.c */
420-/* Author: Marty Kraimer Date: 11Sep95 */
421-#include <stdlib.h>
422-#include <stddef.h>
423-#include <stdio.h>
424-#include <string.h>
425-
426-#include "dbDefs.h"
427-#include "epicsPrint.h"
428-#include "errMdef.h"
429-#include "dbStaticLib.h"
430-#include "dbStaticPvt.h"
431-#include "dbBase.h"
432-#include "gpHash.h"
433-#include "osiFileName.h"
434-
435-DBBASE *pdbbase = NULL;
436-
437
438-int main(int argc,char **argv)
439-{
440- dbMenu *pdbMenu;
441- char *outFilename;
442- char *pext;
443- FILE *outFile;
444- char *plastSlash;
445- int i;
446- int strip;
447- char *path = NULL;
448- char *sub = NULL;
449- int pathLength = 0;
450- int subLength = 0;
451- char **pstr;
452- char *psep;
453- int *len;
454- long status;
455- static char *pathSep = OSI_PATH_LIST_SEPARATOR;
456- static char *subSep = ",";
457-
458- /*Look for options*/
459- if(argc<2) {
460- fprintf(stderr,"usage: dbToMenu -Idir -Idir file.dbd [outfile]\n");
461- exit(0);
462- }
463- while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
464- if(strncmp(argv[1],"-I",2)==0) {
465- pstr = &path;
466- psep = pathSep;
467- len = &pathLength;
468- } else {
469- pstr = &sub;
470- psep = subSep;
471- len = &subLength;
472- }
473- if(strlen(argv[1])==2) {
474- dbCatString(pstr,len,argv[2],psep);
475- strip = 2;
476- } else {
477- dbCatString(pstr,len,argv[1]+2,psep);
478- strip = 1;
479- }
480- argc -= strip;
481- for(i=1; i<argc; i++) argv[i] = argv[i + strip];
482- }
483- if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
484- fprintf(stderr,"usage: dbToMenu -Idir -Idir file.dbd [outfile]\n");
485- exit(0);
486- }
487- if (argc==2) {
488- /*remove path so that outFile is created where program is executed*/
489- plastSlash = strrchr(argv[1],'/');
490- if(!plastSlash) plastSlash = strrchr(argv[1],'\\');
491- plastSlash = (plastSlash ? plastSlash+1 : argv[1]);
492- outFilename = dbCalloc(1,strlen(plastSlash)+1);
493- strcpy(outFilename,plastSlash);
494- pext = strstr(outFilename,".dbd");
495- if (!pext) {
496- fprintf(stderr,"Input file MUST have .dbd extension\n");
497- exit(-1);
498- }
499- strcpy(pext,".h");
500- } else {
501- outFilename = dbCalloc(1,strlen(argv[2])+1);
502- strcpy(outFilename,argv[2]);
503- }
504- pdbbase = dbAllocBase();
505- pdbbase->ignoreMissingMenus = TRUE;
506- status = dbReadDatabase(&pdbbase,argv[1],path,sub);
507- if (status) {
508- errlogFlush();
509- fprintf(stderr, "dbToMenuH: Input errors, no output generated\n");
510- exit(1);
511- }
512- outFile = fopen(outFilename, "w");
513- if (!outFile) {
514- epicsPrintf("Error creating output file \"%s\"\n", outFilename);
515- exit(1);
516- }
517- pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList);
518- while(pdbMenu) {
519- fprintf(outFile,"#ifndef INC%sH\n",pdbMenu->name);
520- fprintf(outFile,"#define INC%sH\n",pdbMenu->name);
521- fprintf(outFile,"typedef enum {\n");
522- for(i=0; i<pdbMenu->nChoice; i++) {
523- fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]);
524- if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,",");
525- fprintf(outFile,"\n");
526- }
527- fprintf(outFile,"}%s;\n",pdbMenu->name);
528- fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name);
529- pdbMenu = (dbMenu *)ellNext(&pdbMenu->node);
530- }
531- fclose(outFile);
532- free((void *)outFilename);
533- return(0);
534-}
535
536=== removed file 'src/ioc/dbStatic/dbToRecordtypeH.c'
537--- src/ioc/dbStatic/dbToRecordtypeH.c 2008-08-05 22:48:45 +0000
538+++ src/ioc/dbStatic/dbToRecordtypeH.c 1970-01-01 00:00:00 +0000
539@@ -1,267 +0,0 @@
540-/*************************************************************************\
541-* Copyright (c) 2007 UChicago Argonne LLC, as Operator of Argonne
542-* National Laboratory.
543-* Copyright (c) 2002 The Regents of the University of California, as
544-* Operator of Los Alamos National Laboratory.
545-* EPICS BASE is distributed subject to a Software License Agreement found
546-* in file LICENSE that is included with this distribution.
547-\*************************************************************************/
548-/* dbToRecordtypeH.c */
549-/* Author: Marty Kraimer Date: 11Sep95 */
550-
551-#include <stdlib.h>
552-#include <stddef.h>
553-#include <stdio.h>
554-#include <string.h>
555-#include <ctype.h>
556-
557-#include "dbDefs.h"
558-#include "epicsPrint.h"
559-#include "errMdef.h"
560-#include "dbStaticLib.h"
561-#include "dbStaticPvt.h"
562-#include "dbBase.h"
563-#include "gpHash.h"
564-#include "osiFileName.h"
565-
566-DBBASE *pdbbase = NULL;
567-
568
569-int main(int argc,char **argv)
570-{
571- int i;
572- char *outFilename;
573- char *pext;
574- FILE *outFile;
575- dbMenu *pdbMenu;
576- dbRecordType *pdbRecordType;
577- dbFldDes *pdbFldDes;
578- dbText *pdbCdef;
579- int isdbCommonRecord = FALSE;
580- char *plastSlash;
581- int strip;
582- char *path = NULL;
583- char *sub = NULL;
584- int pathLength = 0;
585- int subLength = 0;
586- char **pstr;
587- char *psep;
588- int *len;
589- long status;
590- static char *pathSep = OSI_PATH_LIST_SEPARATOR;
591- static char *subSep = ",";
592-
593- /*Look for options*/
594- if(argc<2) {
595- fprintf(stderr,"usage: dbToRecordtypeH -Idir -Idir file.dbd [outfile]\n");
596- exit(0);
597- }
598- while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
599- if(strncmp(argv[1],"-I",2)==0) {
600- pstr = &path;
601- psep = pathSep;
602- len = &pathLength;
603- } else {
604- pstr = &sub;
605- psep = subSep;
606- len = &subLength;
607- }
608- if(strlen(argv[1])==2) {
609- dbCatString(pstr,len,argv[2],psep);
610- strip = 2;
611- } else {
612- dbCatString(pstr,len,argv[1]+2,psep);
613- strip = 1;
614- }
615- argc -= strip;
616- for(i=1; i<argc; i++) argv[i] = argv[i + strip];
617- }
618- if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
619- fprintf(stderr,"usage: dbToRecordtypeH -Idir -Idir file.dbd [outfile]\n");
620- exit(0);
621- }
622- if(argc==2){
623- /*remove path so that outFile is created where program is executed*/
624- plastSlash = strrchr(argv[1],'/');
625- if(!plastSlash) plastSlash = strrchr(argv[1],'\\');
626- plastSlash = (plastSlash ? plastSlash+1 : argv[1]);
627- outFilename = dbCalloc(1,strlen(plastSlash)+1);
628- strcpy(outFilename,plastSlash);
629- pext = strstr(outFilename,".dbd");
630- if(!pext) {
631- fprintf(stderr,"Input file MUST have .dbd extension\n");
632- exit(-1);
633- }
634- strcpy(pext,".h");
635- if(strcmp(outFilename,"dbCommonRecord.h")==0) {
636- strcpy(outFilename,"dbCommon.h");
637- isdbCommonRecord = TRUE;
638- }
639- }else {
640- outFilename = dbCalloc(1,strlen(argv[2])+1);
641- strcpy(outFilename,argv[2]);
642- if(strstr(outFilename,"dbCommon.h")!=0) {
643- isdbCommonRecord = TRUE;
644- }
645- }
646- pdbbase = dbAllocBase();
647- pdbbase->ignoreMissingMenus = TRUE;
648- pdbbase->loadCdefs = TRUE;
649- status = dbReadDatabase(&pdbbase,argv[1],path,sub);
650- if(status) {
651- errlogFlush();
652- fprintf(stderr, "dbToMenuH: Input errors, no output generated\n");
653- exit(1);
654- }
655- outFile = fopen(outFilename,"w");
656- if(!outFile) {
657- epicsPrintf("Error creating output file \"%s\"\n", outFilename);
658- exit(1);
659- }
660-
661- pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList);
662- while(pdbMenu) {
663- fprintf(outFile,"\n#ifndef INC%sH\n",pdbMenu->name);
664- fprintf(outFile,"#define INC%sH\n",pdbMenu->name);
665- fprintf(outFile,"typedef enum {\n");
666- for(i=0; i<pdbMenu->nChoice; i++) {
667- fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]);
668- if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,",");
669- fprintf(outFile,"\n");
670- }
671- fprintf(outFile,"}%s;\n",pdbMenu->name);
672- fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name);
673- pdbMenu = (dbMenu *)ellNext(&pdbMenu->node);
674- }
675- pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList);
676- while(pdbRecordType) {
677- fprintf(outFile,"#ifndef INC%sH\n",pdbRecordType->name);
678- fprintf(outFile,"#define INC%sH\n",pdbRecordType->name);
679- pdbCdef = (dbText *)ellFirst(&pdbRecordType->cdefList);
680- while (pdbCdef) {
681- fprintf(outFile,"%s\n",pdbCdef->text);
682- pdbCdef = (dbText *)ellNext(&pdbCdef->node);
683- }
684- fprintf(outFile,"typedef struct %s",pdbRecordType->name);
685- if(!isdbCommonRecord) fprintf(outFile,"Record");
686- fprintf(outFile," {\n");
687- for(i=0; i<pdbRecordType->no_fields; i++) {
688- char name[256];
689- int j;
690-
691- pdbFldDes = pdbRecordType->papFldDes[i];
692- for(j=0; j< (int)strlen(pdbFldDes->name); j++)
693- name[j] = tolower(pdbFldDes->name[j]);
694- name[strlen(pdbFldDes->name)] = 0;
695- switch(pdbFldDes->field_type) {
696- case DBF_STRING :
697- fprintf(outFile, "\tchar\t\t%s[%d];\t/* %s */\n",
698- name, pdbFldDes->size, pdbFldDes->prompt);
699- break;
700- case DBF_CHAR :
701- fprintf(outFile, "\tepicsInt8\t%s;\t/* %s */\n",
702- name, pdbFldDes->prompt);
703- break;
704- case DBF_UCHAR :
705- fprintf(outFile, "\tepicsUInt8\t%s;\t/* %s */\n",
706- name, pdbFldDes->prompt);
707- break;
708- case DBF_SHORT :
709- fprintf(outFile, "\tepicsInt16\t%s;\t/* %s */\n",
710- name, pdbFldDes->prompt);
711- break;
712- case DBF_USHORT :
713- fprintf(outFile, "\tepicsUInt16\t%s;\t/* %s */\n",
714- name, pdbFldDes->prompt);
715- break;
716- case DBF_LONG :
717- fprintf(outFile, "\tepicsInt32\t%s;\t/* %s */\n",
718- name, pdbFldDes->prompt);
719- break;
720- case DBF_ULONG :
721- fprintf(outFile, "\tepicsUInt32\t%s;\t/* %s */\n",
722- name, pdbFldDes->prompt);
723- break;
724- case DBF_FLOAT :
725- fprintf(outFile, "\tepicsFloat32\t%s;\t/* %s */\n",
726- name, pdbFldDes->prompt);
727- break;
728- case DBF_DOUBLE :
729- fprintf(outFile, "\tepicsFloat64\t%s;\t/* %s */\n",
730- name, pdbFldDes->prompt);
731- break;
732- case DBF_ENUM :
733- case DBF_MENU :
734- case DBF_DEVICE :
735- fprintf(outFile, "\tepicsEnum16\t%s;\t/* %s */\n",
736- name, pdbFldDes->prompt);
737- break;
738- case DBF_INLINK :
739- case DBF_OUTLINK :
740- case DBF_FWDLINK :
741- fprintf(outFile, "\tDBLINK\t\t%s;\t/* %s */\n",
742- name, pdbFldDes->prompt);
743- break;
744- case DBF_NOACCESS:
745- fprintf(outFile, "\t%s;\t/* %s */\n",
746- pdbFldDes->extra, pdbFldDes->prompt);
747- break;
748- default:
749- fprintf(outFile,"ILLEGAL FIELD TYPE\n");
750- }
751- }
752- fprintf(outFile,"} %s",pdbRecordType->name);
753- if(!isdbCommonRecord) fprintf(outFile,"Record");
754- fprintf(outFile,";\n");
755- if(!isdbCommonRecord) {
756- for(i=0; i<pdbRecordType->no_fields; i++) {
757- pdbFldDes = pdbRecordType->papFldDes[i];
758- fprintf(outFile,"#define %sRecord%s\t%d\n",
759- pdbRecordType->name,pdbFldDes->name,pdbFldDes->indRecordType);
760- }
761- }
762- fprintf(outFile,"#endif /*INC%sH*/\n",pdbRecordType->name);
763- pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node);
764- if(pdbRecordType) fprintf(outFile,"\n");
765- }
766- if(!isdbCommonRecord) {
767- fprintf(outFile,"#ifdef GEN_SIZE_OFFSET\n");
768- fprintf(outFile,"#ifdef __cplusplus\n");
769- fprintf(outFile,"extern \"C\" {\n");
770- fprintf(outFile,"#endif\n");
771- fprintf(outFile,"#include <epicsExport.h>\n");
772- pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList);
773- while(pdbRecordType) {
774- fprintf(outFile,"static int %sRecordSizeOffset(dbRecordType *pdbRecordType)\n{\n",
775- pdbRecordType->name);
776- fprintf(outFile," %sRecord *prec = 0;\n",pdbRecordType->name);
777- for(i=0; i<pdbRecordType->no_fields; i++) {
778- char name[256];
779- int j;
780-
781- pdbFldDes = pdbRecordType->papFldDes[i];
782- for(j=0; j< (int)strlen(pdbFldDes->name); j++)
783- name[j] = tolower(pdbFldDes->name[j]);
784- name[strlen(pdbFldDes->name)] = 0;
785- fprintf(outFile,
786- " pdbRecordType->papFldDes[%d]->size=sizeof(prec->%s);\n",
787- i,name);
788- fprintf(outFile," pdbRecordType->papFldDes[%d]->offset=",i);
789- fprintf(outFile,
790- "(short)((char *)&prec->%s - (char *)prec);\n",name);
791- }
792- fprintf(outFile," pdbRecordType->rec_size = sizeof(*prec);\n");
793- fprintf(outFile," return(0);\n");
794- fprintf(outFile,"}\n");
795- fprintf(outFile,"epicsExportRegistrar(%sRecordSizeOffset);\n",
796- pdbRecordType->name);
797- pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node);
798- }
799- fprintf(outFile,"#ifdef __cplusplus\n");
800- fprintf(outFile,"}\n");
801- fprintf(outFile,"#endif\n");
802- fprintf(outFile,"#endif /*GEN_SIZE_OFFSET*/\n");
803- }
804- fclose(outFile);
805- free((void *)outFilename);
806- return(0);
807-}
808
809=== modified file 'src/ioc/registry/registerRecordDeviceDriver.pl'
810--- src/ioc/registry/registerRecordDeviceDriver.pl 2010-12-16 23:02:15 +0000
811+++ src/ioc/registry/registerRecordDeviceDriver.pl 2012-04-02 20:38:19 +0000
812@@ -1,7 +1,7 @@
813 eval 'exec perl -S $0 ${1+"$@"}' # -*- Mode: perl -*-
814 if $running_under_some_shell; # registerRecordDeviceDriver
815 #*************************************************************************
816-# Copyright (c) 2009 UChicago Argonne LLC, as Operator of Argonne
817+# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
818 # National Laboratory.
819 # Copyright (c) 2002 The Regents of the University of California, as
820 # Operator of Los Alamos National Laboratory.
821@@ -9,52 +9,35 @@
822 # in file LICENSE that is included with this distribution.
823 #*************************************************************************
824
825+use strict;
826+
827 use FindBin qw($Bin);
828 use lib "$Bin/../../lib/perl";
829+
830+use DBD;
831+use DBD::Parser;
832+use EPICS::Readfile;
833 use EPICS::Path;
834-
835-($file, $subname, $bldTop) = @ARGV;
836-$numberRecordType = 0;
837-$numberDeviceSupport = 0;
838-$numberDriverSupport = 0;
839+use Text::Wrap;
840+
841+my ($file, $subname, $bldTop) = @ARGV;
842+
843+my $dbd = DBD->new();
844+&ParseDBD($dbd, &Readfile($file));
845+
846+$Text::Wrap::columns = 75;
847
848 # Eliminate chars not allowed in C symbol names
849-$c_bad_ident_chars = '[^0-9A-Za-z_]';
850+my $c_bad_ident_chars = '[^0-9A-Za-z_]';
851 $subname =~ s/$c_bad_ident_chars/_/g;
852
853 # Process bldTop like convertRelease.pl does
854 $bldTop = LocalPath(UnixPath($bldTop));
855 $bldTop =~ s/([\\"])/\\\1/g; # escape back-slashes and double-quotes
856
857-open(INP,"$file") or die "$! opening file";
858-while(<INP>) {
859- next if m/ ^ \s* \# /x;
860- if (m/ \b recordtype \s* \( \s* (\w+) \s* \) /x) {
861- $recordType[$numberRecordType++] = $1;
862- }
863- elsif (m/ \b device \s* \( \s* (\w+) \W+ \w+ \W+ (\w+) /x) {
864- $deviceRecordType[$numberDeviceSupport] = $1;
865- $deviceSupport[$numberDeviceSupport] = $2;
866- $numberDeviceSupport++;
867- }
868- elsif (m/ \b driver \s* \( \s* (\w+) \s* \) /x) {
869- $driverSupport[$numberDriverSupport++] = $1;
870- }
871- elsif (m/ \b registrar \s* \( \s* (\w+) \s* \) /x) {
872- push @registrars, $1;
873- }
874- elsif (m/ \b function \s* \( \s* (\w+) \s* \) /x) {
875- push @registrars, "register_func_$1";
876- }
877- elsif (m/ \b variable \s* \( \s* (\w+) \s* , \s* (\w+) \s* \) /x) {
878- $varType{$1} = $2;
879- push @variables, $1;
880- }
881-}
882-close(INP) or die "$! closing file";
883-
884-
885-# beginning of generated routine
886+
887+# Start of generated file
888+
889 print << "END" ;
890 /* THIS IS A GENERATED FILE. DO NOT EDIT! */
891 /* Generated from $file */
892@@ -70,104 +53,115 @@
893
894 END
895
896-#definitions for recordtype
897-if($numberRecordType>0) {
898- for ($i=0; $i<$numberRecordType; $i++) {
899- print "epicsShareExtern rset *pvar_rset_$recordType[$i]RSET;\n";
900- print "epicsShareExtern int (*pvar_func_$recordType[$i]RecordSizeOffset)(dbRecordType *pdbRecordType);\n"
901- }
902- print "\nstatic const char * const recordTypeNames[$numberRecordType] = {\n";
903- for ($i=0; $i<$numberRecordType; $i++) {
904- print " \"$recordType[$i]\"";
905- if($i < $numberRecordType-1) { print ",";}
906- print "\n";
907- }
908- print "};\n\n";
909-
910- print "static const recordTypeLocation rtl[$i] = {\n";
911- for ($i=0; $i<$numberRecordType; $i++) {
912- print " {pvar_rset_$recordType[$i]RSET, pvar_func_$recordType[$i]RecordSizeOffset}";
913- if($i < $numberRecordType-1) { print ",";}
914- print "\n";
915- }
916- print "};\n\n";
917-}
918-
919-#definitions for device
920-if($numberDeviceSupport>0) {
921- for ($i=0; $i<$numberDeviceSupport; $i++) {
922- print "epicsShareExtern dset *pvar_dset_$deviceSupport[$i];\n";
923- }
924- print "\nstatic const char * const deviceSupportNames[$numberDeviceSupport] = {\n";
925- for ($i=0; $i<$numberDeviceSupport; $i++) {
926- print " \"$deviceSupport[$i]\"";
927- if($i < $numberDeviceSupport-1) { print ",";}
928- print "\n";
929- }
930- print "};\n\n";
931-
932- print "static const dset * const devsl[$i] = {\n";
933- for ($i=0; $i<$numberDeviceSupport; $i++) {
934- print " pvar_dset_$deviceSupport[$i]";
935- if($i < $numberDeviceSupport-1) { print ",";}
936- print "\n";
937- }
938- print "};\n\n";
939-}
940-
941-#definitions for driver
942-if($numberDriverSupport>0) {
943- for ($i=0; $i<$numberDriverSupport; $i++) {
944- print "epicsShareExtern drvet *pvar_drvet_$driverSupport[$i];\n";
945- }
946- print "\nstatic const char *driverSupportNames[$numberDriverSupport] = {\n";
947- for ($i=0; $i<$numberDriverSupport; $i++) {
948- print " \"$driverSupport[$i]\"";
949- if($i < $numberDriverSupport-1) { print ",";}
950- print "\n";
951- }
952- print "};\n\n";
953-
954- print "static struct drvet *drvsl[$i] = {\n";
955- for ($i=0; $i<$numberDriverSupport; $i++) {
956- print " pvar_drvet_$driverSupport[$i]";
957- if($i < $numberDriverSupport-1) { print ",";}
958- print "\n";
959- }
960- print "};\n\n";
961-}
962-
963-#definitions registrar
964-if(@registrars) {
965- foreach $reg (@registrars) {
966- print "epicsShareExtern void (*pvar_func_$reg)(void);\n";
967- }
968- print "\n";
969-}
970-
971-if (@variables) {
972- foreach $var (@variables) {
973- print "epicsShareExtern $varType{$var} *pvar_$varType{$var}_$var;\n";
974- }
975- %iocshTypes = (
976- 'int' => 'iocshArgInt',
977- 'double' => 'iocshArgDouble'
978- );
979- print "static struct iocshVarDef vardefs[] = {\n";
980- foreach $var (@variables) {
981- $argType = $iocshTypes{$varType{$var}};
982- die "Unknown variable type $varType{$var} for variable $var"
983- unless $argType;
984- print "\t{\"$var\", $argType, (void * const)pvar_$varType{$var}_$var},\n";
985- }
986- print "\t{NULL, iocshArgInt, NULL}\n};\n\n";
987-}
988-
989-#Now actual registration code.
990-
991-print "int $subname(DBBASE *pbase)\n{\n";
992-
993-print << "END" if ($bldTop ne '') ;
994+my %rectypes = %{$dbd->recordtypes};
995+my @dsets;
996+if (%rectypes) {
997+ my @rtypnames = sort keys %rectypes;
998+
999+ # Declare the record support entry tables
1000+ print wrap('epicsShareExtern rset ', ' ',
1001+ join(', ', map {"*pvar_rset_${_}RSET"} @rtypnames)), ";\n\n";
1002+
1003+ # Declare the RecordSizeOffset functions
1004+ print "typedef int (*rso_func)(dbRecordType *pdbRecordType);\n";
1005+ print wrap('epicsShareExtern rso_func ', ' ',
1006+ join(', ', map {"pvar_func_${_}RecordSizeOffset"} @rtypnames)), ";\n\n";
1007+
1008+ # List of record type names
1009+ print "static const char * const recordTypeNames[] = {\n";
1010+ print wrap(' ', ' ', join(', ', map {"\"$_\""} @rtypnames));
1011+ print "\n};\n\n";
1012+
1013+ # List of pointers to each RSET and RecordSizeOffset function
1014+ print "static const recordTypeLocation rtl[] = {\n";
1015+ print join(",\n", map {
1016+ " {pvar_rset_${_}RSET, pvar_func_${_}RecordSizeOffset}"
1017+ } @rtypnames);
1018+ print "\n};\n\n";
1019+
1020+ for my $rtype (@rtypnames) {
1021+ my @devices = $rectypes{$rtype}->devices;
1022+ for my $dtype (@devices) {
1023+ my $dset = $dtype->name;
1024+ push @dsets, $dset;
1025+ }
1026+ }
1027+
1028+ if (@dsets) {
1029+ # Declare the device support entry tables
1030+ print wrap('epicsShareExtern dset ', ' ',
1031+ join(', ', map {"*pvar_dset_$_"} @dsets)), ";\n\n";
1032+
1033+ # List of dset names
1034+ print "static const char * const deviceSupportNames[] = {\n";
1035+ print wrap(' ', ' ', join(', ', map {"\"$_\""} @dsets));
1036+ print "\n};\n\n";
1037+
1038+ # List of pointers to each dset
1039+ print "static const dset * const devsl[] = {\n";
1040+ print wrap(' ', ' ', join(", ", map {"pvar_dset_$_"} @dsets));
1041+ print "\n};\n\n";
1042+ }
1043+}
1044+
1045+my %drivers = %{$dbd->drivers};
1046+if (%drivers) {
1047+ my @drivers = sort keys %drivers;
1048+
1049+ # Declare the driver entry tables
1050+ print wrap('epicsShareExtern drvet ', ' ',
1051+ join(', ', map {"*pvar_drvet_$_"} @drivers)), ";\n\n";
1052+
1053+ # List of drvet names
1054+ print "static const char *driverSupportNames[] = {\n";
1055+ print wrap(' ', ' ', join(', ', map {"\"$_\""} @drivers));
1056+ print "};\n\n";
1057+
1058+ # List of pointers to each drvet
1059+ print "static struct drvet *drvsl[] = {\n";
1060+ print join(",\n", map {" pvar_drvet_$_"} @drivers);
1061+ print "};\n\n";
1062+}
1063+
1064+my @registrars = sort keys %{$dbd->registrars};
1065+my @functions = sort keys %{$dbd->functions};
1066+push @registrars, map {"register_func_$_"} @functions;
1067+if (@registrars) {
1068+ # Declare the registrar functions
1069+ print "typedef void (*reg_func)(void);\n";
1070+ print wrap('epicsShareExtern reg_func ', ' ',
1071+ join(', ', map {"pvar_func_$_"} @registrars)), ";\n\n";
1072+}
1073+
1074+my %variables = %{$dbd->variables};
1075+if (%variables) {
1076+ my @varnames = sort keys %variables;
1077+
1078+ # Declare the variables
1079+ for my $var (@varnames) {
1080+ my $vtype = $variables{$var}->var_type;
1081+ print "epicsShareExtern $vtype * const pvar_${vtype}_$var;\n";
1082+ }
1083+
1084+ # Generate the structure for registering variables with iocsh
1085+ print "\nstatic struct iocshVarDef vardefs[] = {\n";
1086+ for my $var (@varnames) {
1087+ my $vtype = $variables{$var}->var_type;
1088+ my $itype = $variables{$var}->iocshArg_type;
1089+ print " {\"$var\", $itype, pvar_${vtype}_$var},\n";
1090+ }
1091+ print " {NULL, iocshArgInt, NULL}\n};\n\n";
1092+}
1093+
1094+# Now for actual registration routine
1095+
1096+print << "END";
1097+int $subname(DBBASE *pbase)
1098+{
1099+ static int executed = 0;
1100+END
1101+
1102+print << "END" if $bldTop ne '';
1103 const char *bldTop = "$bldTop";
1104 const char *envTop = getenv("TOP");
1105
1106@@ -179,57 +173,62 @@
1107
1108 END
1109
1110-print << "END" ;
1111+print << 'END';
1112 if (!pbase) {
1113- printf("pdbbase is NULL; you must load a DBD file first.\\n");
1114+ printf("pdbbase is NULL; you must load a DBD file first.\n");
1115 return -1;
1116 }
1117
1118-END
1119-
1120-if($numberRecordType>0) {
1121- print " registerRecordTypes(pbase, $numberRecordType, ",
1122- "recordTypeNames, rtl);\n";
1123-}
1124-if($numberDeviceSupport>0) {
1125- print " registerDevices(pbase, $numberDeviceSupport, ",
1126- "deviceSupportNames, devsl);\n";
1127-}
1128-if($numberDriverSupport>0) {
1129- print " registerDrivers(pbase, $numberDriverSupport, ",
1130- "driverSupportNames, drvsl);\n";
1131-}
1132-foreach $reg (@registrars) {
1133- print " (*pvar_func_$reg)();\n";
1134-}
1135-
1136-if (@variables) {
1137- print " iocshRegisterVariable(vardefs);\n";
1138-}
1139-print << "END" ;
1140+ if (executed) {
1141+ printf("Registration already done.\n");
1142+ return 0;
1143+ }
1144+ executed = 1;
1145+
1146+END
1147+
1148+print << 'END' if %rectypes;
1149+ registerRecordTypes(pbase, NELEMENTS(rtl), recordTypeNames, rtl);
1150+END
1151+
1152+print << 'END' if @dsets;
1153+ registerDevices(pbase, NELEMENTS(devsl), deviceSupportNames, devsl);
1154+END
1155+
1156+print << 'END' if %drivers;
1157+ registerDrivers(pbase, NELEMENTS(drvsl), driverSupportNames, drvsl);
1158+END
1159+
1160+print << "END" for @registrars;
1161+ pvar_func_$_();
1162+END
1163+
1164+print << 'END' if %variables;
1165+ iocshRegisterVariable(vardefs);
1166+END
1167+
1168+print << "END";
1169 return 0;
1170 }
1171
1172-/* registerRecordDeviceDriver */
1173-static const iocshArg registerRecordDeviceDriverArg0 =
1174- {"pdbbase",iocshArgPdbbase};
1175-static const iocshArg *registerRecordDeviceDriverArgs[1] =
1176- {&registerRecordDeviceDriverArg0};
1177-static const iocshFuncDef registerRecordDeviceDriverFuncDef =
1178- {"$subname",1,registerRecordDeviceDriverArgs};
1179-static void registerRecordDeviceDriverCallFunc(const iocshArgBuf *)
1180+/* $subname */
1181+static const iocshArg rrddArg0 = {"pdbbase", iocshArgPdbbase};
1182+static const iocshArg *rrddArgs[] = {&rrddArg0};
1183+static const iocshFuncDef rrddFuncDef =
1184+ {"$subname", 1, rrddArgs};
1185+static void rrddCallFunc(const iocshArgBuf *)
1186 {
1187 $subname(*iocshPpdbbase);
1188 }
1189
1190 } // extern "C"
1191+
1192 /*
1193 * Register commands on application startup
1194 */
1195 static int Registration() {
1196 iocshRegisterCommon();
1197- iocshRegister(&registerRecordDeviceDriverFuncDef,
1198- registerRecordDeviceDriverCallFunc);
1199+ iocshRegister(&rrddFuncDef, rrddCallFunc);
1200 return 0;
1201 }
1202
1203
1204=== added directory 'src/tools/DBD'
1205=== added file 'src/tools/DBD.pm'
1206--- src/tools/DBD.pm 1970-01-01 00:00:00 +0000
1207+++ src/tools/DBD.pm 2012-04-02 20:38:19 +0000
1208@@ -0,0 +1,81 @@
1209+package DBD;
1210+
1211+use DBD::Base;
1212+use DBD::Breaktable;
1213+use DBD::Driver;
1214+use DBD::Menu;
1215+use DBD::Recordtype;
1216+use DBD::Recfield;
1217+use DBD::Registrar;
1218+use DBD::Function;
1219+use DBD::Variable;
1220+
1221+use Carp;
1222+
1223+sub new {
1224+ my ($class) = @_;
1225+ my $this = {
1226+ 'DBD::Breaktable' => {},
1227+ 'DBD::Driver' => {},
1228+ 'DBD::Function' => {},
1229+ 'DBD::Menu' => {},
1230+ 'DBD::Recordtype' => {},
1231+ 'DBD::Registrar' => {},
1232+ 'DBD::Variable' => {}
1233+ };
1234+ bless $this, $class;
1235+ return $this;
1236+}
1237+
1238+sub add {
1239+ my ($this, $obj) = @_;
1240+ my $obj_class;
1241+ foreach (keys %{$this}) {
1242+ next unless m/^DBD::/;
1243+ $obj_class = $_ and last if $obj->isa($_);
1244+ }
1245+ confess "Unknown object type"
1246+ unless defined $obj_class;
1247+ my $obj_name = $obj->name;
1248+ dieContext("Duplicate name '$obj_name'")
1249+ if exists $this->{$obj_class}->{$obj_name};
1250+ $this->{$obj_class}->{$obj_name} = $obj;
1251+}
1252+
1253+sub breaktables {
1254+ return shift->{'DBD::Breaktable'};
1255+}
1256+
1257+sub drivers {
1258+ return shift->{'DBD::Driver'};
1259+}
1260+
1261+sub functions {
1262+ return shift->{'DBD::Function'};
1263+}
1264+
1265+sub menus {
1266+ return shift->{'DBD::Menu'};
1267+}
1268+sub menu {
1269+ my ($this, $menu_name) = @_;
1270+ return $this->{'DBD::Menu'}->{$menu_name};
1271+}
1272+
1273+sub recordtypes {
1274+ return shift->{'DBD::Recordtype'};
1275+}
1276+sub recordtype {
1277+ my ($this, $rtyp_name) = @_;
1278+ return $this->{'DBD::Recordtype'}->{$rtyp_name};
1279+}
1280+
1281+sub registrars {
1282+ return shift->{'DBD::Registrar'};
1283+}
1284+
1285+sub variables {
1286+ return shift->{'DBD::Variable'};
1287+}
1288+
1289+1;
1290
1291=== added file 'src/tools/DBD/Base.pm'
1292--- src/tools/DBD/Base.pm 1970-01-01 00:00:00 +0000
1293+++ src/tools/DBD/Base.pm 2012-04-02 20:38:19 +0000
1294@@ -0,0 +1,127 @@
1295+# Common utility functions used by the DBD components
1296+
1297+package DBD::Base;
1298+
1299+use Carp;
1300+require Exporter;
1301+
1302+@ISA = qw(Exporter);
1303+@EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved
1304+ &identifier &unquote &escapeCcomment &escapeCstring $RXident $RXname
1305+ $RXuint $RXint $RXhex $RXoct $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr);
1306+
1307+
1308+our $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x;
1309+our $RXname = qr/ [a-zA-Z0-9_\-:.<>;]+ /x;
1310+our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x;
1311+our $RXoct = qr/ 0 [0-7]* /x;
1312+our $RXuint = qr/ \d+ /x;
1313+our $RXint = qr/ -? $RXuint /ox;
1314+our $RXuintx = qr/ ( $RXhex | $RXoct | $RXuint ) /ox;
1315+our $RXintx = qr/ ( $RXhex | $RXoct | $RXint ) /ox;
1316+our $RXnum = qr/ -? (?: \d+ | \d* \. \d+ ) (?: [eE] [-+]? \d+ )? /x;
1317+our $RXdqs = qr/" (?: [^"] | \\" )* " /x;
1318+our $RXsqs = qr/' (?: [^'] | \\' )* ' /x;
1319+our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox;
1320+
1321+our @context;
1322+
1323+
1324+sub pushContext {
1325+ my ($ctxt) = @_;
1326+ unshift @context, $ctxt;
1327+}
1328+
1329+sub popContext {
1330+ my ($ctxt) = @_;
1331+ my ($pop) = shift @context;
1332+ ($ctxt ne $pop) and
1333+ dieContext("Exiting context \"$ctxt\", found \"$pop\" instead.",
1334+ "\tBraces must close in the same file they were opened.");
1335+}
1336+
1337+sub dieContext {
1338+ my ($msg) = join "\n\t", @_;
1339+ print "$msg\n" if $msg;
1340+ die "Context: ", join(' in ', @context), "\n";
1341+}
1342+
1343+sub warnContext {
1344+ my ($msg) = join "\n\t", @_;
1345+ print "$msg\n" if $msg;
1346+ print "Context: ", join(' in ', @context), "\n";
1347+}
1348+
1349+
1350+# Input checking
1351+
1352+sub unquote (\$) {
1353+ my ($s) = @_;
1354+ $$s =~ s/^"(.*)"$/$1/o;
1355+ return $$s;
1356+}
1357+
1358+# Reserved words from C++ and the DB/DBD file parser
1359+my %reserved = map { $_ => undef } qw(and and_eq asm auto bitand bitor bool
1360+ break case catch char class compl const const_cast continue default delete
1361+ do double dynamic_cast else enum explicit export extern false float for
1362+ friend goto if inline int long mutable namespace new not not_eq operator or
1363+ or_eq private protected public register reinterpret_cast return short signed
1364+ sizeof static static_cast struct switch template this throw true try typedef
1365+ typeid typename union unsigned using virtual void volatile wchar_t while xor
1366+ xor_eq addpath alias breaktable choice device driver field function grecord
1367+ include info menu path record recordtype registrar variable);
1368+sub is_reserved {
1369+ my $id = shift;
1370+ return exists $reserved{$id};
1371+}
1372+
1373+sub identifier {
1374+ my ($id, $what) = @_;
1375+ unquote $id;
1376+ confess "$what undefined!" unless defined $id;
1377+ $id =~ m/^$RXident$/o or dieContext("Illegal $what '$id'",
1378+ "Identifiers are used in C code so must start with a letter, followed",
1379+ "by letters, digits and/or underscore characters only.");
1380+ dieContext("Illegal $what '$id'",
1381+ "Identifier is a C++ reserved word.")
1382+ if is_reserved($id);
1383+ return $id;
1384+}
1385+
1386+
1387+# Output filtering
1388+
1389+sub escapeCcomment {
1390+ ($_) = @_;
1391+ s/\*\//**/g;
1392+ return $_;
1393+}
1394+
1395+sub escapeCstring {
1396+ ($_) = @_;
1397+ # How to do this?
1398+ return $_;
1399+}
1400+
1401+
1402+# Base class routines for the DBD component objects
1403+
1404+sub new {
1405+ my $class = shift;
1406+ my $this = {};
1407+ bless $this, $class;
1408+ return $this->init(@_);
1409+}
1410+
1411+sub init {
1412+ my ($this, $name, $what) = @_;
1413+ $this->{NAME} = identifier($name, $what);
1414+ return $this;
1415+}
1416+
1417+sub name {
1418+ return shift->{NAME};
1419+}
1420+
1421+1;
1422
1423=== added file 'src/tools/DBD/Breaktable.pm'
1424--- src/tools/DBD/Breaktable.pm 1970-01-01 00:00:00 +0000
1425+++ src/tools/DBD/Breaktable.pm 2012-04-02 20:38:19 +0000
1426@@ -0,0 +1,32 @@
1427+package DBD::Breaktable;
1428+use DBD::Base;
1429+@ISA = qw(DBD::Base);
1430+
1431+use Carp;
1432+
1433+sub init {
1434+ my ($this, $name) = @_;
1435+ $this->SUPER::init($name, "breakpoint table name");
1436+ $this->{POINT_LIST} = [];
1437+ return $this;
1438+}
1439+
1440+sub add_point {
1441+ my ($this, $raw, $eng) = @_;
1442+ confess "Raw value undefined!" unless defined $raw;
1443+ confess "Engineering value undefined!" unless defined $eng;
1444+ unquote $raw;
1445+ unquote $eng;
1446+ push @{$this->{POINT_LIST}}, [$raw, $eng];
1447+}
1448+
1449+sub points {
1450+ return @{shift->{POINT_LIST}};
1451+}
1452+
1453+sub point {
1454+ my ($this, $idx) = @_;
1455+ return $this->{POINT_LIST}[$idx];
1456+}
1457+
1458+1;
1459
1460=== added file 'src/tools/DBD/Device.pm'
1461--- src/tools/DBD/Device.pm 1970-01-01 00:00:00 +0000
1462+++ src/tools/DBD/Device.pm 2012-04-02 20:38:19 +0000
1463@@ -0,0 +1,45 @@
1464+package DBD::Device;
1465+use DBD::Base;
1466+@ISA = qw(DBD::Base);
1467+
1468+my %link_types = (
1469+ CONSTANT => qr/$RXnum/o,
1470+ PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/ox,
1471+ VME_IO => qr/\# (?: \s* [CS] \s* $RXintx)* \s* (?: @ .*)?/ox,
1472+ CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXintx)* \s* (?: @ .*)?/ox,
1473+ RF_IO => qr/\# (?: \s* [RMDE] \s* $RXintx)*/ox,
1474+ AB_IO => qr/\# (?: \s* [LACS] \s* $RXintx)* \s* (?: @ .*)?/ox,
1475+ GPIB_IO => qr/\# (?: \s* [LA] \s* $RXintx)* \s* (?: @ .*)?/ox,
1476+ BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXuintx)* \s* (?: @ .*)?/ox,
1477+ BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXuintx)* \s* (?: @ .*)?/ox,
1478+ VXI_IO => qr/\# (?: \s* [VCS] \s* $RXintx)* \s* (?: @ .*)?/ox,
1479+ INST_IO => qr/@.*/
1480+);
1481+
1482+sub init {
1483+ my ($this, $link_type, $dset, $choice) = @_;
1484+ unquote $choice;
1485+ dieContext("Unknown link type '$link_type', valid types are:",
1486+ sort keys %link_types) unless exists $link_types{$link_type};
1487+ $this->SUPER::init($dset, "DSET name");
1488+ $this->{LINK_TYPE} = $link_type;
1489+ $this->{CHOICE} = $choice;
1490+ return $this;
1491+}
1492+
1493+sub link_type {
1494+ return shift->{LINK_TYPE};
1495+}
1496+
1497+sub choice {
1498+ return shift->{CHOICE};
1499+}
1500+
1501+sub legal_addr {
1502+ my ($this, $addr) = @_;
1503+ my $rx = $link_types{$this->{LINK_TYPE}};
1504+ unquote $addr;
1505+ return $addr =~ m/^ $rx $/x;
1506+}
1507+
1508+1;
1509
1510=== added file 'src/tools/DBD/Driver.pm'
1511--- src/tools/DBD/Driver.pm 1970-01-01 00:00:00 +0000
1512+++ src/tools/DBD/Driver.pm 2012-04-02 20:38:19 +0000
1513@@ -0,0 +1,9 @@
1514+package DBD::Driver;
1515+use DBD::Base;
1516+@ISA = qw(DBD::Base);
1517+
1518+sub init {
1519+ return shift->SUPER::init(shift, "driver entry table name");
1520+}
1521+
1522+1;
1523
1524=== added file 'src/tools/DBD/Function.pm'
1525--- src/tools/DBD/Function.pm 1970-01-01 00:00:00 +0000
1526+++ src/tools/DBD/Function.pm 2012-04-02 20:38:19 +0000
1527@@ -0,0 +1,10 @@
1528+package DBD::Function;
1529+use DBD::Base;
1530+@ISA = qw(DBD::Base);
1531+
1532+sub init {
1533+ return shift->SUPER::init(shift, "function name");
1534+}
1535+
1536+1;
1537+
1538
1539=== added file 'src/tools/DBD/Menu.pm'
1540--- src/tools/DBD/Menu.pm 1970-01-01 00:00:00 +0000
1541+++ src/tools/DBD/Menu.pm 2012-04-02 20:38:19 +0000
1542@@ -0,0 +1,66 @@
1543+package DBD::Menu;
1544+use DBD::Base;
1545+@ISA = qw(DBD::Base);
1546+
1547+sub init {
1548+ my ($this, $name) = @_;
1549+ $this->SUPER::init($name, "menu name");
1550+ $this->{CHOICE_LIST} = [];
1551+ $this->{CHOICE_INDEX} = {};
1552+ return $this;
1553+}
1554+
1555+sub add_choice {
1556+ my ($this, $name, $value) = @_;
1557+ $name = identifier($name, "Choice name");
1558+ unquote $value;
1559+ foreach $pair ($this->choices) {
1560+ dieContext("Duplicate choice name") if ($pair->[0] eq $name);
1561+ dieContext("Duplicate choice string") if ($pair->[1] eq $value);
1562+ }
1563+ push @{$this->{CHOICE_LIST}}, [$name, $value];
1564+ $this->{CHOICE_INDEX}->{$value} = $name;
1565+}
1566+
1567+sub choices {
1568+ return @{shift->{CHOICE_LIST}};
1569+}
1570+
1571+sub choice {
1572+ my ($this, $idx) = @_;
1573+ return $this->{CHOICE_LIST}[$idx];
1574+}
1575+
1576+sub legal_choice {
1577+ my ($this, $value) = @_;
1578+ unquote $value;
1579+ return exists $this->{CHOICE_INDEX}->{$value};
1580+}
1581+
1582+sub toDeclaration {
1583+ my $this = shift;
1584+ my $name = $this->name;
1585+ my @choices = map {
1586+ sprintf " %-31s /* %s */", @{$_}[0], escapeCcomment(@{$_}[1]);
1587+ } $this->choices;
1588+ return "typedef enum {\n" .
1589+ join(",\n", @choices) .
1590+ ",\n ${name}_NUM_CHOICES\n" .
1591+ "} $name;\n\n";
1592+}
1593+
1594+sub toDefinition {
1595+ my $this = shift;
1596+ my $name = $this->name;
1597+ my @strings = map {
1598+ "\t\"" . escapeCstring(@{$_}[1]) . "\""
1599+ } $this->choices;
1600+ return "static const char * const ${name}ChoiceStrings[] = {\n" .
1601+ join(",\n", @strings) . "\n};\n" .
1602+ "const dbMenu ${name}MenuMetaData = {\n" .
1603+ "\t\"" . escapeCstring($name) . "\",\n" .
1604+ "\t${name}_NUM_CHOICES,\n" .
1605+ "\t${name}ChoiceStrings\n};\n\n";
1606+}
1607+
1608+1;
1609
1610=== added file 'src/tools/DBD/Output.pm'
1611--- src/tools/DBD/Output.pm 1970-01-01 00:00:00 +0000
1612+++ src/tools/DBD/Output.pm 2012-04-02 20:38:19 +0000
1613@@ -0,0 +1,98 @@
1614+package DBD::Output;
1615+
1616+require Exporter;
1617+
1618+@ISA = qw(Exporter);
1619+@EXPORT = qw(&OutputDBD);
1620+
1621+use DBD;
1622+use DBD::Base;
1623+use DBD::Breaktable;
1624+use DBD::Device;
1625+use DBD::Driver;
1626+use DBD::Menu;
1627+use DBD::Recordtype;
1628+use DBD::Recfield;
1629+use DBD::Registrar;
1630+use DBD::Function;
1631+use DBD::Variable;
1632+
1633+sub OutputDBD {
1634+ my ($out, $dbd) = @_;
1635+ &OutputMenus($out, $dbd->menus);
1636+ &OutputRecordtypes($out, $dbd->recordtypes);
1637+ &OutputDrivers($out, $dbd->drivers);
1638+ &OutputRegistrars($out, $dbd->registrars);
1639+ &OutputFunctions($out, $dbd->functions);
1640+ &OutputVariables($out, $dbd->variables);
1641+ &OutputBreaktables($out, $dbd->breaktables);
1642+}
1643+
1644+sub OutputMenus {
1645+ my ($out, $menus) = @_;
1646+ while (my ($name, $menu) = each %{$menus}) {
1647+ printf $out "menu(%s) {\n", $name;
1648+ printf $out " choice(%s, \"%s\")\n", @{$_}
1649+ foreach $menu->choices;
1650+ print $out "}\n";
1651+ }
1652+}
1653+
1654+sub OutputRecordtypes {
1655+ my ($out, $recordtypes) = @_;
1656+ while (my ($name, $recordtype) = each %{$recordtypes}) {
1657+ printf $out "recordtype(%s) {\n", $name;
1658+ print $out " %$_\n"
1659+ foreach $recordtype->cdefs;
1660+ foreach $field ($recordtype->fields) {
1661+ printf $out " field(%s, %s) {\n",
1662+ $field->name, $field->dbf_type;
1663+ while (my ($attr, $val) = each %{$field->attributes}) {
1664+ $val = "\"$val\"" if $val !~ m/^[a-zA-Z0-9_\-+:.\[\]<>;]*$/;
1665+ printf $out " %s(%s)\n", $attr, $val;
1666+ }
1667+ print $out " }\n";
1668+ }
1669+ printf $out "}\n";
1670+ printf $out "device(%s, %s, %s, \"%s\")\n",
1671+ $name, $_->link_type, $_->name, $_->choice
1672+ foreach $recordtype->devices;
1673+ }
1674+}
1675+
1676+sub OutputDrivers {
1677+ my ($out, $drivers) = @_;
1678+ printf $out "driver(%s)\n", $_
1679+ foreach keys %{$drivers};
1680+}
1681+
1682+sub OutputRegistrars {
1683+ my ($out, $registrars) = @_;
1684+ printf $out "registrar(%s)\n", $_
1685+ foreach keys %{$registrars};
1686+}
1687+
1688+sub OutputFunctions {
1689+ my ($out, $functions) = @_;
1690+ printf $out "function(%s)\n", $_
1691+ foreach keys %{$functions};
1692+}
1693+
1694+sub OutputVariables {
1695+ my ($out, $variables) = @_;
1696+ while (my ($name, $variable) = each %{$variables}) {
1697+ printf $out "variable(%s, %s)\n", $name, $variable->var_type;
1698+ }
1699+}
1700+
1701+sub OutputBreaktables {
1702+ my ($out, $breaktables) = @_;
1703+ while (my ($name, $breaktable) = each %{$breaktables}) {
1704+ printf $out "breaktable(\"%s\") {\n", $name;
1705+ printf $out " point(%s, %s)\n", @{$_}
1706+ foreach $breaktable->points;
1707+ print $out "}\n";
1708+ }
1709+}
1710+
1711+1;
1712
1713=== added file 'src/tools/DBD/Parser.pm'
1714--- src/tools/DBD/Parser.pm 1970-01-01 00:00:00 +0000
1715+++ src/tools/DBD/Parser.pm 2012-04-02 20:38:19 +0000
1716@@ -0,0 +1,197 @@
1717+package DBD::Parser;
1718+require Exporter;
1719+
1720+@ISA = qw(Exporter);
1721+@EXPORT = qw(&ParseDBD);
1722+
1723+use DBD;
1724+use DBD::Base;
1725+use DBD::Breaktable;
1726+use DBD::Device;
1727+use DBD::Driver;
1728+use DBD::Menu;
1729+use DBD::Recordtype;
1730+use DBD::Recfield;
1731+use DBD::Registrar;
1732+use DBD::Function;
1733+use DBD::Variable;
1734+
1735+my $RXnam = qr/[a-zA-Z0-9_\-:.<>;]+/o;
1736+my $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/ox;
1737+my $RXdqs = qr/" (?: [^"] | \\" )* "/ox;
1738+my $RXsqs = qr/' (?: [^'] | \\' )* '/ox;
1739+my $string = qr/ ( $RXnam | $RXnum | $RXdqs | $RXsqs ) /ox;
1740+
1741+our $debug=0;
1742+
1743+sub ParseDBD {
1744+ my $dbd = shift;
1745+ $_ = shift;
1746+ while (1) {
1747+ parseCommon();
1748+ if (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
1749+ print "Menu: $1\n" if $debug;
1750+ parse_menu($dbd, $1);
1751+ }
1752+ elsif (m/\G driver \s* \( \s* $string \s* \)/oxgc) {
1753+ print "Driver: $1\n" if $debug;
1754+ $dbd->add(DBD::Driver->new($1));
1755+ }
1756+ elsif (m/\G registrar \s* \( \s* $string \s* \)/oxgc) {
1757+ print "Registrar: $1\n" if $debug;
1758+ $dbd->add(DBD::Registrar->new($1));
1759+ }
1760+ elsif (m/\G function \s* \( \s* $string \s* \)/oxgc) {
1761+ print "Function: $1\n" if $debug;
1762+ $dbd->add(DBD::Function->new($1));
1763+ }
1764+ elsif (m/\G breaktable \s* \( \s* $string \s* \) \s* \{/oxgc) {
1765+ print "Breaktable: $1\n" if $debug;
1766+ parse_breaktable($dbd, $1);
1767+ }
1768+ elsif (m/\G recordtype \s* \( \s* $string \s* \) \s* \{/oxgc) {
1769+ print "Recordtype: $1\n" if $debug;
1770+ parse_recordtype($dbd, $1);
1771+ }
1772+ elsif (m/\G variable \s* \( \s* $string \s* \)/oxgc) {
1773+ print "Variable: $1\n" if $debug;
1774+ $dbd->add(DBD::Variable->new($1, 'int'));
1775+ }
1776+ elsif (m/\G variable \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
1777+ print "Variable: $1, $2\n" if $debug;
1778+ $dbd->add(DBD::Variable->new($1, $2));
1779+ }
1780+ elsif (m/\G device \s* \( \s* $string \s* , \s* $string \s* ,
1781+ \s* $string \s* , \s*$string \s* \)/oxgc) {
1782+ print "Device: $1, $2, $3, $4\n" if $debug;
1783+ my $rtyp = $dbd->recordtype($1);
1784+ dieContext("Unknown record type '$1'") unless defined $rtyp;
1785+ $rtyp->add_device(DBD::Device->new($2, $3, $4));
1786+ } else {
1787+ last unless m/\G (.*) $/moxgc;
1788+ dieContext("Syntax error in '$1'");
1789+ }
1790+ }
1791+}
1792+
1793+sub parseCommon {
1794+ while (1) {
1795+ # Skip leading whitespace
1796+ m/\G \s* /oxgc;
1797+
1798+ if (m/\G \# /oxgc) {
1799+ if (m/\G \#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) {
1800+ print "File-Begin: $1\n" if $debug;
1801+ pushContext("file '$1'");
1802+ }
1803+ elsif (m/\G \#!END\{ ( [^}]* ) \}!\#\# \n?/oxgc) {
1804+ print "File-End: $1\n" if $debug;
1805+ popContext("file '$1'");
1806+ }
1807+ else {
1808+ m/\G (.*) \n/oxgc;
1809+ print "Comment: $1\n" if $debug;
1810+ }
1811+ } else {
1812+ return;
1813+ }
1814+ }
1815+}
1816+
1817+sub parse_menu {
1818+ my ($dbd, $name) = @_;
1819+ pushContext("menu($name)");
1820+ my $menu = DBD::Menu->new($name);
1821+ while(1) {
1822+ parseCommon();
1823+ if (m/\G choice \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
1824+ print " Menu-Choice: $1, $2\n" if $debug;
1825+ $menu->add_choice($1, $2);
1826+ }
1827+ elsif (m/\G \}/oxgc) {
1828+ print " Menu-End:\n" if $debug;
1829+ $dbd->add($menu);
1830+ popContext("menu($name)");
1831+ return;
1832+ } else {
1833+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
1834+ dieContext("Syntax error in '$1'");
1835+ }
1836+ }
1837+}
1838+
1839+sub parse_breaktable {
1840+ my ($dbd, $name) = @_;
1841+ pushContext("breaktable($name)");
1842+ my $bt = DBD::Breaktable->new($name);
1843+ while(1) {
1844+ parseCommon();
1845+ if (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) {
1846+ print " Breaktable-Point: $1, $2\n" if $debug;
1847+ $bt->add_point($1, $2);
1848+ }
1849+ elsif (m/\G $string \s* (?: , \s*)? $string (?: \s* ,)?/oxgc) {
1850+ print " Breaktable-Data: $1, $2\n" if $debug;
1851+ $bt->add_point($1, $2);
1852+ }
1853+ elsif (m/\G \}/oxgc) {
1854+ print " Breaktable-End:\n" if $debug;
1855+ $dbd->add($bt);
1856+ popContext("breaktable($name)");
1857+ return;
1858+ } else {
1859+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
1860+ dieContext("Syntax error in '$1'");
1861+ }
1862+ }
1863+}
1864+
1865+sub parse_recordtype {
1866+ my ($dbd, $name) = @_;
1867+ pushContext("recordtype($name)");
1868+ my $rtyp = DBD::Recordtype->new($name);
1869+ while(1) {
1870+ parseCommon();
1871+ if (m/\G field \s* \( \s* $string \s* , \s* $string \s* \) \s* \{/oxgc) {
1872+ print " Recordtype-Field: $1, $2\n" if $debug;
1873+ parse_field($rtyp, $1, $2);
1874+ }
1875+ elsif (m/\G \}/oxgc) {
1876+ print " Recordtype-End:\n" if $debug;
1877+ $dbd->add($rtyp);
1878+ popContext("recordtype($name)");
1879+ return;
1880+ }
1881+ elsif (m/\G % (.*) \n/oxgc) {
1882+ print " Recordtype-Cdef: $1\n" if $debug;
1883+ $rtyp->add_cdef($1);
1884+ } else {
1885+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
1886+ dieContext("Syntax error in '$1'");
1887+ }
1888+ }
1889+}
1890+
1891+sub parse_field {
1892+ my ($rtyp, $name, $field_type) = @_;
1893+ my $fld = DBD::Recfield->new($name, $field_type);
1894+ pushContext("field($name, $field_type)");
1895+ while(1) {
1896+ parseCommon();
1897+ if (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) {
1898+ print " Field-Attribute: $1, $2\n" if $debug;
1899+ $fld->add_attribute($1, $2);
1900+ }
1901+ elsif (m/\G \}/oxgc) {
1902+ print " Field-End:\n" if $debug;
1903+ $rtyp->add_field($fld);
1904+ popContext("field($name, $field_type)");
1905+ return;
1906+ } else {
1907+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
1908+ dieContext("Syntax error in '$1'");
1909+ }
1910+ }
1911+}
1912+
1913+1;
1914
1915=== added file 'src/tools/DBD/Recfield.pm'
1916--- src/tools/DBD/Recfield.pm 1970-01-01 00:00:00 +0000
1917+++ src/tools/DBD/Recfield.pm 2012-04-02 20:38:19 +0000
1918@@ -0,0 +1,436 @@
1919+package DBD::Recfield;
1920+use DBD::Base;
1921+@ISA = qw(DBD::Base);
1922+
1923+# The hash value is a regexp that matches all legal values of this field
1924+our %field_types = (
1925+ DBF_STRING => qr/.{0,40}/,
1926+ DBF_CHAR => $RXintx,
1927+ DBF_UCHAR => $RXuintx,
1928+ DBF_SHORT => $RXintx,
1929+ DBF_USHORT => $RXuintx,
1930+ DBF_LONG => $RXintx,
1931+ DBF_ULONG => $RXuintx,
1932+ DBF_FLOAT => $RXnum,
1933+ DBF_DOUBLE => $RXnum,
1934+ DBF_ENUM => qr/.*/,
1935+ DBF_MENU => qr/.*/,
1936+ DBF_DEVICE => qr/.*/,
1937+ DBF_INLINK => qr/.*/,
1938+ DBF_OUTLINK => qr/.*/,
1939+ DBF_FWDLINK => qr/.*/,
1940+ DBF_NOACCESS => qr//
1941+);
1942+
1943+# The hash value is a regexp that matches all legal values of this attribute
1944+our %field_attrs = (
1945+ asl => qr/^ASL[01]$/,
1946+ initial => qr/^.*$/,
1947+ promptgroup => qr/^GUI_\w+$/,
1948+ prompt => qr/^.*$/,
1949+ special => qr/^(?:SPC_\w+|\d{3,})$/,
1950+ pp => qr/^(?:TRUE|FALSE)$/,
1951+ interest => qr/^\d+$/,
1952+ base => qr/^(?:DECIMAL|HEX)$/,
1953+ size => qr/^\d+$/,
1954+ extra => qr/^.*$/,
1955+ menu => qr/^$RXident$/o
1956+);
1957+
1958+sub new {
1959+ my ($class, $name, $type) = @_;
1960+ dieContext("Illegal field type '$type', valid field types are:",
1961+ sort keys %field_types) unless exists $field_types{$type};
1962+ my $this = {};
1963+ bless $this, "${class}::${type}";
1964+ return $this->init($name, $type);
1965+}
1966+
1967+sub init {
1968+ my ($this, $name, $type) = @_;
1969+ unquote $type;
1970+ $this->SUPER::init($name, "record field name");
1971+ dieContext("Illegal field type '$type', valid field types are:",
1972+ sort keys %field_types) unless exists $field_types{$type};
1973+ $this->{DBF_TYPE} = $type;
1974+ $this->{ATTR_INDEX} = {};
1975+ return $this;
1976+}
1977+
1978+sub dbf_type {
1979+ return shift->{DBF_TYPE};
1980+}
1981+
1982+sub set_number {
1983+ my ($this, $number) = @_;
1984+ $this->{NUMBER} = $number;
1985+}
1986+
1987+sub number {
1988+ return shift->{NUMBER};
1989+}
1990+
1991+sub add_attribute {
1992+ my ($this, $attr, $value) = @_;
1993+ unquote $value;
1994+ my $match = $field_attrs{$attr};
1995+ dieContext("Unknown field attribute '$1', valid attributes are:",
1996+ sort keys %field_attrs)
1997+ unless defined $match;
1998+ dieContext("Bad value '$value' for field '$attr' attribute")
1999+ unless $value =~ m/$match/;
2000+ $this->{ATTR_INDEX}->{$attr} = $value;
2001+}
2002+
2003+sub attributes {
2004+ return shift->{ATTR_INDEX};
2005+}
2006+
2007+sub attribute {
2008+ my ($this, $attr) = @_;
2009+ return $this->attributes->{$attr};
2010+}
2011+
2012+sub check_valid {
2013+ my ($this) = @_;
2014+ my $name = $this->name;
2015+ my $default = $this->attribute("initial");
2016+ dieContext("Default value '$default' is invalid for field '$name'")
2017+ if (defined($default) and !$this->legal_value($default));
2018+}
2019+
2020+# The C structure member name is usually the field name converted to
2021+# lower-case. However if that is a reserved word, use the original.
2022+sub C_name {
2023+ my ($this) = @_;
2024+ my $name = lc $this->name;
2025+ $name = $this->name
2026+ if is_reserved($name);
2027+ return $name;
2028+}
2029+
2030+sub toDeclaration {
2031+ my ($this, $ctype) = @_;
2032+ my $name = $this->C_name;
2033+ my $result = sprintf " %-19s %-12s", $ctype, "$name;";
2034+ my $prompt = $this->attribute('prompt');
2035+ $result .= "/* $prompt */" if defined $prompt;
2036+ return $result;
2037+}
2038+
2039+
2040+################################################################################
2041+
2042+package DBD::Recfield::DBF_STRING;
2043+
2044+use DBD::Base;
2045+@ISA = qw(DBD::Recfield);
2046+
2047+sub legal_value {
2048+ my ($this, $value) = @_;
2049+ return (length $value < $this->attribute('size'));
2050+ # NB - we use '<' to allow space for the terminating nil byte
2051+}
2052+
2053+sub check_valid {
2054+ my ($this) = @_;
2055+ dieContext("Size missing for DBF_STRING field '$name'")
2056+ unless exists $this->attributes->{'size'};
2057+ $this->SUPER::check_valid;
2058+}
2059+
2060+sub toDeclaration {
2061+ my ($this) = @_;
2062+ my $name = lc $this->name;
2063+ my $size = $this->attribute('size');
2064+ my $result = sprintf " %-19s %-12s", 'char', "${name}[${size}];";
2065+ my $prompt = $this->attribute('prompt');
2066+ $result .= "/* $prompt */" if defined $prompt;
2067+ return $result;
2068+}
2069+
2070+
2071+################################################################################
2072+
2073+package DBD::Recfield::DBF_CHAR;
2074+
2075+use DBD::Base;
2076+@ISA = qw(DBD::Recfield);
2077+
2078+sub legal_value {
2079+ my ($this, $value) = @_;
2080+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
2081+ return ($value =~ m/^ $RXint $/x and
2082+ $value >= -128 and
2083+ $value <= 127);
2084+}
2085+
2086+sub toDeclaration {
2087+ return shift->SUPER::toDeclaration("epicsInt8");
2088+}
2089+
2090+
2091+################################################################################
2092+
2093+package DBD::Recfield::DBF_UCHAR;
2094+
2095+use DBD::Base;
2096+@ISA = qw(DBD::Recfield);
2097+
2098+sub legal_value {
2099+ my ($this, $value) = @_;
2100+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
2101+ return ($value =~ m/^ $RXuint $/x and
2102+ $value >= 0 and
2103+ $value <= 255);
2104+}
2105+
2106+sub toDeclaration {
2107+ return shift->SUPER::toDeclaration("epicsUInt8");
2108+}
2109+
2110+
2111+################################################################################
2112+
2113+package DBD::Recfield::DBF_SHORT;
2114+
2115+use DBD::Base;
2116+@ISA = qw(DBD::Recfield);
2117+
2118+sub legal_value {
2119+ my ($this, $value) = @_;
2120+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
2121+ return ($value =~ m/^ $RXint $/x and
2122+ $value >= -32768 and
2123+ $value <= 32767);
2124+}
2125+
2126+sub toDeclaration {
2127+ return shift->SUPER::toDeclaration("epicsInt16");
2128+}
2129+
2130+
2131+################################################################################
2132+
2133+package DBD::Recfield::DBF_USHORT;
2134+
2135+use DBD::Base;
2136+@ISA = qw(DBD::Recfield);
2137+
2138+sub legal_value {
2139+ my ($this, $value) = @_;
2140+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
2141+ return ($value =~ m/^ $RXuint $/x and
2142+ $value >= 0 and
2143+ $value <= 65535);
2144+}
2145+
2146+sub toDeclaration {
2147+ return shift->SUPER::toDeclaration("epicsUInt16");
2148+}
2149+
2150+
2151+################################################################################
2152+
2153+package DBD::Recfield::DBF_LONG;
2154+
2155+use DBD::Base;
2156+@ISA = qw(DBD::Recfield);
2157+
2158+sub legal_value {
2159+ my ($this, $value) = @_;
2160+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
2161+ return ($value =~ m/^ $RXint $/x);
2162+}
2163+
2164+sub toDeclaration {
2165+ return shift->SUPER::toDeclaration("epicsInt32");
2166+}
2167+
2168+
2169+################################################################################
2170+
2171+package DBD::Recfield::DBF_ULONG;
2172+
2173+use DBD::Base;
2174+@ISA = qw(DBD::Recfield);
2175+
2176+sub legal_value {
2177+ my ($this, $value) = @_;
2178+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
2179+ return ($value =~ m/^ $RXuint $/x and
2180+ $value >= 0);
2181+}
2182+
2183+sub toDeclaration {
2184+ return shift->SUPER::toDeclaration("epicsUInt32");
2185+}
2186+
2187+
2188+################################################################################
2189+
2190+package DBD::Recfield::DBF_FLOAT;
2191+
2192+use DBD::Base;
2193+@ISA = qw(DBD::Recfield);
2194+
2195+sub legal_value {
2196+ my ($this, $value) = @_;
2197+ return ($value =~ m/^ $RXnum $/x);
2198+}
2199+
2200+sub toDeclaration {
2201+ return shift->SUPER::toDeclaration("epicsFloat32");
2202+}
2203+
2204+
2205+################################################################################
2206+
2207+package DBD::Recfield::DBF_DOUBLE;
2208+
2209+use DBD::Base;
2210+@ISA = qw(DBD::Recfield);
2211+
2212+sub legal_value {
2213+ my ($this, $value) = @_;
2214+ return ($value =~ m/^ $RXnum $/x);
2215+}
2216+
2217+sub toDeclaration {
2218+ return shift->SUPER::toDeclaration("epicsFloat64");
2219+}
2220+
2221+
2222+################################################################################
2223+
2224+package DBD::Recfield::DBF_ENUM;
2225+
2226+use DBD::Base;
2227+@ISA = qw(DBD::Recfield);
2228+
2229+sub legal_value {
2230+ return 1;
2231+}
2232+
2233+sub toDeclaration {
2234+ return shift->SUPER::toDeclaration("epicsEnum16");
2235+}
2236+
2237+
2238+################################################################################
2239+
2240+package DBD::Recfield::DBF_MENU;
2241+
2242+use DBD::Base;
2243+@ISA = qw(DBD::Recfield);
2244+
2245+sub legal_value {
2246+ # FIXME: If we know the menu name and the menu exists, check further
2247+ return 1;
2248+}
2249+
2250+sub check_valid {
2251+ my ($this) = @_;
2252+ dieContext("Menu name missing for DBF_MENU field '$name'")
2253+ unless defined($this->attribute("menu"));
2254+ $this->SUPER::check_valid;
2255+}
2256+
2257+sub toDeclaration {
2258+ return shift->SUPER::toDeclaration("epicsEnum16");
2259+}
2260+
2261+
2262+################################################################################
2263+
2264+package DBD::Recfield::DBF_DEVICE;
2265+
2266+use DBD::Base;
2267+@ISA = qw(DBD::Recfield);
2268+
2269+sub legal_value {
2270+ return 1;
2271+}
2272+
2273+sub toDeclaration {
2274+ return shift->SUPER::toDeclaration("epicsEnum16");
2275+}
2276+
2277+
2278+################################################################################
2279+
2280+package DBD::Recfield::DBF_INLINK;
2281+
2282+use DBD::Base;
2283+@ISA = qw(DBD::Recfield);
2284+
2285+sub legal_value {
2286+ return 1;
2287+}
2288+
2289+sub toDeclaration {
2290+ return shift->SUPER::toDeclaration("DBLINK");
2291+}
2292+
2293+
2294+################################################################################
2295+
2296+package DBD::Recfield::DBF_OUTLINK;
2297+
2298+use DBD::Base;
2299+@ISA = qw(DBD::Recfield);
2300+
2301+sub legal_value {
2302+ return 1;
2303+}
2304+
2305+sub toDeclaration {
2306+ return shift->SUPER::toDeclaration("DBLINK");
2307+}
2308+
2309+
2310+################################################################################
2311+
2312+package DBD::Recfield::DBF_FWDLINK;
2313+
2314+use DBD::Base;
2315+@ISA = qw(DBD::Recfield);
2316+
2317+sub legal_value {
2318+ return 1;
2319+}
2320+
2321+sub toDeclaration {
2322+ return shift->SUPER::toDeclaration("DBLINK");
2323+}
2324+
2325+
2326+################################################################################
2327+
2328+package DBD::Recfield::DBF_NOACCESS;
2329+
2330+use DBD::Base;
2331+@ISA = qw(DBD::Recfield);
2332+
2333+sub legal_value {
2334+ my ($this, $value) = @_;
2335+ return ($value eq '');
2336+}
2337+
2338+sub check_valid {
2339+ my ($this) = @_;
2340+ dieContext("Type information missing for DBF_NOACCESS field '$name'")
2341+ unless defined($this->attribute("extra"));
2342+ $this->SUPER::check_valid;
2343+}
2344+
2345+sub toDeclaration {
2346+ my ($this) = @_;
2347+ my $extra = $this->attribute('extra');
2348+ my $result = sprintf " %-31s ", "$extra;";
2349+ my $prompt = $this->attribute('prompt');
2350+ $result .= "/* $prompt */" if defined $prompt;
2351+ return $result;
2352+}
2353+
2354+1;
2355
2356=== added file 'src/tools/DBD/Recordtype.pm'
2357--- src/tools/DBD/Recordtype.pm 1970-01-01 00:00:00 +0000
2358+++ src/tools/DBD/Recordtype.pm 2012-04-02 20:38:19 +0000
2359@@ -0,0 +1,100 @@
2360+package DBD::Recordtype;
2361+use DBD::Base;
2362+@ISA = qw(DBD::Base);
2363+
2364+use Carp;
2365+
2366+sub init {
2367+ my $this = shift;
2368+ $this->SUPER::init(@_);
2369+ $this->{FIELD_LIST} = [];
2370+ $this->{FIELD_INDEX} = {};
2371+ $this->{DEVICE_LIST} = [];
2372+ $this->{DEVICE_INDEX} = {};
2373+ $this->{CDEFS} = [];
2374+ return $this;
2375+}
2376+
2377+sub add_field {
2378+ my ($this, $field) = @_;
2379+ confess "Not a DBD::Recfield" unless $field->isa('DBD::Recfield');
2380+ my $field_name = $field->name;
2381+ dieContext("Duplicate field name '$field_name'")
2382+ if exists $this->{FIELD_INDEX}->{$field_name};
2383+ $field->check_valid;
2384+ $field->set_number(scalar @{$this->{FIELD_LIST}});
2385+ push @{$this->{FIELD_LIST}}, $field;
2386+ $this->{FIELD_INDEX}->{$field_name} = $field;
2387+}
2388+
2389+sub fields {
2390+ return @{shift->{FIELD_LIST}};
2391+}
2392+
2393+sub field_names { # In their original order...
2394+ my $this = shift;
2395+ my @names = ();
2396+ foreach ($this->fields) {
2397+ push @names, $_->name
2398+ }
2399+ return @names;
2400+}
2401+
2402+sub field {
2403+ my ($this, $field_name) = @_;
2404+ return $this->{FIELD_INDEX}->{$field_name};
2405+}
2406+
2407+sub add_device {
2408+ my ($this, $device) = @_;
2409+ confess "Not a DBD::Device" unless $device->isa('DBD::Device');
2410+ my $choice = $device->choice;
2411+ if (exists $this->{DEVICE_INDEX}->{$choice}) {
2412+ my @warning = ("Duplicate device type '$choice'");
2413+ my $old = $this->{DEVICE_INDEX}->{$choice};
2414+ push @warning, "Link types differ"
2415+ if ($old->link_type ne $device->link_type);
2416+ push @warning, "DSETs differ"
2417+ if ($old->name ne $device->name);
2418+ warnContext(@warning);
2419+ return;
2420+ }
2421+ push @{$this->{DEVICE_LIST}}, $device;
2422+ $this->{DEVICE_INDEX}->{$choice} = $device;
2423+}
2424+
2425+sub devices {
2426+ return @{shift->{DEVICE_LIST}};
2427+}
2428+
2429+sub device {
2430+ my ($this, $choice) = @_;
2431+ return $this->{DEVICE_INDEX}->{$choice};
2432+}
2433+
2434+sub add_cdef {
2435+ my ($this, $cdef) = @_;
2436+ push @{$this->{CDEFS}}, $cdef;
2437+}
2438+
2439+sub cdefs {
2440+ return @{shift->{CDEFS}};
2441+}
2442+
2443+sub toCdefs {
2444+ return join("\n", shift->cdefs) . "\n\n";
2445+}
2446+
2447+sub toDeclaration {
2448+ my $this = shift;
2449+ my @fields = map {
2450+ $_->toDeclaration
2451+ } $this->fields;
2452+ my $name = $this->name;
2453+ $name .= "Record" unless $name eq "dbCommon";
2454+ return "typedef struct $name {\n" .
2455+ join("\n", @fields) .
2456+ "\n} $name;\n\n";
2457+}
2458+
2459+1;
2460
2461=== added file 'src/tools/DBD/Registrar.pm'
2462--- src/tools/DBD/Registrar.pm 1970-01-01 00:00:00 +0000
2463+++ src/tools/DBD/Registrar.pm 2012-04-02 20:38:19 +0000
2464@@ -0,0 +1,11 @@
2465+package DBD::Registrar;
2466+use DBD::Base;
2467+@ISA = qw(DBD::Base);
2468+
2469+sub init {
2470+ return shift->SUPER::init(shift, "registrar function name");
2471+}
2472+
2473+
2474+1;
2475+
2476
2477=== added file 'src/tools/DBD/Variable.pm'
2478--- src/tools/DBD/Variable.pm 1970-01-01 00:00:00 +0000
2479+++ src/tools/DBD/Variable.pm 2012-04-02 20:38:19 +0000
2480@@ -0,0 +1,36 @@
2481+package DBD::Variable;
2482+use DBD::Base;
2483+@ISA = qw(DBD::Base);
2484+
2485+my %valid_types = (
2486+ # C type name => corresponding iocshArg type identifier
2487+ int => 'iocshArgInt',
2488+ double => 'iocshArgDouble'
2489+);
2490+
2491+sub init {
2492+ my ($this, $name, $type) = @_;
2493+ if (defined $type) {
2494+ unquote $type;
2495+ } else {
2496+ $type = "int";
2497+ }
2498+ exists $valid_types{$type} or
2499+ dieContext("Unknown variable type '$type', valid types are:",
2500+ sort keys %valid_types);
2501+ $this->SUPER::init($name, "variable name");
2502+ $this->{VAR_TYPE} = $type;
2503+ return $this;
2504+}
2505+
2506+sub var_type {
2507+ my $this = shift;
2508+ return $this->{VAR_TYPE};
2509+}
2510+
2511+sub iocshArg_type {
2512+ my $this = shift;
2513+ return $valid_types{$this->{VAR_TYPE}};
2514+}
2515+
2516+1;
2517
2518=== added file 'src/tools/EPICS/Readfile.pm'
2519--- src/tools/EPICS/Readfile.pm 1970-01-01 00:00:00 +0000
2520+++ src/tools/EPICS/Readfile.pm 2012-04-02 20:38:19 +0000
2521@@ -0,0 +1,101 @@
2522+#*************************************************************************
2523+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
2524+# National Laboratory.
2525+# EPICS BASE is distributed subject to a Software License Agreement found
2526+# in file LICENSE that is included with this distribution.
2527+#*************************************************************************
2528+
2529+# $Id$
2530+
2531+package EPICS::Readfile;
2532+require 5.000;
2533+require Exporter;
2534+
2535+use EPICS::macLib;
2536+
2537+@ISA = qw(Exporter);
2538+@EXPORT = qw(@inputfiles &Readfile);
2539+
2540+our $debug=0;
2541+our @inputfiles;
2542+
2543+sub slurp {
2544+ my ($FILE, $Rpath) = @_;
2545+ my @path = @{$Rpath};
2546+ print "slurp($FILE):\n" if $debug;
2547+ if ($FILE !~ m[/]) {
2548+ foreach $dir (@path) {
2549+ print " trying $dir/$FILE\n" if $debug;
2550+ if (-r "$dir/$FILE") {
2551+ $FILE = "$dir/$FILE";
2552+ last;
2553+ }
2554+ }
2555+ die "Can't find file '$FILE'\n" unless -r $FILE;
2556+ }
2557+ print " opening $FILE\n" if $debug;
2558+ open FILE, "<$FILE" or die "Can't open $FILE: $!\n";
2559+ push @inputfiles, $FILE;
2560+ my @lines = ("##!BEGIN{$FILE}!##\n");
2561+ # Consider replacing these markers with C pre-processor linemarkers.
2562+ # See 'info cpp' * Preprocessor Output:: for details.
2563+ push @lines, <FILE>;
2564+ push @lines, "##!END{$FILE}!##\n";
2565+ close FILE or die "Error closing $FILE: $!\n";
2566+ print " read ", scalar @lines, " lines\n" if $debug;
2567+ return join '', @lines;
2568+}
2569+
2570+sub expandMacros {
2571+ my ($macros, $input) = @_;
2572+ return $input unless $macros;
2573+ return $macros->expandString($input);
2574+}
2575+
2576+sub splitPath {
2577+ my ($path) = @_;
2578+ my (@path) = split /[:;]/, $path;
2579+ grep s/^$/./, @path;
2580+ return @path;
2581+}
2582+
2583+my $RXstr = qr/ " (?: [^"] | \\" )* "/ox;
2584+my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o;
2585+my $string = qr/ ( $RXnam | $RXstr ) /ox;
2586+
2587+sub unquote {
2588+ my ($s) = @_;
2589+ $s =~ s/^"(.*)"$/$1/o;
2590+ return $s;
2591+}
2592+
2593+sub Readfile {
2594+ my ($file, $macros, $Rpath) = @_;
2595+ print "Readfile($file)\n" if $debug;
2596+ my $input = &expandMacros($macros, &slurp($file, $Rpath));
2597+ my @input = split /\n/, $input;
2598+ my @output;
2599+ foreach (@input) {
2600+ if (m/^ \s* include \s+ $string /ox) {
2601+ $arg = &unquote($1);
2602+ print " include $arg\n" if $debug;
2603+ push @output, "##! include \"$arg\"";
2604+ push @output, &Readfile($arg, $macros, $Rpath);
2605+ } elsif (m/^ \s* addpath \s+ $string /ox) {
2606+ $arg = &unquote($1);
2607+ print " addpath $arg\n" if $debug;
2608+ push @output, "##! addpath \"$arg\"";
2609+ push @{$Rpath}, &splitPath($arg);
2610+ } elsif (m/^ \s* path \s+ $string /ox) {
2611+ $arg = &unquote($1);
2612+ print " path $arg\n" if $debug;
2613+ push @output, "##! path \"$arg\"";
2614+ @{$Rpath} = &splitPath($arg);
2615+ } else {
2616+ push @output, $_;
2617+ }
2618+ }
2619+ return join "\n", @output;
2620+}
2621+
2622+1;
2623
2624=== added file 'src/tools/EPICS/macLib.pm'
2625--- src/tools/EPICS/macLib.pm 1970-01-01 00:00:00 +0000
2626+++ src/tools/EPICS/macLib.pm 2012-04-02 20:38:19 +0000
2627@@ -0,0 +1,251 @@
2628+#*************************************************************************
2629+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
2630+# National Laboratory.
2631+# EPICS BASE is distributed subject to a Software License Agreement found
2632+# in file LICENSE that is included with this distribution.
2633+#*************************************************************************
2634+
2635+# $Id$
2636+
2637+package EPICS::macLib::entry;
2638+
2639+sub new ($$) {
2640+ my $class = shift;
2641+ my $this = {
2642+ name => shift,
2643+ type => shift,
2644+ raw => '',
2645+ val => '',
2646+ visited => 0,
2647+ error => 0,
2648+ };
2649+ bless $this, $class;
2650+ return $this;
2651+}
2652+
2653+sub report ($) {
2654+ my ($this) = @_;
2655+ return unless defined $this->{raw};
2656+ printf "%1s %-16s %-16s %s\n",
2657+ ($this->{error} ? '*' : ' '), $this->{name}, $this->{raw}, $this->{val};
2658+}
2659+
2660+
2661+package EPICS::macLib;
2662+
2663+use Carp;
2664+
2665+sub new ($@) {
2666+ my $proto = shift;
2667+ my $class = ref($proto) || $proto;
2668+ my $this = {
2669+ dirty => 0,
2670+ noWarn => 0,
2671+ macros => [{}], # [0] is current scope, [1] is parent etc.
2672+ };
2673+ bless $this, $class;
2674+ $this->installList(@_);
2675+ return $this;
2676+}
2677+
2678+sub installList ($@) {
2679+ # Argument is a list of strings which are arguments to installMacros
2680+ my $this = shift;
2681+ while (@_) {
2682+ $this->installMacros(shift);
2683+ }
2684+}
2685+
2686+sub installMacros ($$) {
2687+ # Argument is a string: a=1,b="2",c,d='hello'
2688+ my $this = shift;
2689+ $_ = shift;
2690+ until (defined pos($_) and pos($_) == length($_)) {
2691+ m/\G \s* /xgc; # Skip whitespace
2692+ if (m/\G ( [A-Za-z0-9_-]+ ) \s* /xgc) {
2693+ my ($name, $val) = ($1);
2694+ if (m/\G = \s* /xgc) {
2695+ # The value follows, handle quotes and escapes
2696+ until (pos($_) == length($_)) {
2697+ if (m/\G , /xgc) { last; }
2698+ elsif (m/\G ' ( ( [^'] | \\ ' )* ) ' /xgc) { $val .= $1; }
2699+ elsif (m/\G " ( ( [^"] | \\ " )* ) " /xgc) { $val .= $1; }
2700+ elsif (m/\G \\ ( . ) /xgc) { $val .= $1; }
2701+ elsif (m/\G ( . ) /xgc) { $val .= $1; }
2702+ else { die "How did I get here?"; }
2703+ }
2704+ $this->putValue($name, $val);
2705+ } elsif (m/\G , /xgc or (pos($_) == length($_))) {
2706+ $this->putValue($name, undef);
2707+ } else {
2708+ warn "How did I get here?";
2709+ }
2710+ } elsif (m/\G ( .* )/xgc) {
2711+ croak "Can't find a macro definition in '$1'";
2712+ } else {
2713+ last;
2714+ }
2715+ }
2716+}
2717+
2718+sub putValue ($$$) {
2719+ my ($this, $name, $raw) = @_;
2720+ if (exists $this->{macros}[0]{$name}) {
2721+ if (!defined $raw) {
2722+ delete $this->{macros}[0]{$name};
2723+ } else {
2724+ $this->{macros}[0]{$name}{raw} = $raw;
2725+ }
2726+ } else {
2727+ my $entry = EPICS::macLib::entry->new($name, 'macro');
2728+ $entry->{raw} = $raw;
2729+ $this->{macros}[0]{$name} = $entry;
2730+ }
2731+ $this->{dirty} = 1;
2732+}
2733+
2734+sub pushScope ($) {
2735+ my ($this) = @_;
2736+ unshift @{$this->{macros}}, {};
2737+}
2738+
2739+sub popScope ($) {
2740+ my ($this) = @_;
2741+ shift @{$this->{macros}};
2742+}
2743+
2744+sub suppressWarning($$) {
2745+ my ($this, $suppress) = @_;
2746+ $this->{noWarn} = $suppress;
2747+}
2748+
2749+sub expandString($$) {
2750+ my ($this, $src) = @_;
2751+ $this->_expand;
2752+ my $entry = EPICS::macLib::entry->new($src, 'string');
2753+ my $result = $this->_translate($entry, 0, $src);
2754+ return $result unless $entry->{error};
2755+ return $this->{noWarn} ? $result : undef;
2756+}
2757+
2758+sub reportMacros ($) {
2759+ my ($this) = @_;
2760+ $this->_expand;
2761+ print "Macro report\n============\n";
2762+ foreach my $scope (@{$this->{macros}}) {
2763+ foreach my $name (keys %{$scope}) {
2764+ my $entry = $scope->{$name};
2765+ $entry->report;
2766+ }
2767+ } continue {
2768+ print " -- scope ends --\n";
2769+ }
2770+}
2771+
2772+
2773+# Private routines, not intended for public use
2774+
2775+sub _expand ($) {
2776+ my ($this) = @_;
2777+ return unless $this->{dirty};
2778+ foreach my $scope (@{$this->{macros}}) {
2779+ foreach my $name (keys %{$scope}) {
2780+ my $entry = $scope->{$name};
2781+ $entry->{val} = $this->_translate($entry, 1, $entry->{raw});
2782+ }
2783+ }
2784+ $this->{dirty} = 0;
2785+}
2786+
2787+sub _lookup ($$$$$) {
2788+ my ($this, $name) = @_;
2789+ foreach my $scope (@{$this->{macros}}) {
2790+ if (exists $scope->{$name}) {
2791+ return undef # Macro marked as deleted
2792+ unless defined $scope->{$name}{raw};
2793+ return $scope->{$name};
2794+ }
2795+ }
2796+ return undef;
2797+}
2798+
2799+sub _translate ($$$$) {
2800+ my ($this, $entry, $level, $str) = @_;
2801+ return $this->_trans($entry, $level, '', \$str);
2802+}
2803+
2804+sub _trans ($$$$$) {
2805+ my ($this, $entry, $level, $term, $R) = @_;
2806+ return $$R
2807+ if (!defined $$R or
2808+ $$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros
2809+ my $quote = 0;
2810+ my $val;
2811+ until (defined pos($$R) and pos($$R) == length($$R)) {
2812+ if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) {
2813+ last;
2814+ }
2815+ if ($$R =~ m/\G \$ ( [({] ) /xgc) {
2816+ my $macEnd = $1;
2817+ $macEnd =~ tr/({/)}/;
2818+ my $name2 = $this->_trans($entry, $level+1, "=$macEnd", $R);
2819+ my $entry2 = $this->_lookup($name2);
2820+ if (!defined $entry2) { # Macro not found
2821+ if ($$R =~ m/\G = /xgc) { # Use default value given
2822+ $val .= $this->_trans($entry, $level+1, $macEnd, $R);
2823+ } else {
2824+ unless ($this->{noWarn}) {
2825+ $entry->{error} = 1;
2826+ printf STDERR "macLib: macro '%s' is undefined (expanding %s '%s')\n",
2827+ $name2, $entry->{type}, $entry->{name};
2828+ }
2829+ $val .= "\$($name2)";
2830+ }
2831+ $$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
2832+ } else { # Macro found
2833+ if ($entry2->{visited}) {
2834+ $entry->{error} = 1;
2835+ printf STDERR "macLib: %s '%s' is recursive (expanding %s '%s')\n",
2836+ $entry->{type}, $entry->{name}, $entry2->{type}, $entry2->{name};
2837+ $val .= "\$($name)";
2838+ } else {
2839+ if ($$R =~ m/\G = /xgc) { # Discard default value
2840+ local $this->{noWarn} = 1; # Temporarily kill warnings
2841+ $this->_trans($entry, $level+1, $macEnd, $R);
2842+ }
2843+ $$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
2844+ if ($this->{dirty}) { # Translate raw value
2845+ $entry2->{visited} = 1;
2846+ $val .= $this->_trans($entry, $level+1, '', \$entry2->{raw});
2847+ $entry2->{visited} = 0;
2848+ } else {
2849+ $val .= $entry2->{val}; # Here's one I made earlier...
2850+ }
2851+ }
2852+ }
2853+ } elsif ($level > 0) { # Discard quotes and escapes
2854+ if ($quote and $$R =~ m/\G $quote /xgc) {
2855+ $quote = 0;
2856+ } elsif ($$R =~ m/\G ( ['"] ) /xgc) {
2857+ $quote = $1;
2858+ } elsif ($$R =~ m/\G \\? ( . ) /xgc) {
2859+ $val .= $1;
2860+ } else {
2861+ warn "How did I get here? level=$level";
2862+ }
2863+ } else { # Level 0
2864+ if ($$R =~ m/\G \\ ( . ) /xgc) {
2865+ $val .= "\\$1";
2866+ } elsif ($$R =~ m/\G ( [^\\\$'")}]* ) /xgc) {
2867+ $val .= $1;
2868+ } elsif ($$R =~ m/\G ( . ) /xgc) {
2869+ $val .= $1;
2870+ } else {
2871+ warn "How did I get here? level=$level";
2872+ }
2873+ }
2874+ }
2875+ return $val;
2876+}
2877+
2878+1;
2879
2880=== modified file 'src/tools/Makefile'
2881--- src/tools/Makefile 2008-09-23 22:13:52 +0000
2882+++ src/tools/Makefile 2012-04-02 20:38:19 +0000
2883@@ -1,5 +1,5 @@
2884 #*************************************************************************
2885-# Copyright (c) 2008 UChicago Argonne LLC, as Operator of Argonne
2886+# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
2887 # National Laboratory.
2888 # EPICS BASE is distributed subject to a Software License Agreement found
2889 # in file LICENSE that is included with this distribution.
2890@@ -14,7 +14,23 @@
2891 PERL_MODULES += EPICS/Copy.pm
2892 PERL_MODULES += EPICS/Path.pm
2893 PERL_MODULES += EPICS/Release.pm
2894+PERL_MODULES += EPICS/Readfile.pm
2895 PERL_MODULES += EPICS/Getopts.pm
2896+PERL_MODULES += EPICS/macLib.pm
2897+
2898+PERL_MODULES += DBD.pm
2899+PERL_MODULES += DBD/Base.pm
2900+PERL_MODULES += DBD/Breaktable.pm
2901+PERL_MODULES += DBD/Device.pm
2902+PERL_MODULES += DBD/Driver.pm
2903+PERL_MODULES += DBD/Function.pm
2904+PERL_MODULES += DBD/Menu.pm
2905+PERL_MODULES += DBD/Output.pm
2906+PERL_MODULES += DBD/Parser.pm
2907+PERL_MODULES += DBD/Recfield.pm
2908+PERL_MODULES += DBD/Recordtype.pm
2909+PERL_MODULES += DBD/Registrar.pm
2910+PERL_MODULES += DBD/Variable.pm
2911
2912 PERL_SCRIPTS += convertRelease.pl
2913 PERL_SCRIPTS += cvsclean.pl
2914@@ -32,5 +48,10 @@
2915 PERL_SCRIPTS += replaceVAR.pl
2916 PERL_SCRIPTS += useManifestTool.pl
2917
2918+PERL_SCRIPTS += dbdToMenuH.pl
2919+PERL_SCRIPTS += dbdToRecordtypeH.pl
2920+PERL_SCRIPTS += dbdExpand.pl
2921+PERL_SCRIPTS += dbdToHtml.pl
2922+
2923 include $(TOP)/configure/RULES
2924
2925
2926=== added file 'src/tools/dbdExpand.pl'
2927--- src/tools/dbdExpand.pl 1970-01-01 00:00:00 +0000
2928+++ src/tools/dbdExpand.pl 2012-04-02 20:38:19 +0000
2929@@ -0,0 +1,53 @@
2930+#!/usr/bin/perl
2931+
2932+#*************************************************************************
2933+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
2934+# National Laboratory.
2935+# EPICS BASE is distributed subject to a Software License Agreement found
2936+# in file LICENSE that is included with this distribution.
2937+#*************************************************************************
2938+
2939+# $Id$
2940+
2941+use FindBin qw($Bin);
2942+use lib "$Bin/../../lib/perl";
2943+
2944+use DBD;
2945+use DBD::Parser;
2946+use DBD::Output;
2947+use EPICS::Getopts;
2948+use EPICS::Readfile;
2949+use EPICS::macLib;
2950+
2951+getopts('DI@S@o:') or
2952+ die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ...";
2953+
2954+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
2955+my $macros = EPICS::macLib->new(@opt_S);
2956+my $dbd = DBD->new();
2957+
2958+while (@ARGV) {
2959+ &ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
2960+}
2961+
2962+if ($opt_D) { # Output dependencies only
2963+ my %filecount;
2964+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
2965+ print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
2966+ print map { "$_:\n" } @uniqfiles;
2967+ exit 0;
2968+}
2969+
2970+my $out;
2971+if ($opt_o) {
2972+ open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
2973+} else {
2974+ $out = STDOUT;
2975+}
2976+
2977+&OutputDBD($out, $dbd);
2978+
2979+if ($opt_o) {
2980+ close $out or die "Closing $opt_o failed: $!\n";
2981+}
2982+exit 0;
2983
2984=== added file 'src/tools/dbdReport.pl'
2985--- src/tools/dbdReport.pl 1970-01-01 00:00:00 +0000
2986+++ src/tools/dbdReport.pl 2012-04-02 20:38:19 +0000
2987@@ -0,0 +1,64 @@
2988+#!/usr/bin/perl
2989+
2990+#*************************************************************************
2991+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
2992+# National Laboratory.
2993+# EPICS BASE is distributed subject to a Software License Agreement found
2994+# in file LICENSE that is included with this distribution.
2995+#*************************************************************************
2996+
2997+# $Id$
2998+
2999+use FindBin qw($Bin);
3000+use lib "$Bin/../../lib/perl";
3001+
3002+use DBD;
3003+use DBD::Parser;
3004+use EPICS::Getopts;
3005+use EPICS::macLib;
3006+use EPICS::Readfile;
3007+use Text::Wrap;
3008+
3009+#$EPICS::Readfile::debug = 1;
3010+#$DBD::Parser::debug = 1;
3011+
3012+getopts('I@S@') or die usage();
3013+
3014+sub usage() {
3015+ "Usage: dbdReport [-I dir:dir2] [-S macro=val,...] file.dbd ...";
3016+}
3017+
3018+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
3019+my $macros = EPICS::macLib->new(@opt_S);
3020+my $dbd = DBD->new();
3021+
3022+&ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
3023+
3024+$Text::Wrap::columns = 75;
3025+
3026+my @menus = sort keys %{$dbd->menus};
3027+print wrap("Menus:\t", "\t", join(', ', @menus)), "\n"
3028+ if @menus;
3029+my @drivers = sort keys %{$dbd->drivers};
3030+print wrap("Drivers: ", "\t", join(', ', @drivers)), "\n"
3031+ if @drivers;
3032+my @variables = sort keys %{$dbd->variables};
3033+print wrap("Variables: ", "\t", join(', ', @variables)), "\n"
3034+ if @variables;
3035+my @registrars = sort keys %{$dbd->registrars};
3036+print wrap("Registrars: ", "\t", join(', ', @registrars)), "\n"
3037+ if @registrars;
3038+my @breaktables = sort keys %{$dbd->breaktables};
3039+print wrap("Breaktables: ", "\t", join(', ', @breaktables)), "\n"
3040+ if @breaktables;
3041+my %recordtypes = %{$dbd->recordtypes};
3042+if (%recordtypes) {
3043+ @rtypes = sort keys %recordtypes;
3044+ print wrap("Recordtypes: ", "\t", join(', ', @rtypes)), "\n";
3045+ foreach my $rtyp (@rtypes) {
3046+ my @devices = $recordtypes{$rtyp}->devices;
3047+ print wrap("Devices($rtyp): ", "\t",
3048+ join(', ', map {$_->choice} @devices)), "\n"
3049+ if @devices;
3050+ }
3051+}
3052
3053=== added file 'src/tools/dbdToHtml.pl'
3054--- src/tools/dbdToHtml.pl 1970-01-01 00:00:00 +0000
3055+++ src/tools/dbdToHtml.pl 2012-04-02 20:38:19 +0000
3056@@ -0,0 +1,252 @@
3057+#!/usr/bin/perl
3058+
3059+#*************************************************************************
3060+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
3061+# National Laboratory.
3062+# EPICS BASE is distributed subject to a Software License Agreement found
3063+# in file LICENSE that is included with this distribution.
3064+#*************************************************************************
3065+
3066+# $Id$
3067+
3068+use FindBin qw($Bin);
3069+use lib "$Bin/../../lib/perl";
3070+
3071+use DBD;
3072+use DBD::Parser;
3073+use EPICS::Getopts;
3074+use EPICS::macLib;
3075+use EPICS::Readfile;
3076+
3077+my $tool = 'dbdToHtml';
3078+getopts('DI@o:') or
3079+ die "Usage: $tool [-D] [-I dir] [-o xRecord.html] xRecord.dbd\n";
3080+
3081+my @path = map { split /[:;]/ } @opt_I;
3082+my $dbd = DBD->new();
3083+
3084+my $infile = shift @ARGV;
3085+$infile =~ m/\.dbd$/ or
3086+ die "$tool: Input file '$infile' must have '.dbd' extension\n";
3087+
3088+&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
3089+
3090+if ($opt_D) { # Output dependencies only
3091+ my %filecount;
3092+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
3093+ print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
3094+ print map { "$_:\n" } @uniqfiles;
3095+ exit 0;
3096+}
3097+
3098+my $out;
3099+if ($opt_o) {
3100+ $out = $opt_o;
3101+} else {
3102+ ($out = $infile) =~ s/\.dbd$/.html/;
3103+ $out =~ s/^.*\///;
3104+ $out =~ s/dbCommonRecord/dbCommon/;
3105+}
3106+open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
3107+
3108+print $out "<h1>$infile</h1>\n";
3109+
3110+my $rtypes = $dbd->recordtypes;
3111+
3112+my ($rn, $rtyp) = each %{$rtypes};
3113+print $out "<h2>Record Name $rn</h2>\n";
3114+
3115+my @fields = $rtyp->fields;
3116+
3117+#create a Hash to store the table of field information for each GUI type
3118+%dbdTables = (
3119+ "GUI_COMMON" => "",
3120+ "GUI_COMMON" => "",
3121+ "GUI_ALARMS" => "",
3122+ "GUI_BITS1" => "",
3123+ "GUI_BITS2" => "",
3124+ "GUI_CALC" => "",
3125+ "GUI_CLOCK" => "",
3126+ "GUI_COMPRESS" => "",
3127+ "GUI_CONVERT" => "",
3128+ "GUI_DISPLAY" => "",
3129+ "GUI_HIST" => "",
3130+ "GUI_INPUTS" => "",
3131+ "GUI_LINKS" => "",
3132+ "GUI_MBB" => "",
3133+ "GUI_MOTOR" => "",
3134+ "GUI_OUTPUT" => "",
3135+ "GUI_PID" => "",
3136+ "GUI_PULSE" => "",
3137+ "GUI_SELECT" => "",
3138+ "GUI_SEQ1" => "",
3139+ "GUI_SEQ2" => "",
3140+ "GUI_SEQ3" => "",
3141+ "GUI_SUB" => "",
3142+ "GUI_TIMER" => "",
3143+ "GUI_WAVE" => "",
3144+ "GUI_SCAN" => "",
3145+ "GUI_NONE" => ""
3146+);
3147+
3148+
3149+#Loop over all of the fields. Build a string that contains the table body
3150+#for each of the GUI Types based on which fields go with which GUI type.
3151+foreach $fVal (@fields) {
3152+ my $pg = $fVal->attribute('promptgroup');
3153+ while ( ($typ1, $content) = each %dbdTables) {
3154+ if ( $pg eq $typ1 or ($pg eq "" and $typ1 eq "GUI_NONE")) {
3155+ buildTableRow($fVal, $dbdTables{$typ1} );
3156+ }
3157+ }
3158+}
3159+
3160+#Write out each table
3161+while ( ($typ2, $content) = each %dbdTables) {
3162+ printHtmlTable($typ2, $content);
3163+}
3164+
3165+
3166+#add a field to a table body. The specified field and table body are passed
3167+#in as parameters
3168+sub buildTableRow {
3169+ my ( $fld, $outStr) = @_;
3170+ $longDesc = "&nbsp;";
3171+ %htmlCellFmt = (
3172+ rowStart => "<tr><td rowspan = \"2\">",
3173+ nextCell => "</td><td>",
3174+ endRow => "</td></tr>",
3175+ nextRow => "<tr><td colspan = \"7\" align=left>"
3176+ );
3177+ my %cellFmt = %htmlCellFmt;
3178+ my $rowStart = $cellFmt{rowStart};
3179+ my $nextCell = $cellFmt{nextCell};
3180+ my $endRow = $cellFmt{endRow};
3181+ my $nextRow = $cellFmt{nextRow};
3182+ $outStr = $outStr . $rowStart;
3183+ $outStr = $outStr . $fld->name;
3184+ $outStr = $outStr . $nextCell;
3185+ $outStr = $outStr . $fld->attribute('prompt');
3186+ $outStr = $outStr . $nextCell;
3187+ my $recType = $fld->dbf_type;
3188+ $typStr = $recType;
3189+ if ($recType eq "DBF_STRING") {
3190+ $typStr = $recType . " [" . $fld->attribute('size') . "]";
3191+ }
3192+
3193+ $outStr = $outStr . $typStr;
3194+ $outStr = $outStr . $nextCell;
3195+ $outStr = $outStr . design($fld);
3196+ $outStr = $outStr . $nextCell;
3197+ my $initial = $fld->attribute('initial');
3198+ if ( $initial eq '' ) {$initial = "&nbsp;";}
3199+ $outStr = $outStr . $initial;
3200+ $outStr = $outStr . $nextCell;
3201+ $outStr = $outStr . readable($fld);
3202+ $outStr = $outStr . $nextCell;
3203+ $outStr = $outStr . writable($fld);
3204+ $outStr = $outStr . $nextCell;
3205+ $outStr = $outStr . processPassive($fld);
3206+ $outStr = $outStr . $endRow;
3207+ $outStr = $outStr . "\n";
3208+ $outStr = $outStr . $nextRow;
3209+ $outStr = $outStr . $longDesc;
3210+ $outStr = $outStr . $endRow;
3211+ $outStr = $outStr . "\n";
3212+ $_[1] = $outStr;
3213+}
3214+
3215+#Check if the prompt group is defined so that this can be used by clients
3216+sub design {
3217+ my $fld = $_[0];
3218+ my $pg = $fld->attribute('promptgroup');
3219+ if ( $pg eq '' ) {
3220+ my $result = 'No';
3221+ }
3222+ else {
3223+ my $result = 'Yes';
3224+ }
3225+}
3226+
3227+#Check if this field is readable by clients
3228+sub readable {
3229+ my $fld = $_[0];
3230+ if ( $fld->attribute('special') eq "SPC_DBADDR") {
3231+ $return = "Probably";
3232+ }
3233+ else{
3234+ if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
3235+ $return = "No";
3236+ }
3237+ else {
3238+ $return = "Yes"
3239+ }
3240+ }
3241+}
3242+
3243+#Check if this field is writable by clients
3244+sub writable {
3245+ my $fld = $_[0];
3246+ my $spec = $fld->attribute('special');
3247+ if ( $spec eq "SPC_NOMOD" ) {
3248+ $return = "No";
3249+ }
3250+ else {
3251+ if ( $spec ne "SPC_DBADDR") {
3252+ if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
3253+ $return = "No";
3254+ }
3255+ else {
3256+ $return = "Yes";
3257+ }
3258+ }
3259+ else {
3260+ $return = "Maybe";
3261+ }
3262+ }
3263+}
3264+
3265+
3266+#Check to see if the field is process passive on caput
3267+sub processPassive {
3268+ my $fld = $_[0];
3269+ $pp = $fld->attribute('pp');
3270+ if ( $pp eq "YES" or $pp eq "TRUE" ) {
3271+ $result = "Yes";
3272+ }
3273+ elsif ( $PP eq "NO" or $pp eq "FALSE" or $pp eq "" ) {
3274+ $result = "No";
3275+ }
3276+}
3277+
3278+#print the start row to define a table
3279+sub printTableStart {
3280+ print $out "<table border =\"1\"> \n";
3281+ print $out "<caption><em>$_[0]</em></caption>";
3282+ print $out "<th>Field</th>\n";
3283+ print $out "<th>Summary</th>\n";
3284+ print $out "<th>Type</th>\n";
3285+ print $out "<th>DCT</th>\n";
3286+ print $out "<th>Default</th>\n";
3287+ print $out "<th>Read</th>\n";
3288+ print $out "<th>Write</th>\n";
3289+ print $out "<th>caPut=PP</th></tr>\n";
3290+
3291+}
3292+
3293+#print the tail end of the table
3294+sub printTableEnd {
3295+ print $out "</table>\n";
3296+}
3297+
3298+# Print the table for a GUI type. The name of the GUI type and the Table body
3299+# for this type are fed in as parameters
3300+sub printHtmlTable {
3301+ my ($typ2, $content) = $_;
3302+ if ( (length $_[1]) gt 0) {
3303+ printTableStart($_[0]);
3304+ print $out "$_[1]\n";
3305+ printTableEnd();
3306+ }
3307+
3308+}
3309
3310=== added file 'src/tools/dbdToMenuH.pl'
3311--- src/tools/dbdToMenuH.pl 1970-01-01 00:00:00 +0000
3312+++ src/tools/dbdToMenuH.pl 2012-04-02 20:38:19 +0000
3313@@ -0,0 +1,80 @@
3314+#!/usr/bin/perl
3315+
3316+#*************************************************************************
3317+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
3318+# National Laboratory.
3319+# EPICS BASE is distributed subject to a Software License Agreement found
3320+# in file LICENSE that is included with this distribution.
3321+#*************************************************************************
3322+
3323+# $Id$
3324+
3325+use FindBin qw($Bin);
3326+use lib "$Bin/../../lib/perl";
3327+
3328+use EPICS::Getopts;
3329+use File::Basename;
3330+use DBD;
3331+use DBD::Parser;
3332+use EPICS::macLib;
3333+use EPICS::Readfile;
3334+
3335+my $tool = 'dbdToMenuH.pl';
3336+
3337+use vars qw($opt_D @opt_I $opt_o $opt_s);
3338+getopts('DI@o:') or
3339+ die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n";
3340+
3341+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
3342+my $dbd = DBD->new();
3343+
3344+my $infile = shift @ARGV;
3345+$infile =~ m/\.dbd$/ or
3346+ die "$tool: Input file '$infile' must have '.dbd' extension\n";
3347+my $inbase = basename($infile);
3348+
3349+my $outfile;
3350+if ($opt_o) {
3351+ $outfile = $opt_o;
3352+} elsif (@ARGV) {
3353+ $outfile = shift @ARGV;
3354+} else {
3355+ ($outfile = $infile) =~ s/\.dbd$/.h/;
3356+ $outfile =~ s/^.*\///;
3357+}
3358+my $outbase = basename($outfile);
3359+
3360+# Derive a name for the include guard
3361+my $guard_name = "INC_$outbase";
3362+$guard_name =~ tr/a-zA-Z0-9_/_/cs;
3363+$guard_name =~ s/(_[hH])?$/_H/;
3364+
3365+&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
3366+
3367+if ($opt_D) {
3368+ my %filecount;
3369+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
3370+ print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
3371+ print map { "$_:\n" } @uniqfiles;
3372+} else {
3373+ open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
3374+ print OUTFILE "/* $outbase generated from $inbase */\n\n",
3375+ "#ifndef $guard_name\n",
3376+ "#define $guard_name\n\n";
3377+ my $menus = $dbd->menus;
3378+ while (my ($name, $menu) = each %{$menus}) {
3379+ print OUTFILE $menu->toDeclaration;
3380+ }
3381+# FIXME: Where to put metadata for widely used menus?
3382+# In the generated menu.h file is wrong: can't create a list of menu.h files.
3383+# Can only rely on registerRecordDeviceDriver output, so we must require that
3384+# all such menus be named "menu...", and any other menus must be defined in
3385+# the record.dbd file that needs them.
3386+# print OUTFILE "\n#ifdef GEN_MENU_METADATA\n\n";
3387+# while (($name, $menu) = each %{$menus}) {
3388+# print OUTFILE $menu->toDefinition;
3389+# }
3390+# print OUTFILE "\n#endif /* GEN_MENU_METADATA */\n";
3391+ print OUTFILE "\n#endif /* $guard_name */\n";
3392+ close OUTFILE;
3393+}
3394
3395=== added file 'src/tools/dbdToRecordtypeH.pl'
3396--- src/tools/dbdToRecordtypeH.pl 1970-01-01 00:00:00 +0000
3397+++ src/tools/dbdToRecordtypeH.pl 2012-04-02 20:38:19 +0000
3398@@ -0,0 +1,231 @@
3399+#!/usr/bin/perl
3400+
3401+#*************************************************************************
3402+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
3403+# National Laboratory.
3404+# EPICS BASE is distributed subject to a Software License Agreement found
3405+# in file LICENSE that is included with this distribution.
3406+#*************************************************************************
3407+
3408+# $Id$
3409+
3410+use FindBin qw($Bin);
3411+use lib "$Bin/../../lib/perl";
3412+
3413+use EPICS::Getopts;
3414+use File::Basename;
3415+use DBD;
3416+use DBD::Parser;
3417+use EPICS::macLib;
3418+use EPICS::Readfile;
3419+
3420+my $tool = 'dbdToRecordtypeH.pl';
3421+
3422+use vars qw($opt_D @opt_I $opt_o $opt_s);
3423+getopts('DI@o:s') or
3424+ die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n";
3425+
3426+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
3427+my $dbd = DBD->new();
3428+
3429+my $infile = shift @ARGV;
3430+$infile =~ m/\.dbd$/ or
3431+ die "$tool: Input file '$infile' must have '.dbd' extension\n";
3432+my $inbase = basename($infile);
3433+
3434+my $outfile;
3435+if ($opt_o) {
3436+ $outfile = $opt_o;
3437+} elsif (@ARGV) {
3438+ $outfile = shift @ARGV;
3439+} else {
3440+ ($outfile = $infile) =~ s/\.dbd$/.h/;
3441+ $outfile =~ s/^.*\///;
3442+ $outfile =~ s/dbCommonRecord/dbCommon/;
3443+}
3444+my $outbase = basename($outfile);
3445+
3446+# Derive a name for the include guard
3447+my $guard_name = "INC_$outbase";
3448+$guard_name =~ tr/a-zA-Z0-9_/_/cs;
3449+$guard_name =~ s/(_[hH])?$/_H/;
3450+
3451+&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
3452+
3453+my $rtypes = $dbd->recordtypes;
3454+die "$tool: Input file must contain a single recordtype definition.\n"
3455+ unless (1 == keys %{$rtypes});
3456+
3457+if ($opt_D) { # Output dependencies only, to stdout
3458+ my %filecount;
3459+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
3460+ print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
3461+ print map { "$_:\n" } @uniqfiles;
3462+} else {
3463+ open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
3464+ print OUTFILE "/* $outbase generated from $inbase */\n\n",
3465+ "#ifndef $guard_name\n",
3466+ "#define $guard_name\n\n";
3467+
3468+ our ($rn, $rtyp) = each %{$rtypes};
3469+
3470+ print OUTFILE $rtyp->toCdefs;
3471+
3472+ my @menu_fields = grep {
3473+ $_->dbf_type eq 'DBF_MENU'
3474+ } $rtyp->fields;
3475+ my %menu_used;
3476+ grep {
3477+ !$menu_used{$_}++
3478+ } map {
3479+ $_->attribute('menu')
3480+ } @menu_fields;
3481+ our $menus_defined = $dbd->menus;
3482+ while (my ($name, $menu) = each %{$menus_defined}) {
3483+ print OUTFILE $menu->toDeclaration;
3484+ if ($menu_used{$name}) {
3485+ delete $menu_used{$name}
3486+ } else {
3487+ warn "Menu '$name' defined but not used\n";
3488+ }
3489+ }
3490+ our @menus_external = keys %menu_used;
3491+
3492+ print OUTFILE $rtyp->toDeclaration;
3493+
3494+ unless ($rn eq 'dbCommon') {
3495+ my $n = 0;
3496+ print OUTFILE "typedef enum {\n",
3497+ join(",\n",
3498+ map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names),
3499+ "\n} ${rn}FieldIndex;\n\n";
3500+ print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n";
3501+ if ($opt_s) {
3502+ &newtables;
3503+ } else {
3504+ &oldtables;
3505+ }
3506+ print OUTFILE "#endif /* GEN_SIZE_OFFSET */\n";
3507+ }
3508+ print OUTFILE "\n",
3509+ "#endif /* $guard_name */\n";
3510+ close OUTFILE;
3511+}
3512+
3513+sub oldtables {
3514+ # Output compatible with R3.14.x
3515+ print OUTFILE "#ifdef __cplusplus\n" .
3516+ "extern \"C\" {\n" .
3517+ "#endif\n" .
3518+ "#include <epicsExport.h>\n" .
3519+ "static int ${rn}RecordSizeOffset(dbRecordType *prt)\n" .
3520+ "{\n" .
3521+ " ${rn}Record *prec = 0;\n" .
3522+ join("\n", map {
3523+ " prt->papFldDes[${rn}Record" . $_->name . "]->size = " .
3524+ "sizeof(prec->" . $_->C_name . ");"
3525+ } $rtyp->fields) . "\n" .
3526+ join("\n", map {
3527+ " prt->papFldDes[${rn}Record" . $_->name . "]->offset = " .
3528+ "(char *)&prec->" . $_->C_name . " - (char *)prec;"
3529+ } $rtyp->fields) . "\n" .
3530+ " prt->rec_size = sizeof(*prec);\n" .
3531+ " return 0;\n" .
3532+ "}\n" .
3533+ "epicsExportRegistrar(${rn}RecordSizeOffset);\n\n" .
3534+ "#ifdef __cplusplus\n" .
3535+ "}\n" .
3536+ "#endif\n";
3537+}
3538+
3539+sub newtables {
3540+ # Output for an eventual DBD-less IOC
3541+ print OUTFILE (map {
3542+ "extern const dbMenu ${_}MenuMetaData;\n"
3543+ } @menus_external), "\n";
3544+ while (my ($name, $menu) = each %{$menus_defined}) {
3545+ print OUTFILE $menu->toDefinition;
3546+ }
3547+ print OUTFILE (map {
3548+ "static const char ${rn}FieldName$_\[] = \"$_\";\n" }
3549+ $rtyp->field_names), "\n";
3550+ my $n = 0;
3551+ print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n",
3552+ "static dbFldDes ${rn}FieldMetaData[] = {\n",
3553+ join(",\n", map {
3554+ my $fn = $_->name;
3555+ my $cn = $_->C_name;
3556+ " { ${rn}FieldName${fn}," .
3557+ $_->dbf_type . ',"' .
3558+ $_->attribute('initial') . '",' .
3559+ ($_->attribute('special') || '0') . ',' .
3560+ ($_->attribute('pp') || 'FALSE') . ',' .
3561+ ($_->attribute('interest') || '0') . ',' .
3562+ ($_->attribute('asl') || 'ASL0') . ',' .
3563+ $n++ . ",\n\t\&${rn}RecordMetaData," .
3564+ "GEOMETRY_DATA(${rn}Record,$cn) }";
3565+ } $rtyp->fields),
3566+ "\n};\n\n";
3567+ print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFieldIndices[] = {\n",
3568+ join(",\n", map {
3569+ " ${rn}Record" . $_->name;
3570+ } grep {
3571+ $_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/;
3572+ } $rtyp->fields),
3573+ "\n};\n\n";
3574+ my @sorted_names = sort $rtyp->field_names;
3575+ print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n",
3576+ join(",\n", map {
3577+ " ${rn}FieldName$_"
3578+ } @sorted_names),
3579+ "\n};\n\n";
3580+ print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndices[] = {\n",
3581+ join(",\n", map {
3582+ " ${rn}Record$_"
3583+ } @sorted_names),
3584+ "\n};\n\n";
3585+ print OUTFILE "extern rset ${rn}RSET;\n\n",
3586+ "static const dbRecordData ${rn}RecordMetaData = {\n",
3587+ " \"$rn\",\n",
3588+ " sizeof(${rn}Record),\n",
3589+ " NELEMENTS(${rn}FieldMetaData),\n",
3590+ " ${rn}FieldMetaData,\n",
3591+ " ${rn}RecordVAL,\n",
3592+ " \&${rn}FieldMetaData[${rn}RecordVAL],\n",
3593+ " NELEMENTS(${rn}RecordLinkFieldIndices),\n",
3594+ " ${rn}RecordLinkFieldIndices,\n",
3595+ " ${rn}RecordSortedFieldNames,\n",
3596+ " ${rn}RecordSortedFieldIndices,\n",
3597+ " \&${rn}RSET\n",
3598+ "};\n\n",
3599+ "#ifdef __cplusplus\n",
3600+ "extern \"C\" {\n",
3601+ "#endif\n\n";
3602+ print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n",
3603+ "{\n",
3604+ " dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n";
3605+ print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n";
3606+ while (my ($name, $menu) = each %{$menus_defined}) {
3607+ print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n";
3608+ }
3609+ print OUTFILE map {
3610+ " ${rn}FieldMetaData[${rn}Record" .
3611+ $_->name .
3612+ "].typDat.pmenu = \n".
3613+ " \&" .
3614+ $_->attribute('menu') .
3615+ "MenuMetaData;\n";
3616+ } @menu_fields;
3617+ print OUTFILE map {
3618+ " ${rn}FieldMetaData[${rn}Record" .
3619+ $_->name .
3620+ "].typDat.base = CT_HEX;\n";
3621+ } grep {
3622+ $_->attribute('base') eq 'HEX';
3623+ } $rtyp->fields;
3624+ print OUTFILE " dbRegisterRecordtype(pbase, prt);\n";
3625+ print OUTFILE " return prt;\n}\n\n",
3626+ "#ifdef __cplusplus\n",
3627+ "} /* extern \"C\" */\n",
3628+ "#endif\n\n";
3629+}
3630
3631=== added directory 'src/tools/test'
3632=== added file 'src/tools/test/Breaktable.plt'
3633--- src/tools/test/Breaktable.plt 1970-01-01 00:00:00 +0000
3634+++ src/tools/test/Breaktable.plt 2012-04-02 20:38:19 +0000
3635@@ -0,0 +1,22 @@
3636+#!/usr/bin/perl
3637+
3638+use FindBin qw($Bin);
3639+use lib "$Bin/../../../../lib/perl";
3640+
3641+use Test::More tests => 9;
3642+
3643+use DBD::Breaktable;
3644+
3645+my $bpt = DBD::Breaktable->new('test');
3646+isa_ok $bpt, 'DBD::Breaktable';
3647+is $bpt->name, 'test', 'Breakpoint table name';
3648+is $bpt->points, 0, 'Points == zero';
3649+$bpt->add_point(0, 0.5);
3650+is $bpt->points, 1, 'First point added';
3651+is_deeply $bpt->point(0), [0, 0.5], 'First point correct';
3652+$bpt->add_point(1, 1.5);
3653+is $bpt->points, 2, 'Second point added';
3654+is_deeply $bpt->point(0), [0, 0.5], 'First point still correct';
3655+is_deeply $bpt->point(1), [1, 1.5], 'Second point correct';
3656+is_deeply $bpt->point(2), undef, 'Third point undefined';
3657+
3658
3659=== added file 'src/tools/test/DBD.plt'
3660--- src/tools/test/DBD.plt 1970-01-01 00:00:00 +0000
3661+++ src/tools/test/DBD.plt 2012-04-02 20:38:19 +0000
3662@@ -0,0 +1,60 @@
3663+#!/usr/bin/perl
3664+
3665+use FindBin qw($Bin);
3666+use lib "$Bin/../../../../lib/perl";
3667+
3668+use Test::More tests => 18;
3669+
3670+use DBD;
3671+
3672+my $dbd = DBD->new;
3673+isa_ok $dbd, 'DBD';
3674+
3675+is keys %{$dbd->breaktables}, 0, 'No breaktables yet';
3676+my $brk = DBD::Breaktable->new('Brighton');
3677+$dbd->add($brk);
3678+my %brks = %{$dbd->breaktables};
3679+is_deeply \%brks, {Brighton => $brk}, 'Added breaktable';
3680+
3681+is keys %{$dbd->drivers}, 0, 'No drivers yet';
3682+my $drv = DBD::Driver->new('Danforth');
3683+$dbd->add($drv);
3684+my %drvs = %{$dbd->drivers};
3685+is_deeply \%drvs, {Danforth => $drv}, 'Added driver';
3686+
3687+is keys %{$dbd->functions}, 0, 'No functions yet';
3688+my $fnc = DBD::Function->new('Frank');
3689+$dbd->add($fnc);
3690+my %fncs = %{$dbd->functions};
3691+is_deeply \%fncs, {Frank => $fnc}, 'Added function';
3692+
3693+is keys %{$dbd->menus}, 0, 'No menus yet';
3694+my $menu = DBD::Menu->new('Mango');
3695+$dbd->add($menu);
3696+my %menus = %{$dbd->menus};
3697+is_deeply \%menus, {Mango => $menu}, 'Added menu';
3698+is $dbd->menu('Mango'), $menu, 'Named menu';
3699+
3700+is keys %{$dbd->recordtypes}, 0, 'No recordtypes yet';
3701+my $rtyp = DBD::Recordtype->new('Rita');
3702+$dbd->add($rtyp);
3703+my %rtypes = %{$dbd->recordtypes};
3704+is_deeply \%rtypes, {Rita => $rtyp}, 'Added recordtype';
3705+is $dbd->recordtype('Rita'), $rtyp, 'Named recordtype';
3706+
3707+is keys %{$dbd->registrars}, 0, 'No registrars yet';
3708+my $reg = DBD::Registrar->new('Reggie');
3709+$dbd->add($reg);
3710+my %regs = %{$dbd->registrars};
3711+is_deeply \%regs, {Reggie => $reg}, 'Added registrar';
3712+
3713+is keys %{$dbd->variables}, 0, 'No variables yet';
3714+my $ivar = DBD::Variable->new('IntVar');
3715+my $dvar = DBD::Variable->new('DblVar', 'double');
3716+$dbd->add($ivar);
3717+my %vars = %{$dbd->variables};
3718+is_deeply \%vars, {IntVar => $ivar}, 'First variable';
3719+$dbd->add($dvar);
3720+%vars = %{$dbd->variables};
3721+is_deeply \%vars, {IntVar => $ivar, DblVar => $dvar}, 'Second variable';
3722+
3723
3724=== added file 'src/tools/test/Device.plt'
3725--- src/tools/test/Device.plt 1970-01-01 00:00:00 +0000
3726+++ src/tools/test/Device.plt 2012-04-02 20:38:19 +0000
3727@@ -0,0 +1,33 @@
3728+#!/usr/bin/perl
3729+
3730+use FindBin qw($Bin);
3731+use lib "$Bin/../../../../lib/perl";
3732+
3733+use Test::More tests => 16;
3734+
3735+use DBD::Device;
3736+
3737+my $dev = DBD::Device->new('VME_IO', 'test', '"Device"');
3738+isa_ok $dev, 'DBD::Device';
3739+is $dev->name, 'test', 'Device name';
3740+is $dev->link_type, 'VME_IO', 'Link type';
3741+is $dev->choice, 'Device', 'Choice string';
3742+ok $dev->legal_addr('#C0xFEED S123 @xxx'), 'Address legal';
3743+my %dev_addrs = (
3744+ CONSTANT => '12345',
3745+ PV_LINK => 'Any:Record.NAME CPP.MS',
3746+ VME_IO => '# C1 S2 @Anything',
3747+ CAMAC_IO => '# B1 C2 N3 A4 F5 @Anything',
3748+ RF_IO => '# R1 M2 D3 E4',
3749+ AB_IO => '# L1 A2 C3 S4 @Anything',
3750+ GPIB_IO => '# L1 A2 @Anything',
3751+ BITBUS_IO => '# L1 N2 P3 S4 @Anything',
3752+ BBGPIB_IO => '# L1 B2 G3 @Anything',
3753+ VXI_IO => '# V1 C2 S3 @Anything',
3754+ INST_IO => '@Anything'
3755+);
3756+while (my ($link, $addr) = each(%dev_addrs)) {
3757+ $dev->init($link, 'test', '"Device"');
3758+ ok $dev->legal_addr($addr), "$link address";
3759+}
3760+
3761
3762=== added file 'src/tools/test/Driver.plt'
3763--- src/tools/test/Driver.plt 1970-01-01 00:00:00 +0000
3764+++ src/tools/test/Driver.plt 2012-04-02 20:38:19 +0000
3765@@ -0,0 +1,13 @@
3766+#!/usr/bin/perl
3767+
3768+use FindBin qw($Bin);
3769+use lib "$Bin/../../../../lib/perl";
3770+
3771+use Test::More tests => 2;
3772+
3773+use DBD::Driver;
3774+
3775+my $drv = DBD::Driver->new('test');
3776+isa_ok $drv, 'DBD::Driver';
3777+is $drv->name, 'test', 'Driver name';
3778+
3779
3780=== added file 'src/tools/test/Function.plt'
3781--- src/tools/test/Function.plt 1970-01-01 00:00:00 +0000
3782+++ src/tools/test/Function.plt 2012-04-02 20:38:19 +0000
3783@@ -0,0 +1,13 @@
3784+#!/usr/bin/perl
3785+
3786+use FindBin qw($Bin);
3787+use lib "$Bin/../../../../lib/perl";
3788+
3789+use Test::More tests => 2;
3790+
3791+use DBD::Function;
3792+
3793+my $func = DBD::Function->new('test');
3794+isa_ok $func, 'DBD::Function';
3795+is $func->name, 'test', 'Function name';
3796+
3797
3798=== added file 'src/tools/test/Makefile'
3799--- src/tools/test/Makefile 1970-01-01 00:00:00 +0000
3800+++ src/tools/test/Makefile 2012-04-02 20:38:19 +0000
3801@@ -0,0 +1,26 @@
3802+#*************************************************************************
3803+# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
3804+# National Laboratory.
3805+# EPICS BASE is distributed subject to a Software License Agreement found
3806+# in the file LICENSE that is included with this distribution.
3807+#*************************************************************************
3808+TOP=../../..
3809+
3810+include $(TOP)/configure/CONFIG
3811+
3812+TESTS += Breaktable
3813+TESTS += DBD
3814+TESTS += Device
3815+TESTS += Driver
3816+TESTS += Function
3817+TESTS += macLib
3818+TESTS += Menu
3819+TESTS += Recfield
3820+TESTS += Recordtype
3821+TESTS += Registrar
3822+TESTS += Variable
3823+
3824+TESTSCRIPTS_HOST += $(TESTS:%=%.t)
3825+
3826+include $(TOP)/configure/RULES
3827+
3828
3829=== added file 'src/tools/test/Menu.plt'
3830--- src/tools/test/Menu.plt 1970-01-01 00:00:00 +0000
3831+++ src/tools/test/Menu.plt 2012-04-02 20:38:19 +0000
3832@@ -0,0 +1,32 @@
3833+#!/usr/bin/perl
3834+
3835+use FindBin qw($Bin);
3836+use lib "$Bin/../../../../lib/perl";
3837+
3838+use Test::More tests => 14;
3839+
3840+use DBD::Menu;
3841+
3842+my $menu = DBD::Menu->new('test');
3843+isa_ok $menu, 'DBD::Menu';
3844+is $menu->name, 'test', 'Menu name';
3845+is $menu->choices, 0, 'Choices == zero';
3846+$menu->add_choice('ch1', '"Choice 1"');
3847+is $menu->choices, 1, 'First choice added';
3848+ok $menu->legal_choice('Choice 1'), 'First choice legal';
3849+is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice found';
3850+$menu->add_choice('ch2', '"Choice 2"');
3851+is $menu->choices, 2, 'Second choice added';
3852+ok $menu->legal_choice('Choice 1'), 'First choice still legal';
3853+is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice still found';
3854+ok $menu->legal_choice('Choice 2'), 'Second choice legal';
3855+is_deeply $menu->choice(1), ['ch2', 'Choice 2'], 'Second choice found';
3856+ok !$menu->legal_choice('Choice 3'), 'Third choice not legal';
3857+is_deeply $menu->choice(2), undef, 'Third choice undefined';
3858+
3859+like $menu->toDeclaration, qr/ ^
3860+ \s* typedef \s+ enum \s+ {
3861+ \s+ ch1 \s+ \/\* [^*]* \*\/,
3862+ \s+ ch2 \s+ \/\* [^*]* \*\/,
3863+ \s+ test_NUM_CHOICES ,?
3864+ \s+ } \s+ test; \s* $ /x, 'C declaration';
3865
3866=== added file 'src/tools/test/Recfield.plt'
3867--- src/tools/test/Recfield.plt 1970-01-01 00:00:00 +0000
3868+++ src/tools/test/Recfield.plt 2012-04-02 20:38:19 +0000
3869@@ -0,0 +1,114 @@
3870+#!/usr/bin/perl
3871+
3872+use FindBin qw($Bin);
3873+use lib "$Bin/../../../../lib/perl";
3874+
3875+use Test::More tests => 76;
3876+
3877+use DBD::Recfield;
3878+
3879+my $fld_string = DBD::Recfield->new('str', 'DBF_STRING');
3880+isa_ok $fld_string, 'DBD::Recfield';
3881+isa_ok $fld_string, 'DBD::Recfield::DBF_STRING';
3882+$fld_string->set_number(0);
3883+is $fld_string->number, 0, 'Field number';
3884+$fld_string->add_attribute("size", "41");
3885+is keys %{$fld_string->attributes}, 1, "Size set";
3886+ok $fld_string->legal_value("Hello, world!"), 'Legal value';
3887+ok !$fld_string->legal_value("x"x41), 'Illegal string';
3888+$fld_string->check_valid;
3889+like $fld_string->toDeclaration, qr/^\s*char\s+str\[41\];\s*$/, "C declaration";
3890+
3891+my $fld_char = DBD::Recfield->new('chr', 'DBF_CHAR');
3892+isa_ok $fld_char, 'DBD::Recfield';
3893+isa_ok $fld_char, 'DBD::Recfield::DBF_CHAR';
3894+is $fld_char->name, 'chr', 'Field name';
3895+is $fld_char->dbf_type, 'DBF_CHAR', 'Field type';
3896+ok !$fld_char->legal_value("-129"), 'Illegal - value';
3897+ok $fld_char->legal_value("-128"), 'Legal - value';
3898+ok $fld_char->legal_value("127"), 'Legal + value';
3899+ok !$fld_char->legal_value("0x80"), 'Illegal + hex value';
3900+$fld_char->check_valid;
3901+like $fld_char->toDeclaration, qr/^\s*epicsInt8\s+chr;\s*$/, "C declaration";
3902+
3903+my $fld_uchar = DBD::Recfield->new('uchr', 'DBF_UCHAR');
3904+isa_ok $fld_uchar, 'DBD::Recfield';
3905+isa_ok $fld_uchar, 'DBD::Recfield::DBF_UCHAR';
3906+is $fld_uchar->name, 'uchr', 'Field name';
3907+is $fld_uchar->dbf_type, 'DBF_UCHAR', 'Field type';
3908+ok !$fld_uchar->legal_value("-1"), 'Illegal - value';
3909+ok $fld_uchar->legal_value("0"), 'Legal 0 value';
3910+ok $fld_uchar->legal_value("0377"), 'Legal + value';
3911+ok !$fld_uchar->legal_value("0400"), 'Illegal + octal value';
3912+$fld_uchar->check_valid;
3913+like $fld_uchar->toDeclaration, qr/^\s*epicsUInt8\s+uchr;\s*$/, "C declaration";
3914+
3915+my $fld_short = DBD::Recfield->new('shrt', 'DBF_SHORT');
3916+isa_ok $fld_short, 'DBD::Recfield';
3917+isa_ok $fld_short, 'DBD::Recfield::DBF_SHORT';
3918+is $fld_short->name, 'shrt', 'Field name';
3919+is $fld_short->dbf_type, 'DBF_SHORT', 'Field type';
3920+ok !$fld_short->legal_value("-32769"), 'Illegal - value';
3921+ok $fld_short->legal_value("-32768"), 'Legal - value';
3922+ok $fld_short->legal_value("32767"), 'Legal + value';
3923+ok !$fld_short->legal_value("0x8000"), 'Illegal + hex value';
3924+$fld_short->check_valid;
3925+like $fld_short->toDeclaration, qr/^\s*epicsInt16\s+shrt;\s*$/, "C declaration";
3926+
3927+my $fld_ushort = DBD::Recfield->new('ushrt', 'DBF_USHORT');
3928+isa_ok $fld_ushort, 'DBD::Recfield';
3929+isa_ok $fld_ushort, 'DBD::Recfield::DBF_USHORT';
3930+is $fld_ushort->name, 'ushrt', 'Field name';
3931+is $fld_ushort->dbf_type, 'DBF_USHORT', 'Field type';
3932+ok !$fld_ushort->legal_value("-1"), 'Illegal - value';
3933+ok $fld_ushort->legal_value("0"), 'Legal 0 value';
3934+ok $fld_ushort->legal_value("65535"), 'Legal + value';
3935+ok !$fld_ushort->legal_value("0x10000"), 'Illegal + hex value';
3936+$fld_ushort->check_valid;
3937+like $fld_ushort->toDeclaration, qr/^\s*epicsUInt16\s+ushrt;\s*$/, "C declaration";
3938+
3939+my $fld_long = DBD::Recfield->new('lng', 'DBF_LONG');
3940+isa_ok $fld_long, 'DBD::Recfield';
3941+isa_ok $fld_long, 'DBD::Recfield::DBF_LONG';
3942+is $fld_long->name, 'lng', 'Field name';
3943+is $fld_long->dbf_type, 'DBF_LONG', 'Field type';
3944+ok $fld_long->legal_value("-12345678"), 'Legal - value';
3945+ok $fld_long->legal_value("0x12345678"), 'Legal + value';
3946+ok !$fld_long->legal_value("0xfigure"), 'Illegal value';
3947+$fld_long->check_valid;
3948+like $fld_long->toDeclaration, qr/^\s*epicsInt32\s+lng;\s*$/, "C declaration";
3949+
3950+my $fld_ulong = DBD::Recfield->new('ulng', 'DBF_ULONG');
3951+isa_ok $fld_ulong, 'DBD::Recfield';
3952+isa_ok $fld_ulong, 'DBD::Recfield::DBF_ULONG';
3953+is $fld_ulong->name, 'ulng', 'Field name';
3954+is $fld_ulong->dbf_type, 'DBF_ULONG', 'Field type';
3955+ok !$fld_ulong->legal_value("-1"), 'Illegal - value';
3956+ok $fld_ulong->legal_value("00"), 'Legal 0 value';
3957+ok $fld_ulong->legal_value("0xffffffff"), 'Legal + value';
3958+ok !$fld_ulong->legal_value("0xfacepaint"), 'Illegal value';
3959+$fld_ulong->check_valid;
3960+like $fld_ulong->toDeclaration, qr/^\s*epicsUInt32\s+ulng;\s*$/, "C declaration";
3961+
3962+my $fld_float = DBD::Recfield->new('flt', 'DBF_FLOAT');
3963+isa_ok $fld_float, 'DBD::Recfield';
3964+isa_ok $fld_float, 'DBD::Recfield::DBF_FLOAT';
3965+is $fld_float->name, 'flt', 'Field name';
3966+is $fld_float->dbf_type, 'DBF_FLOAT', 'Field type';
3967+ok $fld_float->legal_value("-1.2345678e9"), 'Legal - value';
3968+ok $fld_float->legal_value("0.12345678e9"), 'Legal + value';
3969+ok !$fld_float->legal_value("0x1.5"), 'Illegal value';
3970+$fld_float->check_valid;
3971+like $fld_float->toDeclaration, qr/^\s*epicsFloat32\s+flt;\s*$/, "C declaration";
3972+
3973+my $fld_double = DBD::Recfield->new('dbl', 'DBF_DOUBLE');
3974+isa_ok $fld_double, 'DBD::Recfield';
3975+isa_ok $fld_double, 'DBD::Recfield::DBF_DOUBLE';
3976+is $fld_double->name, 'dbl', 'Field name';
3977+is $fld_double->dbf_type, 'DBF_DOUBLE', 'Field type';
3978+ok $fld_double->legal_value("-12345e-67"), 'Legal - value';
3979+ok $fld_double->legal_value("12345678e+9"), 'Legal + value';
3980+ok !$fld_double->legal_value("e5"), 'Illegal value';
3981+$fld_double->check_valid;
3982+like $fld_double->toDeclaration, qr/^\s*epicsFloat64\s+dbl;\s*$/, "C declaration";
3983+
3984
3985=== added file 'src/tools/test/Recordtype.plt'
3986--- src/tools/test/Recordtype.plt 1970-01-01 00:00:00 +0000
3987+++ src/tools/test/Recordtype.plt 2012-04-02 20:38:19 +0000
3988@@ -0,0 +1,57 @@
3989+#!/usr/bin/perl
3990+
3991+use FindBin qw($Bin);
3992+use lib "$Bin/../../../../lib/perl";
3993+
3994+use Test::More tests => 17;
3995+
3996+use DBD::Recordtype;
3997+use DBD::Recfield;
3998+use DBD::Device;
3999+
4000+my $rtyp = DBD::Recordtype->new('test');
4001+isa_ok $rtyp, 'DBD::Recordtype';
4002+is $rtyp->name, 'test', 'Record name';
4003+is $rtyp->fields, 0, 'No fields yet';
4004+
4005+my $fld1 = DBD::Recfield->new('NAME', 'DBF_STRING');
4006+$fld1->add_attribute("size", "41");
4007+$fld1->check_valid;
4008+
4009+my $fld2 = DBD::Recfield->new('DTYP', 'DBF_DEVICE');
4010+$fld2->check_valid;
4011+
4012+$rtyp->add_field($fld1);
4013+is $rtyp->fields, 1, 'First field added';
4014+
4015+$rtyp->add_field($fld2);
4016+is $rtyp->fields, 2, 'Second field added';
4017+
4018+my @fields = $rtyp->fields;
4019+is_deeply \@fields, [$fld1, $fld2], 'Field list';
4020+
4021+my @names = $rtyp->field_names;
4022+is_deeply \@names, ['NAME', 'DTYP'], 'Field name list';
4023+
4024+is $rtyp->field('NAME'), $fld1, 'Field name lookup';
4025+
4026+is $fld1->number, 0, 'Field number 0';
4027+is $fld2->number, 1, 'Field number 1';
4028+
4029+is $rtyp->devices, 0, 'No devices yet';
4030+
4031+my $dev1 = DBD::Device->new('INST_IO', 'testDset', 'test device');
4032+$rtyp->add_device($dev1);
4033+is $rtyp->devices, 1, 'First device added';
4034+
4035+my @devices = $rtyp->devices;
4036+is_deeply \@devices, [$dev1], 'Device list';
4037+
4038+is $rtyp->device('test device'), $dev1, 'Device name lookup';
4039+
4040+is $rtyp->cdefs, 0, 'No cdefs yet';
4041+$rtyp->add_cdef("cdef");
4042+is $rtyp->cdefs, 1, 'First cdef added';
4043+
4044+my @cdefs = $rtyp->cdefs;
4045+is_deeply \@cdefs, ["cdef"], 'cdef list';
4046
4047=== added file 'src/tools/test/Registrar.plt'
4048--- src/tools/test/Registrar.plt 1970-01-01 00:00:00 +0000
4049+++ src/tools/test/Registrar.plt 2012-04-02 20:38:19 +0000
4050@@ -0,0 +1,13 @@
4051+#!/usr/bin/perl
4052+
4053+use FindBin qw($Bin);
4054+use lib "$Bin/../../../../lib/perl";
4055+
4056+use Test::More tests => 2;
4057+
4058+use DBD::Registrar;
4059+
4060+my $reg = DBD::Registrar->new('test');
4061+isa_ok $reg, 'DBD::Registrar';
4062+is $reg->name, 'test', 'Registrar name';
4063+
4064
4065=== added file 'src/tools/test/Variable.plt'
4066--- src/tools/test/Variable.plt 1970-01-01 00:00:00 +0000
4067+++ src/tools/test/Variable.plt 2012-04-02 20:38:19 +0000
4068@@ -0,0 +1,15 @@
4069+#!/usr/bin/perl
4070+
4071+use FindBin qw($Bin);
4072+use lib "$Bin/../../../../lib/perl";
4073+
4074+use Test::More tests => 4;
4075+
4076+use DBD::Variable;
4077+
4078+my $ivar = DBD::Variable->new('test');
4079+isa_ok $ivar, 'DBD::Variable';
4080+is $ivar->name, 'test', 'Variable name';
4081+is $ivar->var_type, 'int', 'variable defaults to int';
4082+my $dvar = DBD::Variable->new('test', 'double');
4083+is $dvar->var_type, 'double', 'double variable';
4084
4085=== added file 'src/tools/test/macLib.plt'
4086--- src/tools/test/macLib.plt 1970-01-01 00:00:00 +0000
4087+++ src/tools/test/macLib.plt 2012-04-02 20:38:19 +0000
4088@@ -0,0 +1,72 @@
4089+#!/usr/bin/perl
4090+
4091+use FindBin qw($Bin);
4092+use lib "$Bin/../../../../lib/perl";
4093+
4094+use Test::More tests => 34;
4095+
4096+use EPICS::macLib;
4097+
4098+use Data::Dumper;
4099+
4100+my $m = EPICS::macLib->new;
4101+isa_ok $m, 'EPICS::macLib';
4102+is $m->expandString(''), '', 'Empty string';
4103+is $m->expandString('$(undef)'), undef, 'Warning $(undef)';
4104+
4105+$m->suppressWarning(1);
4106+is $m->expandString('$(undef)'), '$(undef)', 'Suppressed $(undef)';
4107+
4108+$m->putValue('a', 'foo');
4109+is $m->expandString('$(a)'), 'foo', '$(a)';
4110+is $m->expandString('${a}'), 'foo', '${a}';
4111+is $m->expandString('$(a=bar)'), 'foo', '$(a=bar)';
4112+is $m->expandString('${a=bar}'), 'foo', '${a=bar}';
4113+is $m->expandString('$(undef)'), '$(undef)', '$(undef) again';
4114+is $m->expandString('${undef}'), '$(undef)', '${undef} again';
4115+
4116+$m->suppressWarning(0);
4117+is $m->expandString('$(undef=$(a))'), 'foo', '$(undef=$(a))';
4118+is $m->expandString('${undef=${a}}'), 'foo', '${undef=${a}}';
4119+is $m->expandString('${undef=$(a)}'), 'foo', '${undef=$(a)}';
4120+is $m->expandString('$(undef=${a})'), 'foo', '$(undef=${a})';
4121+is $m->expandString('$(a=$(undef))'), 'foo', '$(a=$(undef))';
4122+
4123+$m->putValue('b', 'baz');
4124+is $m->expandString('$(b)'), 'baz', '$(b)';
4125+is $m->expandString('$(a)'), 'foo', '$(a)';
4126+is $m->expandString('$(a)$(b)'), 'foobaz', '$(a)$(b)';
4127+is $m->expandString('$(a)/$(b)'), 'foo/baz', '$(a)/$(b)';
4128+is $m->expandString('$(a)\$(b)'), 'foo\$(b)', '$(a)\$(b)';
4129+is $m->expandString('$(a)$$(b)'), 'foo$baz', '$(a)$$(b)';
4130+
4131+$m->putValue('c', '$(a)');
4132+is $m->expandString('$(c)'), 'foo', '$(c)';
4133+is $m->expandString('$(undef=$(c))'), 'foo', '$(undef=$(c))';
4134+
4135+$m->putValue('d', 'c');
4136+is $m->expandString('$(d)'), 'c', '$(d)';
4137+is $m->expandString('$($(d))'), 'foo', '$($(d))';
4138+is $m->expandString('$($(b)=$(a))'), 'foo', '$($(b)=$(a))';
4139+
4140+$m->suppressWarning(1);
4141+$m->putValue('c', undef);
4142+is $m->expandString('$(c)'), '$(c)', '$(c) deleted';
4143+
4144+$m->installMacros('c=fum,d');
4145+is $m->expandString('$(c)'), 'fum', 'installMacros, $(c)';
4146+
4147+is $m->expandString('$(d)'), '$(d)', 'installMacros deletion';
4148+
4149+$m->pushScope;
4150+is $m->expandString('$(a)'), 'foo', 'pushScope, $(a)';
4151+$m->putValue('a', 'grinch');
4152+is $m->expandString('$(a)'), 'grinch', 'new $(a) in child';
4153+
4154+$m->putValue('b', undef);
4155+is $m->expandString('$(b)'), '$(b)', '$(b) deleted in child';
4156+
4157+$m->popScope;
4158+is $m->expandString('$(a)'), 'foo', 'popScope, $(a) restored';
4159+is $m->expandString('$(b)'), 'baz', '$(b) restored';
4160+

Subscribers

People subscribed via source and target branches