Andrew Johnson has proposed merging lp:~anj/epics-base/compiled-dbd into lp:epics-base.
Requested reviews:
EPICS Core Developers (epics-core)
Related bugs:
Bug #541187 in EPICS Base: "Don't allow record field names to be C/C++ keywords"
https://bugs.launchpad.net/epics-base/+bug/541187
For more details, see:
https://code.launchpad.net/~anj/epics-base/compiled-dbd/+merge/97525
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.
--
https://code.launchpad.net/~anj/epics-base/compiled-dbd/+merge/97525
Your team EPICS Core Developers is requested to review the proposed merge of lp:~anj/epics-base/compiled-dbd into lp:epics-base.
=== modified file 'configure/CONFIG_BASE'
--- configure/CONFIG_BASE 2011-02-27 00:24:51 +0000
+++ configure/CONFIG_BASE 2012-03-14 21:45:30 +0000
@@ -57,11 +57,11 @@
# Epics base build tools and tool flags
MAKEBPT = $(call PATH_FILTER, $(TOOLS)/makeBpt$(HOSTEXE))
-DBEXPAND = $(call PATH_FILTER, $(TOOLS)/dbExpand$(HOSTEXE))
-DBTORECORDTYPEH = $(call PATH_FILTER, $(TOOLS)/dbToRecordtypeH$(HOSTEXE))
-DBTOMENUH = $(call PATH_FILTER, $(TOOLS)/dbToMenuH$(HOSTEXE))
+DBEXPAND = $(PERL) $(TOOLS)/dbdExpand.pl
+DBTORECORDTYPEH = $(PERL) $(TOOLS)/dbdToRecordtypeH.pl
+DBTOMENUH = $(PERL) $(TOOLS)/dbdToMenuH.pl
REGISTERRECORDDEVICEDRIVER = $(PERL) $(TOOLS)/registerRecordDeviceDriver.pl
-CONVERTRELEASE=$(PERL) $(TOOLS)/convertRelease.pl
+CONVERTRELEASE = $(PERL) $(TOOLS)/convertRelease.pl
#-------------------------------------------------------
# tools for installing libraries and products
=== modified file 'src/Makefile'
--- src/Makefile 2011-02-27 00:24:51 +0000
+++ src/Makefile 2012-03-14 21:45:30 +0000
@@ -15,6 +15,9 @@
DIRS += tools
+DIRS += tools/test
+tools/test_DEPEND_DIRS = tools
+
DIRS += template/base
template/base_DEPEND_DIRS = tools
=== modified file 'src/ioc/db/RULES'
--- src/ioc/db/RULES 2011-11-15 00:25:13 +0000
+++ src/ioc/db/RULES 2012-03-14 21:45:30 +0000
@@ -20,6 +20,7 @@
@$(MKMF) -m $@ ../db $(COMMON_DIR)/dbCommon.h $<
$(COMMON_DIR)/dbCommon.h: $(IOCDIR)/db/dbCommonRecord.dbd $(IOCDIR)/db/dbCommon.dbd
+<<<<<<< TREE
@$(RM) $(notdir $@)
$(DBTORECORDTYPEH) -I ../db $< $(notdir $@)
@$(MV) $(notdir $@) $@
@@ -29,3 +30,7 @@
$(patsubst %,$(COMMON_DIR)/%.h,$(DBDINC) menuConvert menuGlobal) : \
$(COMMON_DIR)/%.h : $(DBTOMENUH)
+=======
+ $(RM) $@
+ $(DBTORECORDTYPEH) -I ../db $< $@
+>>>>>>> MERGE-SOURCE
=== modified file 'src/ioc/db/dbCommon.dbd'
--- src/ioc/db/dbCommon.dbd 2009-04-23 20:35:02 +0000
+++ src/ioc/db/dbCommon.dbd 2012-03-14 21:45:30 +0000
@@ -82,14 +82,14 @@
prompt("Monitor lock")
special(SPC_NOMOD)
interest(4)
- extra("epicsMutexId mlok")
+ extra("epicsMutexId mlok")
}
%#include "ellLib.h"
field(MLIS,DBF_NOACCESS) {
prompt("Monitor List")
special(SPC_NOMOD)
interest(4)
- extra("ELLLIST mlis")
+ extra("ELLLIST mlis")
}
field(DISP,DBF_UCHAR) {
prompt("Disable putField")
@@ -167,13 +167,13 @@
prompt("Access Security Pvt")
special(SPC_NOMOD)
interest(4)
- extra("struct asgMember *asp")
+ extra("struct asgMember *asp")
}
field(PPN,DBF_NOACCESS) {
prompt("addr of PUTNOTIFY")
special(SPC_NOMOD)
interest(4)
- extra("struct putNotify *ppn")
+ extra("struct putNotify *ppn")
}
field(PPNR,DBF_NOACCESS) {
prompt("pputNotifyRecord")
@@ -191,19 +191,19 @@
prompt("Address of RSET")
special(SPC_NOMOD)
interest(4)
- extra("struct rset *rset")
+ extra("struct rset *rset")
}
field(DSET,DBF_NOACCESS) {
prompt("DSET address")
special(SPC_NOMOD)
interest(4)
- extra("struct dset *dset")
+ extra("struct dset *dset")
}
field(DPVT,DBF_NOACCESS) {
prompt("Device Private")
special(SPC_NOMOD)
interest(4)
- extra("void *dpvt")
+ extra("void *dpvt")
}
field(RDES,DBF_NOACCESS) {
prompt("Address of dbRecordType")
@@ -215,7 +215,7 @@
prompt("Lock Set")
special(SPC_NOMOD)
interest(4)
- extra("struct lockRecord *lset")
+ extra("struct lockRecord *lset")
}
field(PRIO,DBF_MENU) {
prompt("Scheduling Priority")
@@ -231,7 +231,7 @@
prompt("Break Point")
special(SPC_NOMOD)
interest(1)
- extra("char bkpt")
+ extra("char bkpt")
}
field(UDF,DBF_UCHAR) {
prompt("Undefined")
@@ -245,7 +245,7 @@
prompt("Time")
special(SPC_NOMOD)
interest(2)
- extra("epicsTimeStamp time")
+ extra("epicsTimeStamp time")
}
field(FLNK,DBF_FWDLINK) {
prompt("Forward Process Link")
=== modified file 'src/ioc/dbStatic/Makefile'
--- src/ioc/dbStatic/Makefile 2011-09-15 19:05:05 +0000
+++ src/ioc/dbStatic/Makefile 2012-03-14 21:45:30 +0000
@@ -32,26 +32,10 @@
dbCore_SRCS += dbStaticIocRegister.c
dbStaticHost_SRCS += $(STATIC_SRCS)
-dbStaticHost_SRCS += dbStaticNoRun.c
+dbStaticHost_SRCS += dbStaticNoRun.c
LIBRARY_HOST += dbStaticHost
dbStaticHost_LIBS = Com
-PROD_HOST += dbReadTest dbExpand dbToMenuH dbToRecordtypeH
-
-dbReadTest_SRCS = dbReadTest.c
-dbExpand_SRCS = dbExpand.c
-dbToMenuH_SRCS = dbToMenuH.c
-dbToRecordtypeH_SRCS = dbToRecordtypeH.c
-
-# Include dbStaticHost objects directly in executables
-# because of a Circular dependency induced by a rule
-# $(INSTALL_LIBS): $(INSTALL_SHRLIBS)
-# in RULES_BUILD
-dbReadTest_SRCS += $(dbStaticHost_SRCS)
-dbExpand_SRCS += $(dbStaticHost_SRCS)
-dbToMenuH_SRCS += $(dbStaticHost_SRCS)
-dbToRecordtypeH_SRCS += $(dbStaticHost_SRCS)
-
CLEANS += dbLex.c dbYacc.c
=== renamed file 'src/ioc/dbStatic/dbExpand.c' => 'src/ioc/dbStatic/dbExpand.c.THIS'
=== removed file 'src/ioc/dbStatic/dbReadTest.c'
--- src/ioc/dbStatic/dbReadTest.c 2004-07-08 14:43:45 +0000
+++ src/ioc/dbStatic/dbReadTest.c 1970-01-01 00:00:00 +0000
@@ -1,90 +0,0 @@
-/*************************************************************************\
-* Copyright (c) 2002 The University of Chicago, as Operator of Argonne
-* National Laboratory.
-* Copyright (c) 2002 The Regents of the University of California, as
-* Operator of Los Alamos National Laboratory.
-* EPICS BASE Versions 3.13.7
-* and higher are distributed subject to a Software License Agreement found
-* in file LICENSE that is included with this distribution.
-\*************************************************************************/
-/* dbReadTest.c */
-/* Author: Marty Kraimer Date: 13JUL95 */
-
-#include <stdlib.h>
-#include <stddef.h>
-#include <stdio.h>
-#include <string.h>
-
-#include "dbDefs.h"
-#include "epicsPrint.h"
-#include "errMdef.h"
-#include "dbStaticLib.h"
-#include "dbStaticPvt.h"
-#include "dbBase.h"
-#include "gpHash.h"
-#include "osiFileName.h"
-
-DBBASE *pdbbase = NULL;
-
-int main(int argc,char **argv)
-{
- int i;
- int strip;
- char *path = NULL;
- char *sub = NULL;
- int pathLength = 0;
- int subLength = 0;
- char **pstr;
- char *psep;
- int *len;
- long status;
- static char *pathSep = OSI_PATH_LIST_SEPARATOR;
- static char *subSep = ",";
-
- /*Look for options*/
- if(argc<2) {
- printf("usage: dbReadTest -Idir -Smacsub file.dbd file.db \n");
- exit(0);
- }
- while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
- if(strncmp(argv[1],"-I",2)==0) {
- pstr = &path;
- psep = pathSep;
- len = &pathLength;
- } else {
- pstr = ⊂
- psep = subSep;
- len = &subLength;
- }
- if(strlen(argv[1])==2) {
- dbCatString(pstr,len,argv[2],psep);
- strip = 2;
- } else {
- dbCatString(pstr,len,argv[1]+2,psep);
- strip = 1;
- }
- argc -= strip;
- for(i=1; i<argc; i++) argv[i] = argv[i + strip];
- }
- if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
- printf("usage: dbReadTest -Idir -Idir file.dbd file.dbd \n");
- exit(0);
- }
- for(i=1; i<argc; i++) {
- status = dbReadDatabase(&pdbbase,argv[i],path,sub);
- if(!status) continue;
- fprintf(stderr,"For input file %s",argv[i]);
- errMessage(status,"from dbReadDatabase");
- }
-/*
- dbDumpRecordType(pdbbase,"ai");
- dbDumpRecordType(pdbbase,NULL);
- dbPvdDump(pdbbase,1);
- gphDump(pdbbase->pgpHash);
- dbDumpMenu(pdbbase,NULL);
- dbDumpRecord(pdbbase,NULL,0);
- dbReportDeviceConfig(pdbbase,stdout);
-*/
- dbFreeBase(pdbbase);
- return(0);
-}
=== removed file 'src/ioc/dbStatic/dbToMenuH.c'
--- src/ioc/dbStatic/dbToMenuH.c 2008-08-05 22:48:45 +0000
+++ src/ioc/dbStatic/dbToMenuH.c 1970-01-01 00:00:00 +0000
@@ -1,124 +0,0 @@
-/*************************************************************************\
-* Copyright (c) 2002 The University of Chicago, as Operator of Argonne
-* National Laboratory.
-* Copyright (c) 2002 The Regents of the University of California, as
-* Operator of Los Alamos National Laboratory.
-* EPICS BASE Versions 3.13.7
-* and higher are distributed subject to a Software License Agreement found
-* in file LICENSE that is included with this distribution.
-\*************************************************************************/
-/* dbToMenu.c */
-/* Author: Marty Kraimer Date: 11Sep95 */
-#include <stdlib.h>
-#include <stddef.h>
-#include <stdio.h>
-#include <string.h>
-
-#include "dbDefs.h"
-#include "epicsPrint.h"
-#include "errMdef.h"
-#include "dbStaticLib.h"
-#include "dbStaticPvt.h"
-#include "dbBase.h"
-#include "gpHash.h"
-#include "osiFileName.h"
-
-DBBASE *pdbbase = NULL;
-
-int main(int argc,char **argv)
-{
- dbMenu *pdbMenu;
- char *outFilename;
- char *pext;
- FILE *outFile;
- char *plastSlash;
- int i;
- int strip;
- char *path = NULL;
- char *sub = NULL;
- int pathLength = 0;
- int subLength = 0;
- char **pstr;
- char *psep;
- int *len;
- long status;
- static char *pathSep = OSI_PATH_LIST_SEPARATOR;
- static char *subSep = ",";
-
- /*Look for options*/
- if(argc<2) {
- fprintf(stderr,"usage: dbToMenu -Idir -Idir file.dbd [outfile]\n");
- exit(0);
- }
- while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
- if(strncmp(argv[1],"-I",2)==0) {
- pstr = &path;
- psep = pathSep;
- len = &pathLength;
- } else {
- pstr = ⊂
- psep = subSep;
- len = &subLength;
- }
- if(strlen(argv[1])==2) {
- dbCatString(pstr,len,argv[2],psep);
- strip = 2;
- } else {
- dbCatString(pstr,len,argv[1]+2,psep);
- strip = 1;
- }
- argc -= strip;
- for(i=1; i<argc; i++) argv[i] = argv[i + strip];
- }
- if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
- fprintf(stderr,"usage: dbToMenu -Idir -Idir file.dbd [outfile]\n");
- exit(0);
- }
- if (argc==2) {
- /*remove path so that outFile is created where program is executed*/
- plastSlash = strrchr(argv[1],'/');
- if(!plastSlash) plastSlash = strrchr(argv[1],'\\');
- plastSlash = (plastSlash ? plastSlash+1 : argv[1]);
- outFilename = dbCalloc(1,strlen(plastSlash)+1);
- strcpy(outFilename,plastSlash);
- pext = strstr(outFilename,".dbd");
- if (!pext) {
- fprintf(stderr,"Input file MUST have .dbd extension\n");
- exit(-1);
- }
- strcpy(pext,".h");
- } else {
- outFilename = dbCalloc(1,strlen(argv[2])+1);
- strcpy(outFilename,argv[2]);
- }
- pdbbase = dbAllocBase();
- pdbbase->ignoreMissingMenus = TRUE;
- status = dbReadDatabase(&pdbbase,argv[1],path,sub);
- if (status) {
- errlogFlush();
- fprintf(stderr, "dbToMenuH: Input errors, no output generated\n");
- exit(1);
- }
- outFile = fopen(outFilename, "w");
- if (!outFile) {
- epicsPrintf("Error creating output file \"%s\"\n", outFilename);
- exit(1);
- }
- pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList);
- while(pdbMenu) {
- fprintf(outFile,"#ifndef INC%sH\n",pdbMenu->name);
- fprintf(outFile,"#define INC%sH\n",pdbMenu->name);
- fprintf(outFile,"typedef enum {\n");
- for(i=0; i<pdbMenu->nChoice; i++) {
- fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]);
- if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,",");
- fprintf(outFile,"\n");
- }
- fprintf(outFile,"}%s;\n",pdbMenu->name);
- fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name);
- pdbMenu = (dbMenu *)ellNext(&pdbMenu->node);
- }
- fclose(outFile);
- free((void *)outFilename);
- return(0);
-}
=== removed file 'src/ioc/dbStatic/dbToRecordtypeH.c'
--- src/ioc/dbStatic/dbToRecordtypeH.c 2008-08-05 22:48:45 +0000
+++ src/ioc/dbStatic/dbToRecordtypeH.c 1970-01-01 00:00:00 +0000
@@ -1,267 +0,0 @@
-/*************************************************************************\
-* Copyright (c) 2007 UChicago Argonne LLC, as Operator of Argonne
-* National Laboratory.
-* Copyright (c) 2002 The Regents of the University of California, as
-* Operator of Los Alamos National Laboratory.
-* EPICS BASE is distributed subject to a Software License Agreement found
-* in file LICENSE that is included with this distribution.
-\*************************************************************************/
-/* dbToRecordtypeH.c */
-/* Author: Marty Kraimer Date: 11Sep95 */
-
-#include <stdlib.h>
-#include <stddef.h>
-#include <stdio.h>
-#include <string.h>
-#include <ctype.h>
-
-#include "dbDefs.h"
-#include "epicsPrint.h"
-#include "errMdef.h"
-#include "dbStaticLib.h"
-#include "dbStaticPvt.h"
-#include "dbBase.h"
-#include "gpHash.h"
-#include "osiFileName.h"
-
-DBBASE *pdbbase = NULL;
-
-int main(int argc,char **argv)
-{
- int i;
- char *outFilename;
- char *pext;
- FILE *outFile;
- dbMenu *pdbMenu;
- dbRecordType *pdbRecordType;
- dbFldDes *pdbFldDes;
- dbText *pdbCdef;
- int isdbCommonRecord = FALSE;
- char *plastSlash;
- int strip;
- char *path = NULL;
- char *sub = NULL;
- int pathLength = 0;
- int subLength = 0;
- char **pstr;
- char *psep;
- int *len;
- long status;
- static char *pathSep = OSI_PATH_LIST_SEPARATOR;
- static char *subSep = ",";
-
- /*Look for options*/
- if(argc<2) {
- fprintf(stderr,"usage: dbToRecordtypeH -Idir -Idir file.dbd [outfile]\n");
- exit(0);
- }
- while((strncmp(argv[1],"-I",2)==0)||(strncmp(argv[1],"-S",2)==0)) {
- if(strncmp(argv[1],"-I",2)==0) {
- pstr = &path;
- psep = pathSep;
- len = &pathLength;
- } else {
- pstr = ⊂
- psep = subSep;
- len = &subLength;
- }
- if(strlen(argv[1])==2) {
- dbCatString(pstr,len,argv[2],psep);
- strip = 2;
- } else {
- dbCatString(pstr,len,argv[1]+2,psep);
- strip = 1;
- }
- argc -= strip;
- for(i=1; i<argc; i++) argv[i] = argv[i + strip];
- }
- if(argc<2 || (strncmp(argv[1],"-",1)==0)) {
- fprintf(stderr,"usage: dbToRecordtypeH -Idir -Idir file.dbd [outfile]\n");
- exit(0);
- }
- if(argc==2){
- /*remove path so that outFile is created where program is executed*/
- plastSlash = strrchr(argv[1],'/');
- if(!plastSlash) plastSlash = strrchr(argv[1],'\\');
- plastSlash = (plastSlash ? plastSlash+1 : argv[1]);
- outFilename = dbCalloc(1,strlen(plastSlash)+1);
- strcpy(outFilename,plastSlash);
- pext = strstr(outFilename,".dbd");
- if(!pext) {
- fprintf(stderr,"Input file MUST have .dbd extension\n");
- exit(-1);
- }
- strcpy(pext,".h");
- if(strcmp(outFilename,"dbCommonRecord.h")==0) {
- strcpy(outFilename,"dbCommon.h");
- isdbCommonRecord = TRUE;
- }
- }else {
- outFilename = dbCalloc(1,strlen(argv[2])+1);
- strcpy(outFilename,argv[2]);
- if(strstr(outFilename,"dbCommon.h")!=0) {
- isdbCommonRecord = TRUE;
- }
- }
- pdbbase = dbAllocBase();
- pdbbase->ignoreMissingMenus = TRUE;
- pdbbase->loadCdefs = TRUE;
- status = dbReadDatabase(&pdbbase,argv[1],path,sub);
- if(status) {
- errlogFlush();
- fprintf(stderr, "dbToMenuH: Input errors, no output generated\n");
- exit(1);
- }
- outFile = fopen(outFilename,"w");
- if(!outFile) {
- epicsPrintf("Error creating output file \"%s\"\n", outFilename);
- exit(1);
- }
-
- pdbMenu = (dbMenu *)ellFirst(&pdbbase->menuList);
- while(pdbMenu) {
- fprintf(outFile,"\n#ifndef INC%sH\n",pdbMenu->name);
- fprintf(outFile,"#define INC%sH\n",pdbMenu->name);
- fprintf(outFile,"typedef enum {\n");
- for(i=0; i<pdbMenu->nChoice; i++) {
- fprintf(outFile,"\t%s",pdbMenu->papChoiceName[i]);
- if(i < (pdbMenu->nChoice - 1)) fprintf(outFile,",");
- fprintf(outFile,"\n");
- }
- fprintf(outFile,"}%s;\n",pdbMenu->name);
- fprintf(outFile,"#endif /*INC%sH*/\n",pdbMenu->name);
- pdbMenu = (dbMenu *)ellNext(&pdbMenu->node);
- }
- pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList);
- while(pdbRecordType) {
- fprintf(outFile,"#ifndef INC%sH\n",pdbRecordType->name);
- fprintf(outFile,"#define INC%sH\n",pdbRecordType->name);
- pdbCdef = (dbText *)ellFirst(&pdbRecordType->cdefList);
- while (pdbCdef) {
- fprintf(outFile,"%s\n",pdbCdef->text);
- pdbCdef = (dbText *)ellNext(&pdbCdef->node);
- }
- fprintf(outFile,"typedef struct %s",pdbRecordType->name);
- if(!isdbCommonRecord) fprintf(outFile,"Record");
- fprintf(outFile," {\n");
- for(i=0; i<pdbRecordType->no_fields; i++) {
- char name[256];
- int j;
-
- pdbFldDes = pdbRecordType->papFldDes[i];
- for(j=0; j< (int)strlen(pdbFldDes->name); j++)
- name[j] = tolower(pdbFldDes->name[j]);
- name[strlen(pdbFldDes->name)] = 0;
- switch(pdbFldDes->field_type) {
- case DBF_STRING :
- fprintf(outFile, "\tchar\t\t%s[%d];\t/* %s */\n",
- name, pdbFldDes->size, pdbFldDes->prompt);
- break;
- case DBF_CHAR :
- fprintf(outFile, "\tepicsInt8\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_UCHAR :
- fprintf(outFile, "\tepicsUInt8\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_SHORT :
- fprintf(outFile, "\tepicsInt16\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_USHORT :
- fprintf(outFile, "\tepicsUInt16\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_LONG :
- fprintf(outFile, "\tepicsInt32\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_ULONG :
- fprintf(outFile, "\tepicsUInt32\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_FLOAT :
- fprintf(outFile, "\tepicsFloat32\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_DOUBLE :
- fprintf(outFile, "\tepicsFloat64\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_ENUM :
- case DBF_MENU :
- case DBF_DEVICE :
- fprintf(outFile, "\tepicsEnum16\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_INLINK :
- case DBF_OUTLINK :
- case DBF_FWDLINK :
- fprintf(outFile, "\tDBLINK\t\t%s;\t/* %s */\n",
- name, pdbFldDes->prompt);
- break;
- case DBF_NOACCESS:
- fprintf(outFile, "\t%s;\t/* %s */\n",
- pdbFldDes->extra, pdbFldDes->prompt);
- break;
- default:
- fprintf(outFile,"ILLEGAL FIELD TYPE\n");
- }
- }
- fprintf(outFile,"} %s",pdbRecordType->name);
- if(!isdbCommonRecord) fprintf(outFile,"Record");
- fprintf(outFile,";\n");
- if(!isdbCommonRecord) {
- for(i=0; i<pdbRecordType->no_fields; i++) {
- pdbFldDes = pdbRecordType->papFldDes[i];
- fprintf(outFile,"#define %sRecord%s\t%d\n",
- pdbRecordType->name,pdbFldDes->name,pdbFldDes->indRecordType);
- }
- }
- fprintf(outFile,"#endif /*INC%sH*/\n",pdbRecordType->name);
- pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node);
- if(pdbRecordType) fprintf(outFile,"\n");
- }
- if(!isdbCommonRecord) {
- fprintf(outFile,"#ifdef GEN_SIZE_OFFSET\n");
- fprintf(outFile,"#ifdef __cplusplus\n");
- fprintf(outFile,"extern \"C\" {\n");
- fprintf(outFile,"#endif\n");
- fprintf(outFile,"#include <epicsExport.h>\n");
- pdbRecordType = (dbRecordType *)ellFirst(&pdbbase->recordTypeList);
- while(pdbRecordType) {
- fprintf(outFile,"static int %sRecordSizeOffset(dbRecordType *pdbRecordType)\n{\n",
- pdbRecordType->name);
- fprintf(outFile," %sRecord *prec = 0;\n",pdbRecordType->name);
- for(i=0; i<pdbRecordType->no_fields; i++) {
- char name[256];
- int j;
-
- pdbFldDes = pdbRecordType->papFldDes[i];
- for(j=0; j< (int)strlen(pdbFldDes->name); j++)
- name[j] = tolower(pdbFldDes->name[j]);
- name[strlen(pdbFldDes->name)] = 0;
- fprintf(outFile,
- " pdbRecordType->papFldDes[%d]->size=sizeof(prec->%s);\n",
- i,name);
- fprintf(outFile," pdbRecordType->papFldDes[%d]->offset=",i);
- fprintf(outFile,
- "(short)((char *)&prec->%s - (char *)prec);\n",name);
- }
- fprintf(outFile," pdbRecordType->rec_size = sizeof(*prec);\n");
- fprintf(outFile," return(0);\n");
- fprintf(outFile,"}\n");
- fprintf(outFile,"epicsExportRegistrar(%sRecordSizeOffset);\n",
- pdbRecordType->name);
- pdbRecordType = (dbRecordType *)ellNext(&pdbRecordType->node);
- }
- fprintf(outFile,"#ifdef __cplusplus\n");
- fprintf(outFile,"}\n");
- fprintf(outFile,"#endif\n");
- fprintf(outFile,"#endif /*GEN_SIZE_OFFSET*/\n");
- }
- fclose(outFile);
- free((void *)outFilename);
- return(0);
-}
=== added directory 'src/tools/DBD'
=== added file 'src/tools/DBD.pm'
--- src/tools/DBD.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,81 @@
+package DBD;
+
+use DBD::Base;
+use DBD::Breaktable;
+use DBD::Driver;
+use DBD::Menu;
+use DBD::Recordtype;
+use DBD::Recfield;
+use DBD::Registrar;
+use DBD::Function;
+use DBD::Variable;
+
+use Carp;
+
+sub new {
+ my ($class) = @_;
+ my $this = {
+ 'DBD::Breaktable' => {},
+ 'DBD::Driver' => {},
+ 'DBD::Function' => {},
+ 'DBD::Menu' => {},
+ 'DBD::Recordtype' => {},
+ 'DBD::Registrar' => {},
+ 'DBD::Variable' => {}
+ };
+ bless $this, $class;
+ return $this;
+}
+
+sub add {
+ my ($this, $obj) = @_;
+ my $obj_class;
+ foreach (keys %{$this}) {
+ next unless m/^DBD::/;
+ $obj_class = $_ and last if $obj->isa($_);
+ }
+ confess "Unknown object type"
+ unless defined $obj_class;
+ my $obj_name = $obj->name;
+ dieContext("Duplicate name '$obj_name'")
+ if exists $this->{$obj_class}->{$obj_name};
+ $this->{$obj_class}->{$obj_name} = $obj;
+}
+
+sub breaktables {
+ return shift->{'DBD::Breaktable'};
+}
+
+sub drivers {
+ return shift->{'DBD::Driver'};
+}
+
+sub functions {
+ return shift->{'DBD::Function'};
+}
+
+sub menus {
+ return shift->{'DBD::Menu'};
+}
+sub menu {
+ my ($this, $menu_name) = @_;
+ return $this->{'DBD::Menu'}->{$menu_name};
+}
+
+sub recordtypes {
+ return shift->{'DBD::Recordtype'};
+}
+sub recordtype {
+ my ($this, $rtyp_name) = @_;
+ return $this->{'DBD::Recordtype'}->{$rtyp_name};
+}
+
+sub registrars {
+ return shift->{'DBD::Registrar'};
+}
+
+sub variables {
+ return shift->{'DBD::Variable'};
+}
+
+1;
=== added file 'src/tools/DBD/Base.pm'
--- src/tools/DBD/Base.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Base.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,127 @@
+# Common utility functions used by the DBD components
+
+package DBD::Base;
+
+use Carp;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&pushContext &popContext &dieContext &warnContext &is_reserved
+ &identifier &unquote &escapeCcomment &escapeCstring $RXident $RXname
+ $RXuint $RXint $RXhex $RXoct $RXuintx $RXintx $RXnum $RXdqs $RXsqs $RXstr);
+
+
+our $RXident = qr/ [a-zA-Z] [a-zA-Z0-9_]* /x;
+our $RXname = qr/ [a-zA-Z0-9_\-:.<>;]+ /x;
+our $RXhex = qr/ (?: 0 [xX] [0-9A-Fa-f]+ ) /x;
+our $RXoct = qr/ 0 [0-7]* /x;
+our $RXuint = qr/ \d+ /x;
+our $RXint = qr/ -? $RXuint /ox;
+our $RXuintx = qr/ ( $RXhex | $RXoct | $RXuint ) /ox;
+our $RXintx = qr/ ( $RXhex | $RXoct | $RXint ) /ox;
+our $RXnum = qr/ -? (?: \d+ | \d* \. \d+ ) (?: [eE] [-+]? \d+ )? /x;
+our $RXdqs = qr/" (?: [^"] | \\" )* " /x;
+our $RXsqs = qr/' (?: [^'] | \\' )* ' /x;
+our $RXstr = qr/ ( $RXname | $RXnum | $RXdqs | $RXsqs ) /ox;
+
+our @context;
+
+
+sub pushContext {
+ my ($ctxt) = @_;
+ unshift @context, $ctxt;
+}
+
+sub popContext {
+ my ($ctxt) = @_;
+ my ($pop) = shift @context;
+ ($ctxt ne $pop) and
+ dieContext("Exiting context \"$ctxt\", found \"$pop\" instead.",
+ "\tBraces must close in the same file they were opened.");
+}
+
+sub dieContext {
+ my ($msg) = join "\n\t", @_;
+ print "$msg\n" if $msg;
+ die "Context: ", join(' in ', @context), "\n";
+}
+
+sub warnContext {
+ my ($msg) = join "\n\t", @_;
+ print "$msg\n" if $msg;
+ print "Context: ", join(' in ', @context), "\n";
+}
+
+
+# Input checking
+
+sub unquote (\$) {
+ my ($s) = @_;
+ $$s =~ s/^"(.*)"$/$1/o;
+ return $$s;
+}
+
+# Reserved words from C++ and the DB/DBD file parser
+my %reserved = map { $_ => undef } qw(and and_eq asm auto bitand bitor bool
+ break case catch char class compl const const_cast continue default delete
+ do double dynamic_cast else enum explicit export extern false float for
+ friend goto if inline int long mutable namespace new not not_eq operator or
+ or_eq private protected public register reinterpret_cast return short signed
+ sizeof static static_cast struct switch template this throw true try typedef
+ typeid typename union unsigned using virtual void volatile wchar_t while xor
+ xor_eq addpath alias breaktable choice device driver field function grecord
+ include info menu path record recordtype registrar variable);
+sub is_reserved {
+ my $id = shift;
+ return exists $reserved{$id};
+}
+
+sub identifier {
+ my ($id, $what) = @_;
+ unquote $id;
+ confess "$what undefined!" unless defined $id;
+ $id =~ m/^$RXident$/o or dieContext("Illegal $what '$id'",
+ "Identifiers are used in C code so must start with a letter, followed",
+ "by letters, digits and/or underscore characters only.");
+ dieContext("Illegal $what '$id'",
+ "Identifier is a C++ reserved word.")
+ if is_reserved($id);
+ return $id;
+}
+
+
+# Output filtering
+
+sub escapeCcomment {
+ ($_) = @_;
+ s/\*\//**/g;
+ return $_;
+}
+
+sub escapeCstring {
+ ($_) = @_;
+ # How to do this?
+ return $_;
+}
+
+
+# Base class routines for the DBD component objects
+
+sub new {
+ my $class = shift;
+ my $this = {};
+ bless $this, $class;
+ return $this->init(@_);
+}
+
+sub init {
+ my ($this, $name, $what) = @_;
+ $this->{NAME} = identifier($name, $what);
+ return $this;
+}
+
+sub name {
+ return shift->{NAME};
+}
+
+1;
=== added file 'src/tools/DBD/Breaktable.pm'
--- src/tools/DBD/Breaktable.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Breaktable.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,32 @@
+package DBD::Breaktable;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+use Carp;
+
+sub init {
+ my ($this, $name) = @_;
+ $this->SUPER::init($name, "breakpoint table name");
+ $this->{POINT_LIST} = [];
+ return $this;
+}
+
+sub add_point {
+ my ($this, $raw, $eng) = @_;
+ confess "Raw value undefined!" unless defined $raw;
+ confess "Engineering value undefined!" unless defined $eng;
+ unquote $raw;
+ unquote $eng;
+ push @{$this->{POINT_LIST}}, [$raw, $eng];
+}
+
+sub points {
+ return @{shift->{POINT_LIST}};
+}
+
+sub point {
+ my ($this, $idx) = @_;
+ return $this->{POINT_LIST}[$idx];
+}
+
+1;
=== added file 'src/tools/DBD/Device.pm'
--- src/tools/DBD/Device.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Device.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,45 @@
+package DBD::Device;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+my %link_types = (
+ CONSTANT => qr/$RXnum/o,
+ PV_LINK => qr/$RXname \s+ [.NPCAMS ]*/ox,
+ VME_IO => qr/\# (?: \s* [CS] \s* $RXintx)* \s* (?: @ .*)?/ox,
+ CAMAC_IO => qr/\# (?: \s* [BCNAF] \s* $RXintx)* \s* (?: @ .*)?/ox,
+ RF_IO => qr/\# (?: \s* [RMDE] \s* $RXintx)*/ox,
+ AB_IO => qr/\# (?: \s* [LACS] \s* $RXintx)* \s* (?: @ .*)?/ox,
+ GPIB_IO => qr/\# (?: \s* [LA] \s* $RXintx)* \s* (?: @ .*)?/ox,
+ BITBUS_IO => qr/\# (?: \s* [LNPS] \s* $RXuintx)* \s* (?: @ .*)?/ox,
+ BBGPIB_IO => qr/\# (?: \s* [LBG] \s* $RXuintx)* \s* (?: @ .*)?/ox,
+ VXI_IO => qr/\# (?: \s* [VCS] \s* $RXintx)* \s* (?: @ .*)?/ox,
+ INST_IO => qr/@.*/
+);
+
+sub init {
+ my ($this, $link_type, $dset, $choice) = @_;
+ unquote $choice;
+ dieContext("Unknown link type '$link_type', valid types are:",
+ sort keys %link_types) unless exists $link_types{$link_type};
+ $this->SUPER::init($dset, "DSET name");
+ $this->{LINK_TYPE} = $link_type;
+ $this->{CHOICE} = $choice;
+ return $this;
+}
+
+sub link_type {
+ return shift->{LINK_TYPE};
+}
+
+sub choice {
+ return shift->{CHOICE};
+}
+
+sub legal_addr {
+ my ($this, $addr) = @_;
+ my $rx = $link_types{$this->{LINK_TYPE}};
+ unquote $addr;
+ return $addr =~ m/^ $rx $/x;
+}
+
+1;
=== added file 'src/tools/DBD/Driver.pm'
--- src/tools/DBD/Driver.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Driver.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,9 @@
+package DBD::Driver;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+sub init {
+ return shift->SUPER::init(shift, "driver entry table name");
+}
+
+1;
=== added file 'src/tools/DBD/Function.pm'
--- src/tools/DBD/Function.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Function.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,10 @@
+package DBD::Function;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+sub init {
+ return shift->SUPER::init(shift, "function name");
+}
+
+1;
+
=== added file 'src/tools/DBD/Menu.pm'
--- src/tools/DBD/Menu.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Menu.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,66 @@
+package DBD::Menu;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+sub init {
+ my ($this, $name) = @_;
+ $this->SUPER::init($name, "menu name");
+ $this->{CHOICE_LIST} = [];
+ $this->{CHOICE_INDEX} = {};
+ return $this;
+}
+
+sub add_choice {
+ my ($this, $name, $value) = @_;
+ $name = identifier($name, "Choice name");
+ unquote $value;
+ foreach $pair ($this->choices) {
+ dieContext("Duplicate choice name") if ($pair->[0] eq $name);
+ dieContext("Duplicate choice string") if ($pair->[1] eq $value);
+ }
+ push @{$this->{CHOICE_LIST}}, [$name, $value];
+ $this->{CHOICE_INDEX}->{$value} = $name;
+}
+
+sub choices {
+ return @{shift->{CHOICE_LIST}};
+}
+
+sub choice {
+ my ($this, $idx) = @_;
+ return $this->{CHOICE_LIST}[$idx];
+}
+
+sub legal_choice {
+ my ($this, $value) = @_;
+ unquote $value;
+ return exists $this->{CHOICE_INDEX}->{$value};
+}
+
+sub toDeclaration {
+ my $this = shift;
+ my $name = $this->name;
+ my @choices = map {
+ sprintf " %-31s /* %s */", @{$_}[0], escapeCcomment(@{$_}[1]);
+ } $this->choices;
+ return "typedef enum {\n" .
+ join(",\n", @choices) .
+ ",\n ${name}_NUM_CHOICES\n" .
+ "} $name;\n\n";
+}
+
+sub toDefinition {
+ my $this = shift;
+ my $name = $this->name;
+ my @strings = map {
+ "\t\"" . escapeCstring(@{$_}[1]) . "\""
+ } $this->choices;
+ return "static const char * const ${name}ChoiceStrings[] = {\n" .
+ join(",\n", @strings) . "\n};\n" .
+ "const dbMenu ${name}MenuMetaData = {\n" .
+ "\t\"" . escapeCstring($name) . "\",\n" .
+ "\t${name}_NUM_CHOICES,\n" .
+ "\t${name}ChoiceStrings\n};\n\n";
+}
+
+1;
=== added file 'src/tools/DBD/Output.pm'
--- src/tools/DBD/Output.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Output.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,98 @@
+package DBD::Output;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&OutputDBD);
+
+use DBD;
+use DBD::Base;
+use DBD::Breaktable;
+use DBD::Device;
+use DBD::Driver;
+use DBD::Menu;
+use DBD::Recordtype;
+use DBD::Recfield;
+use DBD::Registrar;
+use DBD::Function;
+use DBD::Variable;
+
+sub OutputDBD {
+ my ($out, $dbd) = @_;
+ &OutputMenus($out, $dbd->menus);
+ &OutputRecordtypes($out, $dbd->recordtypes);
+ &OutputDrivers($out, $dbd->drivers);
+ &OutputRegistrars($out, $dbd->registrars);
+ &OutputFunctions($out, $dbd->functions);
+ &OutputVariables($out, $dbd->variables);
+ &OutputBreaktables($out, $dbd->breaktables);
+}
+
+sub OutputMenus {
+ my ($out, $menus) = @_;
+ while (my ($name, $menu) = each %{$menus}) {
+ printf $out "menu(%s) {\n", $name;
+ printf $out " choice(%s, \"%s\")\n", @{$_}
+ foreach $menu->choices;
+ print $out "}\n";
+ }
+}
+
+sub OutputRecordtypes {
+ my ($out, $recordtypes) = @_;
+ while (my ($name, $recordtype) = each %{$recordtypes}) {
+ printf $out "recordtype(%s) {\n", $name;
+ print $out " %$_\n"
+ foreach $recordtype->cdefs;
+ foreach $field ($recordtype->fields) {
+ printf $out " field(%s, %s) {\n",
+ $field->name, $field->dbf_type;
+ while (my ($attr, $val) = each %{$field->attributes}) {
+ $val = "\"$val\"" if $val !~ m/^[a-zA-Z0-9_\-+:.\[\]<>;]*$/;
+ printf $out " %s(%s)\n", $attr, $val;
+ }
+ print $out " }\n";
+ }
+ printf $out "}\n";
+ printf $out "device(%s, %s, %s, \"%s\")\n",
+ $name, $_->link_type, $_->name, $_->choice
+ foreach $recordtype->devices;
+ }
+}
+
+sub OutputDrivers {
+ my ($out, $drivers) = @_;
+ printf $out "driver(%s)\n", $_
+ foreach keys %{$drivers};
+}
+
+sub OutputRegistrars {
+ my ($out, $registrars) = @_;
+ printf $out "registrar(%s)\n", $_
+ foreach keys %{$registrars};
+}
+
+sub OutputFunctions {
+ my ($out, $functions) = @_;
+ printf $out "function(%s)\n", $_
+ foreach keys %{$functions};
+}
+
+sub OutputVariables {
+ my ($out, $variables) = @_;
+ while (my ($name, $variable) = each %{$variables}) {
+ printf $out "variable(%s, %s)\n", $name, $variable->var_type;
+ }
+}
+
+sub OutputBreaktables {
+ my ($out, $breaktables) = @_;
+ while (my ($name, $breaktable) = each %{$breaktables}) {
+ printf $out "breaktable(\"%s\") {\n", $name;
+ printf $out " point(%s, %s)\n", @{$_}
+ foreach $breaktable->points;
+ print $out "}\n";
+ }
+}
+
+1;
=== added file 'src/tools/DBD/Parser.pm'
--- src/tools/DBD/Parser.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Parser.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,197 @@
+package DBD::Parser;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(&ParseDBD);
+
+use DBD;
+use DBD::Base;
+use DBD::Breaktable;
+use DBD::Device;
+use DBD::Driver;
+use DBD::Menu;
+use DBD::Recordtype;
+use DBD::Recfield;
+use DBD::Registrar;
+use DBD::Function;
+use DBD::Variable;
+
+my $RXnam = qr/[a-zA-Z0-9_\-:.<>;]+/o;
+my $RXnum = qr/-? (?: \d+ ) | (?: \d* \. \d+ ) (?: [eE] [-+]? \d+ )?/ox;
+my $RXdqs = qr/" (?: [^"] | \\" )* "/ox;
+my $RXsqs = qr/' (?: [^'] | \\' )* '/ox;
+my $string = qr/ ( $RXnam | $RXnum | $RXdqs | $RXsqs ) /ox;
+
+our $debug=0;
+
+sub ParseDBD {
+ my $dbd = shift;
+ $_ = shift;
+ while (1) {
+ parseCommon();
+ if (m/\G menu \s* \( \s* $string \s* \) \s* \{/oxgc) {
+ print "Menu: $1\n" if $debug;
+ parse_menu($dbd, $1);
+ }
+ elsif (m/\G driver \s* \( \s* $string \s* \)/oxgc) {
+ print "Driver: $1\n" if $debug;
+ $dbd->add(DBD::Driver->new($1));
+ }
+ elsif (m/\G registrar \s* \( \s* $string \s* \)/oxgc) {
+ print "Registrar: $1\n" if $debug;
+ $dbd->add(DBD::Registrar->new($1));
+ }
+ elsif (m/\G function \s* \( \s* $string \s* \)/oxgc) {
+ print "Function: $1\n" if $debug;
+ $dbd->add(DBD::Function->new($1));
+ }
+ elsif (m/\G breaktable \s* \( \s* $string \s* \) \s* \{/oxgc) {
+ print "Breaktable: $1\n" if $debug;
+ parse_breaktable($dbd, $1);
+ }
+ elsif (m/\G recordtype \s* \( \s* $string \s* \) \s* \{/oxgc) {
+ print "Recordtype: $1\n" if $debug;
+ parse_recordtype($dbd, $1);
+ }
+ elsif (m/\G variable \s* \( \s* $string \s* \)/oxgc) {
+ print "Variable: $1\n" if $debug;
+ $dbd->add(DBD::Variable->new($1, 'int'));
+ }
+ elsif (m/\G variable \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
+ print "Variable: $1, $2\n" if $debug;
+ $dbd->add(DBD::Variable->new($1, $2));
+ }
+ elsif (m/\G device \s* \( \s* $string \s* , \s* $string \s* ,
+ \s* $string \s* , \s*$string \s* \)/oxgc) {
+ print "Device: $1, $2, $3, $4\n" if $debug;
+ my $rtyp = $dbd->recordtype($1);
+ dieContext("Unknown record type '$1'") unless defined $rtyp;
+ $rtyp->add_device(DBD::Device->new($2, $3, $4));
+ } else {
+ last unless m/\G (.*) $/moxgc;
+ dieContext("Syntax error in '$1'");
+ }
+ }
+}
+
+sub parseCommon {
+ while (1) {
+ # Skip leading whitespace
+ m/\G \s* /oxgc;
+
+ if (m/\G \# /oxgc) {
+ if (m/\G \#!BEGIN\{ ( [^}]* ) \}!\#\# \n/oxgc) {
+ print "File-Begin: $1\n" if $debug;
+ pushContext("file '$1'");
+ }
+ elsif (m/\G \#!END\{ ( [^}]* ) \}!\#\# \n?/oxgc) {
+ print "File-End: $1\n" if $debug;
+ popContext("file '$1'");
+ }
+ else {
+ m/\G (.*) \n/oxgc;
+ print "Comment: $1\n" if $debug;
+ }
+ } else {
+ return;
+ }
+ }
+}
+
+sub parse_menu {
+ my ($dbd, $name) = @_;
+ pushContext("menu($name)");
+ my $menu = DBD::Menu->new($name);
+ while(1) {
+ parseCommon();
+ if (m/\G choice \s* \( \s* $string \s* , \s* $string \s* \)/oxgc) {
+ print " Menu-Choice: $1, $2\n" if $debug;
+ $menu->add_choice($1, $2);
+ }
+ elsif (m/\G \}/oxgc) {
+ print " Menu-End:\n" if $debug;
+ $dbd->add($menu);
+ popContext("menu($name)");
+ return;
+ } else {
+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
+ dieContext("Syntax error in '$1'");
+ }
+ }
+}
+
+sub parse_breaktable {
+ my ($dbd, $name) = @_;
+ pushContext("breaktable($name)");
+ my $bt = DBD::Breaktable->new($name);
+ while(1) {
+ parseCommon();
+ if (m/\G point\s* \(\s* $string \s* , \s* $string \s* \)/oxgc) {
+ print " Breaktable-Point: $1, $2\n" if $debug;
+ $bt->add_point($1, $2);
+ }
+ elsif (m/\G $string \s* (?: , \s*)? $string (?: \s* ,)?/oxgc) {
+ print " Breaktable-Data: $1, $2\n" if $debug;
+ $bt->add_point($1, $2);
+ }
+ elsif (m/\G \}/oxgc) {
+ print " Breaktable-End:\n" if $debug;
+ $dbd->add($bt);
+ popContext("breaktable($name)");
+ return;
+ } else {
+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
+ dieContext("Syntax error in '$1'");
+ }
+ }
+}
+
+sub parse_recordtype {
+ my ($dbd, $name) = @_;
+ pushContext("recordtype($name)");
+ my $rtyp = DBD::Recordtype->new($name);
+ while(1) {
+ parseCommon();
+ if (m/\G field \s* \( \s* $string \s* , \s* $string \s* \) \s* \{/oxgc) {
+ print " Recordtype-Field: $1, $2\n" if $debug;
+ parse_field($rtyp, $1, $2);
+ }
+ elsif (m/\G \}/oxgc) {
+ print " Recordtype-End:\n" if $debug;
+ $dbd->add($rtyp);
+ popContext("recordtype($name)");
+ return;
+ }
+ elsif (m/\G % (.*) \n/oxgc) {
+ print " Recordtype-Cdef: $1\n" if $debug;
+ $rtyp->add_cdef($1);
+ } else {
+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
+ dieContext("Syntax error in '$1'");
+ }
+ }
+}
+
+sub parse_field {
+ my ($rtyp, $name, $field_type) = @_;
+ my $fld = DBD::Recfield->new($name, $field_type);
+ pushContext("field($name, $field_type)");
+ while(1) {
+ parseCommon();
+ if (m/\G (\w+) \s* \( \s* $string \s* \)/oxgc) {
+ print " Field-Attribute: $1, $2\n" if $debug;
+ $fld->add_attribute($1, $2);
+ }
+ elsif (m/\G \}/oxgc) {
+ print " Field-End:\n" if $debug;
+ $rtyp->add_field($fld);
+ popContext("field($name, $field_type)");
+ return;
+ } else {
+ m/\G (.*) $/moxgc or dieContext("Unexpected end of input");
+ dieContext("Syntax error in '$1'");
+ }
+ }
+}
+
+1;
=== added file 'src/tools/DBD/Recfield.pm'
--- src/tools/DBD/Recfield.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Recfield.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,436 @@
+package DBD::Recfield;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+# The hash value is a regexp that matches all legal values of this field
+our %field_types = (
+ DBF_STRING => qr/.{0,40}/,
+ DBF_CHAR => $RXintx,
+ DBF_UCHAR => $RXuintx,
+ DBF_SHORT => $RXintx,
+ DBF_USHORT => $RXuintx,
+ DBF_LONG => $RXintx,
+ DBF_ULONG => $RXuintx,
+ DBF_FLOAT => $RXnum,
+ DBF_DOUBLE => $RXnum,
+ DBF_ENUM => qr/.*/,
+ DBF_MENU => qr/.*/,
+ DBF_DEVICE => qr/.*/,
+ DBF_INLINK => qr/.*/,
+ DBF_OUTLINK => qr/.*/,
+ DBF_FWDLINK => qr/.*/,
+ DBF_NOACCESS => qr//
+);
+
+# The hash value is a regexp that matches all legal values of this attribute
+our %field_attrs = (
+ asl => qr/^ASL[01]$/,
+ initial => qr/^.*$/,
+ promptgroup => qr/^GUI_\w+$/,
+ prompt => qr/^.*$/,
+ special => qr/^(?:SPC_\w+|\d{3,})$/,
+ pp => qr/^(?:TRUE|FALSE)$/,
+ interest => qr/^\d+$/,
+ base => qr/^(?:DECIMAL|HEX)$/,
+ size => qr/^\d+$/,
+ extra => qr/^.*$/,
+ menu => qr/^$RXident$/o
+);
+
+sub new {
+ my ($class, $name, $type) = @_;
+ dieContext("Illegal field type '$type', valid field types are:",
+ sort keys %field_types) unless exists $field_types{$type};
+ my $this = {};
+ bless $this, "${class}::${type}";
+ return $this->init($name, $type);
+}
+
+sub init {
+ my ($this, $name, $type) = @_;
+ unquote $type;
+ $this->SUPER::init($name, "record field name");
+ dieContext("Illegal field type '$type', valid field types are:",
+ sort keys %field_types) unless exists $field_types{$type};
+ $this->{DBF_TYPE} = $type;
+ $this->{ATTR_INDEX} = {};
+ return $this;
+}
+
+sub dbf_type {
+ return shift->{DBF_TYPE};
+}
+
+sub set_number {
+ my ($this, $number) = @_;
+ $this->{NUMBER} = $number;
+}
+
+sub number {
+ return shift->{NUMBER};
+}
+
+sub add_attribute {
+ my ($this, $attr, $value) = @_;
+ unquote $value;
+ my $match = $field_attrs{$attr};
+ dieContext("Unknown field attribute '$1', valid attributes are:",
+ sort keys %field_attrs)
+ unless defined $match;
+ dieContext("Bad value '$value' for field '$attr' attribute")
+ unless $value =~ m/$match/;
+ $this->{ATTR_INDEX}->{$attr} = $value;
+}
+
+sub attributes {
+ return shift->{ATTR_INDEX};
+}
+
+sub attribute {
+ my ($this, $attr) = @_;
+ return $this->attributes->{$attr};
+}
+
+sub check_valid {
+ my ($this) = @_;
+ my $name = $this->name;
+ my $default = $this->attribute("initial");
+ dieContext("Default value '$default' is invalid for field '$name'")
+ if (defined($default) and !$this->legal_value($default));
+}
+
+# The C structure member name is usually the field name converted to
+# lower-case. However if that is a reserved word, use the original.
+sub C_name {
+ my ($this) = @_;
+ my $name = lc $this->name;
+ $name = $this->name
+ if is_reserved($name);
+ return $name;
+}
+
+sub toDeclaration {
+ my ($this, $ctype) = @_;
+ my $name = $this->C_name;
+ my $result = sprintf " %-19s %-12s", $ctype, "$name;";
+ my $prompt = $this->attribute('prompt');
+ $result .= "/* $prompt */" if defined $prompt;
+ return $result;
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_STRING;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ return (length $value < $this->attribute('size'));
+ # NB - we use '<' to allow space for the terminating nil byte
+}
+
+sub check_valid {
+ my ($this) = @_;
+ dieContext("Size missing for DBF_STRING field '$name'")
+ unless exists $this->attributes->{'size'};
+ $this->SUPER::check_valid;
+}
+
+sub toDeclaration {
+ my ($this) = @_;
+ my $name = lc $this->name;
+ my $size = $this->attribute('size');
+ my $result = sprintf " %-19s %-12s", 'char', "${name}[${size}];";
+ my $prompt = $this->attribute('prompt');
+ $result .= "/* $prompt */" if defined $prompt;
+ return $result;
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_CHAR;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
+ return ($value =~ m/^ $RXint $/x and
+ $value >= -128 and
+ $value <= 127);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsInt8");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_UCHAR;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
+ return ($value =~ m/^ $RXuint $/x and
+ $value >= 0 and
+ $value <= 255);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsUInt8");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_SHORT;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
+ return ($value =~ m/^ $RXint $/x and
+ $value >= -32768 and
+ $value <= 32767);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsInt16");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_USHORT;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
+ return ($value =~ m/^ $RXuint $/x and
+ $value >= 0 and
+ $value <= 65535);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsUInt16");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_LONG;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
+ return ($value =~ m/^ $RXint $/x);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsInt32");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_ULONG;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ $value =~ s/^ ( $RXhex | $RXoct ) $/ oct($1) /xe;
+ return ($value =~ m/^ $RXuint $/x and
+ $value >= 0);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsUInt32");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_FLOAT;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ return ($value =~ m/^ $RXnum $/x);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsFloat32");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_DOUBLE;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ return ($value =~ m/^ $RXnum $/x);
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsFloat64");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_ENUM;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ return 1;
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsEnum16");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_MENU;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ # FIXME: If we know the menu name and the menu exists, check further
+ return 1;
+}
+
+sub check_valid {
+ my ($this) = @_;
+ dieContext("Menu name missing for DBF_MENU field '$name'")
+ unless defined($this->attribute("menu"));
+ $this->SUPER::check_valid;
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsEnum16");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_DEVICE;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ return 1;
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("epicsEnum16");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_INLINK;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ return 1;
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("DBLINK");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_OUTLINK;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ return 1;
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("DBLINK");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_FWDLINK;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ return 1;
+}
+
+sub toDeclaration {
+ return shift->SUPER::toDeclaration("DBLINK");
+}
+
+
+################################################################################
+
+package DBD::Recfield::DBF_NOACCESS;
+
+use DBD::Base;
+@ISA = qw(DBD::Recfield);
+
+sub legal_value {
+ my ($this, $value) = @_;
+ return ($value eq '');
+}
+
+sub check_valid {
+ my ($this) = @_;
+ dieContext("Type information missing for DBF_NOACCESS field '$name'")
+ unless defined($this->attribute("extra"));
+ $this->SUPER::check_valid;
+}
+
+sub toDeclaration {
+ my ($this) = @_;
+ my $extra = $this->attribute('extra');
+ my $result = sprintf " %-31s ", "$extra;";
+ my $prompt = $this->attribute('prompt');
+ $result .= "/* $prompt */" if defined $prompt;
+ return $result;
+}
+
+1;
=== added file 'src/tools/DBD/Recordtype.pm'
--- src/tools/DBD/Recordtype.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Recordtype.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,100 @@
+package DBD::Recordtype;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+use Carp;
+
+sub init {
+ my $this = shift;
+ $this->SUPER::init(@_);
+ $this->{FIELD_LIST} = [];
+ $this->{FIELD_INDEX} = {};
+ $this->{DEVICE_LIST} = [];
+ $this->{DEVICE_INDEX} = {};
+ $this->{CDEFS} = [];
+ return $this;
+}
+
+sub add_field {
+ my ($this, $field) = @_;
+ confess "Not a DBD::Recfield" unless $field->isa('DBD::Recfield');
+ my $field_name = $field->name;
+ dieContext("Duplicate field name '$field_name'")
+ if exists $this->{FIELD_INDEX}->{$field_name};
+ $field->check_valid;
+ $field->set_number(scalar @{$this->{FIELD_LIST}});
+ push @{$this->{FIELD_LIST}}, $field;
+ $this->{FIELD_INDEX}->{$field_name} = $field;
+}
+
+sub fields {
+ return @{shift->{FIELD_LIST}};
+}
+
+sub field_names { # In their original order...
+ my $this = shift;
+ my @names = ();
+ foreach ($this->fields) {
+ push @names, $_->name
+ }
+ return @names;
+}
+
+sub field {
+ my ($this, $field_name) = @_;
+ return $this->{FIELD_INDEX}->{$field_name};
+}
+
+sub add_device {
+ my ($this, $device) = @_;
+ confess "Not a DBD::Device" unless $device->isa('DBD::Device');
+ my $choice = $device->choice;
+ if (exists $this->{DEVICE_INDEX}->{$choice}) {
+ my @warning = ("Duplicate device type '$choice'");
+ my $old = $this->{DEVICE_INDEX}->{$choice};
+ push @warning, "Link types differ"
+ if ($old->link_type ne $device->link_type);
+ push @warning, "DSETs differ"
+ if ($old->name ne $device->name);
+ warnContext(@warning);
+ return;
+ }
+ push @{$this->{DEVICE_LIST}}, $device;
+ $this->{DEVICE_INDEX}->{$choice} = $device;
+}
+
+sub devices {
+ return @{shift->{DEVICE_LIST}};
+}
+
+sub device {
+ my ($this, $choice) = @_;
+ return $this->{DEVICE_INDEX}->{$choice};
+}
+
+sub add_cdef {
+ my ($this, $cdef) = @_;
+ push @{$this->{CDEFS}}, $cdef;
+}
+
+sub cdefs {
+ return @{shift->{CDEFS}};
+}
+
+sub toCdefs {
+ return join("\n", shift->cdefs) . "\n\n";
+}
+
+sub toDeclaration {
+ my $this = shift;
+ my @fields = map {
+ $_->toDeclaration
+ } $this->fields;
+ my $name = $this->name;
+ $name .= "Record" unless $name eq "dbCommon";
+ return "typedef struct $name {\n" .
+ join("\n", @fields) .
+ "\n} $name;\n\n";
+}
+
+1;
=== added file 'src/tools/DBD/Registrar.pm'
--- src/tools/DBD/Registrar.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Registrar.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,11 @@
+package DBD::Registrar;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+sub init {
+ return shift->SUPER::init(shift, "registrar function name");
+}
+
+
+1;
+
=== added file 'src/tools/DBD/Variable.pm'
--- src/tools/DBD/Variable.pm 1970-01-01 00:00:00 +0000
+++ src/tools/DBD/Variable.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,27 @@
+package DBD::Variable;
+use DBD::Base;
+@ISA = qw(DBD::Base);
+
+my %var_types = ("int" => 1, "double" => 1);
+
+sub init {
+ my ($this, $name, $type) = @_;
+ if (defined $type) {
+ unquote $type;
+ } else {
+ $type = "int";
+ }
+ exists $var_types{$type} or
+ dieContext("Unknown variable type '$type', valid types are:",
+ sort keys %var_types);
+ $this->SUPER::init($name, "variable name");
+ $this->{VAR_TYPE} = $type;
+ return $this;
+}
+
+sub var_type {
+ my $this = shift;
+ return $this->{VAR_TYPE};
+}
+
+1;
=== added file 'src/tools/EPICS/Readfile.pm'
--- src/tools/EPICS/Readfile.pm 1970-01-01 00:00:00 +0000
+++ src/tools/EPICS/Readfile.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,101 @@
+#*************************************************************************
+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in file LICENSE that is included with this distribution.
+#*************************************************************************
+
+# $Id$
+
+package EPICS::Readfile;
+require 5.000;
+require Exporter;
+
+use EPICS::macLib;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(@inputfiles &Readfile);
+
+our $debug=0;
+our @inputfiles;
+
+sub slurp {
+ my ($FILE, $Rpath) = @_;
+ my @path = @{$Rpath};
+ print "slurp($FILE):\n" if $debug;
+ if ($FILE !~ m[/]) {
+ foreach $dir (@path) {
+ print " trying $dir/$FILE\n" if $debug;
+ if (-r "$dir/$FILE") {
+ $FILE = "$dir/$FILE";
+ last;
+ }
+ }
+ die "Can't find file '$FILE'\n" unless -r $FILE;
+ }
+ print " opening $FILE\n" if $debug;
+ open FILE, "<$FILE" or die "Can't open $FILE: $!\n";
+ push @inputfiles, $FILE;
+ my @lines = ("##!BEGIN{$FILE}!##\n");
+ # Consider replacing these markers with C pre-processor linemarkers.
+ # See 'info cpp' * Preprocessor Output:: for details.
+ push @lines, <FILE>;
+ push @lines, "##!END{$FILE}!##\n";
+ close FILE or die "Error closing $FILE: $!\n";
+ print " read ", scalar @lines, " lines\n" if $debug;
+ return join '', @lines;
+}
+
+sub expandMacros {
+ my ($macros, $input) = @_;
+ return $input unless $macros;
+ return $macros->expandString($input);
+}
+
+sub splitPath {
+ my ($path) = @_;
+ my (@path) = split /[:;]/, $path;
+ grep s/^$/./, @path;
+ return @path;
+}
+
+my $RXstr = qr/ " (?: [^"] | \\" )* "/ox;
+my $RXnam = qr/[a-zA-Z0-9_\-:.[\]<>;]+/o;
+my $string = qr/ ( $RXnam | $RXstr ) /ox;
+
+sub unquote {
+ my ($s) = @_;
+ $s =~ s/^"(.*)"$/$1/o;
+ return $s;
+}
+
+sub Readfile {
+ my ($file, $macros, $Rpath) = @_;
+ print "Readfile($file)\n" if $debug;
+ my $input = &expandMacros($macros, &slurp($file, $Rpath));
+ my @input = split /\n/, $input;
+ my @output;
+ foreach (@input) {
+ if (m/^ \s* include \s+ $string /ox) {
+ $arg = &unquote($1);
+ print " include $arg\n" if $debug;
+ push @output, "##! include \"$arg\"";
+ push @output, &Readfile($arg, $macros, $Rpath);
+ } elsif (m/^ \s* addpath \s+ $string /ox) {
+ $arg = &unquote($1);
+ print " addpath $arg\n" if $debug;
+ push @output, "##! addpath \"$arg\"";
+ push @{$Rpath}, &splitPath($arg);
+ } elsif (m/^ \s* path \s+ $string /ox) {
+ $arg = &unquote($1);
+ print " path $arg\n" if $debug;
+ push @output, "##! path \"$arg\"";
+ @{$Rpath} = &splitPath($arg);
+ } else {
+ push @output, $_;
+ }
+ }
+ return join "\n", @output;
+}
+
+1;
=== added file 'src/tools/EPICS/macLib.pm'
--- src/tools/EPICS/macLib.pm 1970-01-01 00:00:00 +0000
+++ src/tools/EPICS/macLib.pm 2012-03-14 21:45:30 +0000
@@ -0,0 +1,251 @@
+#*************************************************************************
+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in file LICENSE that is included with this distribution.
+#*************************************************************************
+
+# $Id$
+
+package EPICS::macLib::entry;
+
+sub new ($$) {
+ my $class = shift;
+ my $this = {
+ name => shift,
+ type => shift,
+ raw => '',
+ val => '',
+ visited => 0,
+ error => 0,
+ };
+ bless $this, $class;
+ return $this;
+}
+
+sub report ($) {
+ my ($this) = @_;
+ return unless defined $this->{raw};
+ printf "%1s %-16s %-16s %s\n",
+ ($this->{error} ? '*' : ' '), $this->{name}, $this->{raw}, $this->{val};
+}
+
+
+package EPICS::macLib;
+
+use Carp;
+
+sub new ($@) {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = {
+ dirty => 0,
+ noWarn => 0,
+ macros => [{}], # [0] is current scope, [1] is parent etc.
+ };
+ bless $this, $class;
+ $this->installList(@_);
+ return $this;
+}
+
+sub installList ($@) {
+ # Argument is a list of strings which are arguments to installMacros
+ my $this = shift;
+ while (@_) {
+ $this->installMacros(shift);
+ }
+}
+
+sub installMacros ($$) {
+ # Argument is a string: a=1,b="2",c,d='hello'
+ my $this = shift;
+ $_ = shift;
+ until (defined pos($_) and pos($_) == length($_)) {
+ m/\G \s* /xgc; # Skip whitespace
+ if (m/\G ( [A-Za-z0-9_-]+ ) \s* /xgc) {
+ my ($name, $val) = ($1);
+ if (m/\G = \s* /xgc) {
+ # The value follows, handle quotes and escapes
+ until (pos($_) == length($_)) {
+ if (m/\G , /xgc) { last; }
+ elsif (m/\G ' ( ( [^'] | \\ ' )* ) ' /xgc) { $val .= $1; }
+ elsif (m/\G " ( ( [^"] | \\ " )* ) " /xgc) { $val .= $1; }
+ elsif (m/\G \\ ( . ) /xgc) { $val .= $1; }
+ elsif (m/\G ( . ) /xgc) { $val .= $1; }
+ else { die "How did I get here?"; }
+ }
+ $this->putValue($name, $val);
+ } elsif (m/\G , /xgc or (pos($_) == length($_))) {
+ $this->putValue($name, undef);
+ } else {
+ warn "How did I get here?";
+ }
+ } elsif (m/\G ( .* )/xgc) {
+ croak "Can't find a macro definition in '$1'";
+ } else {
+ last;
+ }
+ }
+}
+
+sub putValue ($$$) {
+ my ($this, $name, $raw) = @_;
+ if (exists $this->{macros}[0]{$name}) {
+ if (!defined $raw) {
+ delete $this->{macros}[0]{$name};
+ } else {
+ $this->{macros}[0]{$name}{raw} = $raw;
+ }
+ } else {
+ my $entry = EPICS::macLib::entry->new($name, 'macro');
+ $entry->{raw} = $raw;
+ $this->{macros}[0]{$name} = $entry;
+ }
+ $this->{dirty} = 1;
+}
+
+sub pushScope ($) {
+ my ($this) = @_;
+ unshift @{$this->{macros}}, {};
+}
+
+sub popScope ($) {
+ my ($this) = @_;
+ shift @{$this->{macros}};
+}
+
+sub suppressWarning($$) {
+ my ($this, $suppress) = @_;
+ $this->{noWarn} = $suppress;
+}
+
+sub expandString($$) {
+ my ($this, $src) = @_;
+ $this->_expand;
+ my $entry = EPICS::macLib::entry->new($src, 'string');
+ my $result = $this->_translate($entry, 0, $src);
+ return $result unless $entry->{error};
+ return $this->{noWarn} ? $result : undef;
+}
+
+sub reportMacros ($) {
+ my ($this) = @_;
+ $this->_expand;
+ print "Macro report\n============\n";
+ foreach my $scope (@{$this->{macros}}) {
+ foreach my $name (keys %{$scope}) {
+ my $entry = $scope->{$name};
+ $entry->report;
+ }
+ } continue {
+ print " -- scope ends --\n";
+ }
+}
+
+
+# Private routines, not intended for public use
+
+sub _expand ($) {
+ my ($this) = @_;
+ return unless $this->{dirty};
+ foreach my $scope (@{$this->{macros}}) {
+ foreach my $name (keys %{$scope}) {
+ my $entry = $scope->{$name};
+ $entry->{val} = $this->_translate($entry, 1, $entry->{raw});
+ }
+ }
+ $this->{dirty} = 0;
+}
+
+sub _lookup ($$$$$) {
+ my ($this, $name) = @_;
+ foreach my $scope (@{$this->{macros}}) {
+ if (exists $scope->{$name}) {
+ return undef # Macro marked as deleted
+ unless defined $scope->{$name}{raw};
+ return $scope->{$name};
+ }
+ }
+ return undef;
+}
+
+sub _translate ($$$$) {
+ my ($this, $entry, $level, $str) = @_;
+ return $this->_trans($entry, $level, '', \$str);
+}
+
+sub _trans ($$$$$) {
+ my ($this, $entry, $level, $term, $R) = @_;
+ return $$R
+ if (!defined $$R or
+ $$R =~ m/\A [^\$]* \Z/x); # Short-circuit if no macros
+ my $quote = 0;
+ my $val;
+ until (defined pos($$R) and pos($$R) == length($$R)) {
+ if ($term and ($$R =~ m/\G (?= [$term] ) /xgc)) {
+ last;
+ }
+ if ($$R =~ m/\G \$ ( [({] ) /xgc) {
+ my $macEnd = $1;
+ $macEnd =~ tr/({/)}/;
+ my $name2 = $this->_trans($entry, $level+1, "=$macEnd", $R);
+ my $entry2 = $this->_lookup($name2);
+ if (!defined $entry2) { # Macro not found
+ if ($$R =~ m/\G = /xgc) { # Use default value given
+ $val .= $this->_trans($entry, $level+1, $macEnd, $R);
+ } else {
+ unless ($this->{noWarn}) {
+ $entry->{error} = 1;
+ printf STDERR "macLib: macro '%s' is undefined (expanding %s '%s')\n",
+ $name2, $entry->{type}, $entry->{name};
+ }
+ $val .= "\$($name2)";
+ }
+ $$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
+ } else { # Macro found
+ if ($entry2->{visited}) {
+ $entry->{error} = 1;
+ printf STDERR "macLib: %s '%s' is recursive (expanding %s '%s')\n",
+ $entry->{type}, $entry->{name}, $entry2->{type}, $entry2->{name};
+ $val .= "\$($name)";
+ } else {
+ if ($$R =~ m/\G = /xgc) { # Discard default value
+ local $this->{noWarn} = 1; # Temporarily kill warnings
+ $this->_trans($entry, $level+1, $macEnd, $R);
+ }
+ $$R =~ m/\G [$macEnd] /xgc; # Discard close bracket
+ if ($this->{dirty}) { # Translate raw value
+ $entry2->{visited} = 1;
+ $val .= $this->_trans($entry, $level+1, '', \$entry2->{raw});
+ $entry2->{visited} = 0;
+ } else {
+ $val .= $entry2->{val}; # Here's one I made earlier...
+ }
+ }
+ }
+ } elsif ($level > 0) { # Discard quotes and escapes
+ if ($quote and $$R =~ m/\G $quote /xgc) {
+ $quote = 0;
+ } elsif ($$R =~ m/\G ( ['"] ) /xgc) {
+ $quote = $1;
+ } elsif ($$R =~ m/\G \\? ( . ) /xgc) {
+ $val .= $1;
+ } else {
+ warn "How did I get here? level=$level";
+ }
+ } else { # Level 0
+ if ($$R =~ m/\G \\ ( . ) /xgc) {
+ $val .= "\\$1";
+ } elsif ($$R =~ m/\G ( [^\\\$'")}]* ) /xgc) {
+ $val .= $1;
+ } elsif ($$R =~ m/\G ( . ) /xgc) {
+ $val .= $1;
+ } else {
+ warn "How did I get here? level=$level";
+ }
+ }
+ }
+ return $val;
+}
+
+1;
=== modified file 'src/tools/Makefile'
--- src/tools/Makefile 2008-09-23 22:13:52 +0000
+++ src/tools/Makefile 2012-03-14 21:45:30 +0000
@@ -1,5 +1,5 @@
#*************************************************************************
-# Copyright (c) 2008 UChicago Argonne LLC, as Operator of Argonne
+# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
# National Laboratory.
# EPICS BASE is distributed subject to a Software License Agreement found
# in file LICENSE that is included with this distribution.
@@ -14,7 +14,23 @@
PERL_MODULES += EPICS/Copy.pm
PERL_MODULES += EPICS/Path.pm
PERL_MODULES += EPICS/Release.pm
+PERL_MODULES += EPICS/Readfile.pm
PERL_MODULES += EPICS/Getopts.pm
+PERL_MODULES += EPICS/macLib.pm
+
+PERL_MODULES += DBD.pm
+PERL_MODULES += DBD/Base.pm
+PERL_MODULES += DBD/Breaktable.pm
+PERL_MODULES += DBD/Device.pm
+PERL_MODULES += DBD/Driver.pm
+PERL_MODULES += DBD/Function.pm
+PERL_MODULES += DBD/Menu.pm
+PERL_MODULES += DBD/Output.pm
+PERL_MODULES += DBD/Parser.pm
+PERL_MODULES += DBD/Recfield.pm
+PERL_MODULES += DBD/Recordtype.pm
+PERL_MODULES += DBD/Registrar.pm
+PERL_MODULES += DBD/Variable.pm
PERL_SCRIPTS += convertRelease.pl
PERL_SCRIPTS += cvsclean.pl
@@ -32,5 +48,10 @@
PERL_SCRIPTS += replaceVAR.pl
PERL_SCRIPTS += useManifestTool.pl
+PERL_SCRIPTS += dbdToMenuH.pl
+PERL_SCRIPTS += dbdToRecordtypeH.pl
+PERL_SCRIPTS += dbdExpand.pl
+PERL_SCRIPTS += dbdToHtml.pl
+
include $(TOP)/configure/RULES
=== added file 'src/tools/dbdExpand.pl'
--- src/tools/dbdExpand.pl 1970-01-01 00:00:00 +0000
+++ src/tools/dbdExpand.pl 2012-03-14 21:45:30 +0000
@@ -0,0 +1,53 @@
+#!/usr/bin/perl
+
+#*************************************************************************
+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in file LICENSE that is included with this distribution.
+#*************************************************************************
+
+# $Id$
+
+use FindBin qw($Bin);
+use lib "$Bin/../../lib/perl";
+
+use DBD;
+use DBD::Parser;
+use DBD::Output;
+use EPICS::Getopts;
+use EPICS::Readfile;
+use EPICS::macLib;
+
+getopts('DI@S@o:') or
+ die "Usage: dbdExpand [-D] [-I dir] [-S macro=val] [-o out.dbd] in.dbd ...";
+
+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
+my $macros = EPICS::macLib->new(@opt_S);
+my $dbd = DBD->new();
+
+while (@ARGV) {
+ &ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
+}
+
+if ($opt_D) { # Output dependencies only
+ my %filecount;
+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
+ print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
+ print map { "$_:\n" } @uniqfiles;
+ exit 0;
+}
+
+my $out;
+if ($opt_o) {
+ open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
+} else {
+ $out = STDOUT;
+}
+
+&OutputDBD($out, $dbd);
+
+if ($opt_o) {
+ close $out or die "Closing $opt_o failed: $!\n";
+}
+exit 0;
=== added file 'src/tools/dbdReport.pl'
--- src/tools/dbdReport.pl 1970-01-01 00:00:00 +0000
+++ src/tools/dbdReport.pl 2012-03-14 21:45:30 +0000
@@ -0,0 +1,64 @@
+#!/usr/bin/perl
+
+#*************************************************************************
+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in file LICENSE that is included with this distribution.
+#*************************************************************************
+
+# $Id$
+
+use FindBin qw($Bin);
+use lib "$Bin/../../lib/perl";
+
+use DBD;
+use DBD::Parser;
+use EPICS::Getopts;
+use EPICS::macLib;
+use EPICS::Readfile;
+use Text::Wrap;
+
+#$EPICS::Readfile::debug = 1;
+#$DBD::Parser::debug = 1;
+
+getopts('I@S@') or die usage();
+
+sub usage() {
+ "Usage: dbdReport [-I dir:dir2] [-S macro=val,...] file.dbd ...";
+}
+
+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
+my $macros = EPICS::macLib->new(@opt_S);
+my $dbd = DBD->new();
+
+&ParseDBD($dbd, &Readfile(shift @ARGV, $macros, \@opt_I));
+
+$Text::Wrap::columns = 75;
+
+my @menus = sort keys %{$dbd->menus};
+print wrap("Menus:\t", "\t", join(', ', @menus)), "\n"
+ if @menus;
+my @drivers = sort keys %{$dbd->drivers};
+print wrap("Drivers: ", "\t", join(', ', @drivers)), "\n"
+ if @drivers;
+my @variables = sort keys %{$dbd->variables};
+print wrap("Variables: ", "\t", join(', ', @variables)), "\n"
+ if @variables;
+my @registrars = sort keys %{$dbd->registrars};
+print wrap("Registrars: ", "\t", join(', ', @registrars)), "\n"
+ if @registrars;
+my @breaktables = sort keys %{$dbd->breaktables};
+print wrap("Breaktables: ", "\t", join(', ', @breaktables)), "\n"
+ if @breaktables;
+my %recordtypes = %{$dbd->recordtypes};
+if (%recordtypes) {
+ @rtypes = sort keys %recordtypes;
+ print wrap("Recordtypes: ", "\t", join(', ', @rtypes)), "\n";
+ foreach my $rtyp (@rtypes) {
+ my @devices = $recordtypes{$rtyp}->devices;
+ print wrap("Devices($rtyp): ", "\t",
+ join(', ', map {$_->choice} @devices)), "\n"
+ if @devices;
+ }
+}
=== added file 'src/tools/dbdToHtml.pl'
--- src/tools/dbdToHtml.pl 1970-01-01 00:00:00 +0000
+++ src/tools/dbdToHtml.pl 2012-03-14 21:45:30 +0000
@@ -0,0 +1,252 @@
+#!/usr/bin/perl
+
+#*************************************************************************
+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in file LICENSE that is included with this distribution.
+#*************************************************************************
+
+# $Id$
+
+use FindBin qw($Bin);
+use lib "$Bin/../../lib/perl";
+
+use DBD;
+use DBD::Parser;
+use EPICS::Getopts;
+use EPICS::macLib;
+use EPICS::Readfile;
+
+my $tool = 'dbdToHtml';
+getopts('DI@o:') or
+ die "Usage: $tool [-D] [-I dir] [-o xRecord.html] xRecord.dbd\n";
+
+my @path = map { split /[:;]/ } @opt_I;
+my $dbd = DBD->new();
+
+my $infile = shift @ARGV;
+$infile =~ m/\.dbd$/ or
+ die "$tool: Input file '$infile' must have '.dbd' extension\n";
+
+&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
+
+if ($opt_D) { # Output dependencies only
+ my %filecount;
+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
+ print "$opt_o: ", join(" \\\n ", @uniqfiles), "\n\n";
+ print map { "$_:\n" } @uniqfiles;
+ exit 0;
+}
+
+my $out;
+if ($opt_o) {
+ $out = $opt_o;
+} else {
+ ($out = $infile) =~ s/\.dbd$/.html/;
+ $out =~ s/^.*\///;
+ $out =~ s/dbCommonRecord/dbCommon/;
+}
+open $out, '>', $opt_o or die "Can't create $opt_o: $!\n";
+
+print $out "<h1>$infile</h1>\n";
+
+my $rtypes = $dbd->recordtypes;
+
+my ($rn, $rtyp) = each %{$rtypes};
+print $out "<h2>Record Name $rn</h2>\n";
+
+my @fields = $rtyp->fields;
+
+#create a Hash to store the table of field information for each GUI type
+%dbdTables = (
+ "GUI_COMMON" => "",
+ "GUI_COMMON" => "",
+ "GUI_ALARMS" => "",
+ "GUI_BITS1" => "",
+ "GUI_BITS2" => "",
+ "GUI_CALC" => "",
+ "GUI_CLOCK" => "",
+ "GUI_COMPRESS" => "",
+ "GUI_CONVERT" => "",
+ "GUI_DISPLAY" => "",
+ "GUI_HIST" => "",
+ "GUI_INPUTS" => "",
+ "GUI_LINKS" => "",
+ "GUI_MBB" => "",
+ "GUI_MOTOR" => "",
+ "GUI_OUTPUT" => "",
+ "GUI_PID" => "",
+ "GUI_PULSE" => "",
+ "GUI_SELECT" => "",
+ "GUI_SEQ1" => "",
+ "GUI_SEQ2" => "",
+ "GUI_SEQ3" => "",
+ "GUI_SUB" => "",
+ "GUI_TIMER" => "",
+ "GUI_WAVE" => "",
+ "GUI_SCAN" => "",
+ "GUI_NONE" => ""
+);
+
+
+#Loop over all of the fields. Build a string that contains the table body
+#for each of the GUI Types based on which fields go with which GUI type.
+foreach $fVal (@fields) {
+ my $pg = $fVal->attribute('promptgroup');
+ while ( ($typ1, $content) = each %dbdTables) {
+ if ( $pg eq $typ1 or ($pg eq "" and $typ1 eq "GUI_NONE")) {
+ buildTableRow($fVal, $dbdTables{$typ1} );
+ }
+ }
+}
+
+#Write out each table
+while ( ($typ2, $content) = each %dbdTables) {
+ printHtmlTable($typ2, $content);
+}
+
+
+#add a field to a table body. The specified field and table body are passed
+#in as parameters
+sub buildTableRow {
+ my ( $fld, $outStr) = @_;
+ $longDesc = " ";
+ %htmlCellFmt = (
+ rowStart => "<tr><td rowspan = \"2\">",
+ nextCell => "</td><td>",
+ endRow => "</td></tr>",
+ nextRow => "<tr><td colspan = \"7\" align=left>"
+ );
+ my %cellFmt = %htmlCellFmt;
+ my $rowStart = $cellFmt{rowStart};
+ my $nextCell = $cellFmt{nextCell};
+ my $endRow = $cellFmt{endRow};
+ my $nextRow = $cellFmt{nextRow};
+ $outStr = $outStr . $rowStart;
+ $outStr = $outStr . $fld->name;
+ $outStr = $outStr . $nextCell;
+ $outStr = $outStr . $fld->attribute('prompt');
+ $outStr = $outStr . $nextCell;
+ my $recType = $fld->dbf_type;
+ $typStr = $recType;
+ if ($recType eq "DBF_STRING") {
+ $typStr = $recType . " [" . $fld->attribute('size') . "]";
+ }
+
+ $outStr = $outStr . $typStr;
+ $outStr = $outStr . $nextCell;
+ $outStr = $outStr . design($fld);
+ $outStr = $outStr . $nextCell;
+ my $initial = $fld->attribute('initial');
+ if ( $initial eq '' ) {$initial = " ";}
+ $outStr = $outStr . $initial;
+ $outStr = $outStr . $nextCell;
+ $outStr = $outStr . readable($fld);
+ $outStr = $outStr . $nextCell;
+ $outStr = $outStr . writable($fld);
+ $outStr = $outStr . $nextCell;
+ $outStr = $outStr . processPassive($fld);
+ $outStr = $outStr . $endRow;
+ $outStr = $outStr . "\n";
+ $outStr = $outStr . $nextRow;
+ $outStr = $outStr . $longDesc;
+ $outStr = $outStr . $endRow;
+ $outStr = $outStr . "\n";
+ $_[1] = $outStr;
+}
+
+#Check if the prompt group is defined so that this can be used by clients
+sub design {
+ my $fld = $_[0];
+ my $pg = $fld->attribute('promptgroup');
+ if ( $pg eq '' ) {
+ my $result = 'No';
+ }
+ else {
+ my $result = 'Yes';
+ }
+}
+
+#Check if this field is readable by clients
+sub readable {
+ my $fld = $_[0];
+ if ( $fld->attribute('special') eq "SPC_DBADDR") {
+ $return = "Probably";
+ }
+ else{
+ if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
+ $return = "No";
+ }
+ else {
+ $return = "Yes"
+ }
+ }
+}
+
+#Check if this field is writable by clients
+sub writable {
+ my $fld = $_[0];
+ my $spec = $fld->attribute('special');
+ if ( $spec eq "SPC_NOMOD" ) {
+ $return = "No";
+ }
+ else {
+ if ( $spec ne "SPC_DBADDR") {
+ if ( $fld->dbf_type eq "DBF_NOACCESS" ) {
+ $return = "No";
+ }
+ else {
+ $return = "Yes";
+ }
+ }
+ else {
+ $return = "Maybe";
+ }
+ }
+}
+
+
+#Check to see if the field is process passive on caput
+sub processPassive {
+ my $fld = $_[0];
+ $pp = $fld->attribute('pp');
+ if ( $pp eq "YES" or $pp eq "TRUE" ) {
+ $result = "Yes";
+ }
+ elsif ( $PP eq "NO" or $pp eq "FALSE" or $pp eq "" ) {
+ $result = "No";
+ }
+}
+
+#print the start row to define a table
+sub printTableStart {
+ print $out "<table border =\"1\"> \n";
+ print $out "<caption><em>$_[0]</em></caption>";
+ print $out "<th>Field</th>\n";
+ print $out "<th>Summary</th>\n";
+ print $out "<th>Type</th>\n";
+ print $out "<th>DCT</th>\n";
+ print $out "<th>Default</th>\n";
+ print $out "<th>Read</th>\n";
+ print $out "<th>Write</th>\n";
+ print $out "<th>caPut=PP</th></tr>\n";
+
+}
+
+#print the tail end of the table
+sub printTableEnd {
+ print $out "</table>\n";
+}
+
+# Print the table for a GUI type. The name of the GUI type and the Table body
+# for this type are fed in as parameters
+sub printHtmlTable {
+ my ($typ2, $content) = $_;
+ if ( (length $_[1]) gt 0) {
+ printTableStart($_[0]);
+ print $out "$_[1]\n";
+ printTableEnd();
+ }
+
+}
=== added file 'src/tools/dbdToMenuH.pl'
--- src/tools/dbdToMenuH.pl 1970-01-01 00:00:00 +0000
+++ src/tools/dbdToMenuH.pl 2012-03-14 21:45:30 +0000
@@ -0,0 +1,80 @@
+#!/usr/bin/perl
+
+#*************************************************************************
+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in file LICENSE that is included with this distribution.
+#*************************************************************************
+
+# $Id$
+
+use FindBin qw($Bin);
+use lib "$Bin/../../lib/perl";
+
+use EPICS::Getopts;
+use File::Basename;
+use DBD;
+use DBD::Parser;
+use EPICS::macLib;
+use EPICS::Readfile;
+
+my $tool = 'dbdToMenuH.pl';
+
+use vars qw($opt_D @opt_I $opt_o $opt_s);
+getopts('DI@o:') or
+ die "Usage: $tool: [-D] [-I dir] [-o menu.h] menu.dbd [menu.h]\n";
+
+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
+my $dbd = DBD->new();
+
+my $infile = shift @ARGV;
+$infile =~ m/\.dbd$/ or
+ die "$tool: Input file '$infile' must have '.dbd' extension\n";
+my $inbase = basename($infile);
+
+my $outfile;
+if ($opt_o) {
+ $outfile = $opt_o;
+} elsif (@ARGV) {
+ $outfile = shift @ARGV;
+} else {
+ ($outfile = $infile) =~ s/\.dbd$/.h/;
+ $outfile =~ s/^.*\///;
+}
+my $outbase = basename($outfile);
+
+# Derive a name for the include guard
+my $guard_name = "INC_$outbase";
+$guard_name =~ tr/a-zA-Z0-9_/_/cs;
+$guard_name =~ s/(_[hH])?$/_H/;
+
+&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
+
+if ($opt_D) {
+ my %filecount;
+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
+ print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
+ print map { "$_:\n" } @uniqfiles;
+} else {
+ open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
+ print OUTFILE "/* $outbase generated from $inbase */\n\n",
+ "#ifndef $guard_name\n",
+ "#define $guard_name\n\n";
+ my $menus = $dbd->menus;
+ while (my ($name, $menu) = each %{$menus}) {
+ print OUTFILE $menu->toDeclaration;
+ }
+# FIXME: Where to put metadata for widely used menus?
+# In the generated menu.h file is wrong: can't create a list of menu.h files.
+# Can only rely on registerRecordDeviceDriver output, so we must require that
+# all such menus be named "menu...", and any other menus must be defined in
+# the record.dbd file that needs them.
+# print OUTFILE "\n#ifdef GEN_MENU_METADATA\n\n";
+# while (($name, $menu) = each %{$menus}) {
+# print OUTFILE $menu->toDefinition;
+# }
+# print OUTFILE "\n#endif /* GEN_MENU_METADATA */\n";
+ print OUTFILE "\n#endif /* $guard_name */\n";
+ close OUTFILE;
+}
=== added file 'src/tools/dbdToRecordtypeH.pl'
--- src/tools/dbdToRecordtypeH.pl 1970-01-01 00:00:00 +0000
+++ src/tools/dbdToRecordtypeH.pl 2012-03-14 21:45:30 +0000
@@ -0,0 +1,231 @@
+#!/usr/bin/perl
+
+#*************************************************************************
+# Copyright (c) 2010 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in file LICENSE that is included with this distribution.
+#*************************************************************************
+
+# $Id$
+
+use FindBin qw($Bin);
+use lib "$Bin/../../lib/perl";
+
+use EPICS::Getopts;
+use File::Basename;
+use DBD;
+use DBD::Parser;
+use EPICS::macLib;
+use EPICS::Readfile;
+
+my $tool = 'dbdToRecordtypeH.pl';
+
+use vars qw($opt_D @opt_I $opt_o $opt_s);
+getopts('DI@o:s') or
+ die "Usage: $tool [-D] [-I dir] [-o xRecord.h] xRecord.dbd [xRecord.h]\n";
+
+my @path = map { split /[:;]/ } @opt_I; # FIXME: Broken on Win32?
+my $dbd = DBD->new();
+
+my $infile = shift @ARGV;
+$infile =~ m/\.dbd$/ or
+ die "$tool: Input file '$infile' must have '.dbd' extension\n";
+my $inbase = basename($infile);
+
+my $outfile;
+if ($opt_o) {
+ $outfile = $opt_o;
+} elsif (@ARGV) {
+ $outfile = shift @ARGV;
+} else {
+ ($outfile = $infile) =~ s/\.dbd$/.h/;
+ $outfile =~ s/^.*\///;
+ $outfile =~ s/dbCommonRecord/dbCommon/;
+}
+my $outbase = basename($outfile);
+
+# Derive a name for the include guard
+my $guard_name = "INC_$outbase";
+$guard_name =~ tr/a-zA-Z0-9_/_/cs;
+$guard_name =~ s/(_[hH])?$/_H/;
+
+&ParseDBD($dbd, &Readfile($infile, 0, \@opt_I));
+
+my $rtypes = $dbd->recordtypes;
+die "$tool: Input file must contain a single recordtype definition.\n"
+ unless (1 == keys %{$rtypes});
+
+if ($opt_D) { # Output dependencies only, to stdout
+ my %filecount;
+ my @uniqfiles = grep { not $filecount{$_}++ } @inputfiles;
+ print "$outfile: ", join(" \\\n ", @uniqfiles), "\n\n";
+ print map { "$_:\n" } @uniqfiles;
+} else {
+ open OUTFILE, ">$outfile" or die "$tool: Can't open $outfile: $!\n";
+ print OUTFILE "/* $outbase generated from $inbase */\n\n",
+ "#ifndef $guard_name\n",
+ "#define $guard_name\n\n";
+
+ our ($rn, $rtyp) = each %{$rtypes};
+
+ print OUTFILE $rtyp->toCdefs;
+
+ my @menu_fields = grep {
+ $_->dbf_type eq 'DBF_MENU'
+ } $rtyp->fields;
+ my %menu_used;
+ grep {
+ !$menu_used{$_}++
+ } map {
+ $_->attribute('menu')
+ } @menu_fields;
+ our $menus_defined = $dbd->menus;
+ while (my ($name, $menu) = each %{$menus_defined}) {
+ print OUTFILE $menu->toDeclaration;
+ if ($menu_used{$name}) {
+ delete $menu_used{$name}
+ } else {
+ warn "Menu '$name' defined but not used\n";
+ }
+ }
+ our @menus_external = keys %menu_used;
+
+ print OUTFILE $rtyp->toDeclaration;
+
+ unless ($rn eq 'dbCommon') {
+ my $n = 0;
+ print OUTFILE "typedef enum {\n",
+ join(",\n",
+ map { "\t${rn}Record$_ = " . $n++ } $rtyp->field_names),
+ "\n} ${rn}FieldIndex;\n\n";
+ print OUTFILE "#ifdef GEN_SIZE_OFFSET\n\n";
+ if ($opt_s) {
+ &newtables;
+ } else {
+ &oldtables;
+ }
+ print OUTFILE "#endif /* GEN_SIZE_OFFSET */\n";
+ }
+ print OUTFILE "\n",
+ "#endif /* $guard_name */\n";
+ close OUTFILE;
+}
+
+sub oldtables {
+ # Output compatible with R3.14.x
+ print OUTFILE "#ifdef __cplusplus\n" .
+ "extern \"C\" {\n" .
+ "#endif\n" .
+ "#include <epicsExport.h>\n" .
+ "static int ${rn}RecordSizeOffset(dbRecordType *prt)\n" .
+ "{\n" .
+ " ${rn}Record *prec = 0;\n" .
+ join("\n", map {
+ " prt->papFldDes[${rn}Record" . $_->name . "]->size = " .
+ "sizeof(prec->" . $_->C_name . ");"
+ } $rtyp->fields) . "\n" .
+ join("\n", map {
+ " prt->papFldDes[${rn}Record" . $_->name . "]->offset = " .
+ "(char *)&prec->" . $_->C_name . " - (char *)prec;"
+ } $rtyp->fields) . "\n" .
+ " prt->rec_size = sizeof(*prec);\n" .
+ " return 0;\n" .
+ "}\n" .
+ "epicsExportRegistrar(${rn}RecordSizeOffset);\n\n" .
+ "#ifdef __cplusplus\n" .
+ "}\n" .
+ "#endif\n";
+}
+
+sub newtables {
+ # Output for an eventual DBD-less IOC
+ print OUTFILE (map {
+ "extern const dbMenu ${_}MenuMetaData;\n"
+ } @menus_external), "\n";
+ while (my ($name, $menu) = each %{$menus_defined}) {
+ print OUTFILE $menu->toDefinition;
+ }
+ print OUTFILE (map {
+ "static const char ${rn}FieldName$_\[] = \"$_\";\n" }
+ $rtyp->field_names), "\n";
+ my $n = 0;
+ print OUTFILE "static const dbRecordData ${rn}RecordMetaData;\n\n",
+ "static dbFldDes ${rn}FieldMetaData[] = {\n",
+ join(",\n", map {
+ my $fn = $_->name;
+ my $cn = $_->C_name;
+ " { ${rn}FieldName${fn}," .
+ $_->dbf_type . ',"' .
+ $_->attribute('initial') . '",' .
+ ($_->attribute('special') || '0') . ',' .
+ ($_->attribute('pp') || 'FALSE') . ',' .
+ ($_->attribute('interest') || '0') . ',' .
+ ($_->attribute('asl') || 'ASL0') . ',' .
+ $n++ . ",\n\t\&${rn}RecordMetaData," .
+ "GEOMETRY_DATA(${rn}Record,$cn) }";
+ } $rtyp->fields),
+ "\n};\n\n";
+ print OUTFILE "static const ${rn}FieldIndex ${rn}RecordLinkFieldIndices[] = {\n",
+ join(",\n", map {
+ " ${rn}Record" . $_->name;
+ } grep {
+ $_->dbf_type =~ m/^DBF_(IN|OUT|FWD)LINK/;
+ } $rtyp->fields),
+ "\n};\n\n";
+ my @sorted_names = sort $rtyp->field_names;
+ print OUTFILE "static const char * const ${rn}RecordSortedFieldNames[] = {\n",
+ join(",\n", map {
+ " ${rn}FieldName$_"
+ } @sorted_names),
+ "\n};\n\n";
+ print OUTFILE "static const ${rn}FieldIndex ${rn}RecordSortedFieldIndices[] = {\n",
+ join(",\n", map {
+ " ${rn}Record$_"
+ } @sorted_names),
+ "\n};\n\n";
+ print OUTFILE "extern rset ${rn}RSET;\n\n",
+ "static const dbRecordData ${rn}RecordMetaData = {\n",
+ " \"$rn\",\n",
+ " sizeof(${rn}Record),\n",
+ " NELEMENTS(${rn}FieldMetaData),\n",
+ " ${rn}FieldMetaData,\n",
+ " ${rn}RecordVAL,\n",
+ " \&${rn}FieldMetaData[${rn}RecordVAL],\n",
+ " NELEMENTS(${rn}RecordLinkFieldIndices),\n",
+ " ${rn}RecordLinkFieldIndices,\n",
+ " ${rn}RecordSortedFieldNames,\n",
+ " ${rn}RecordSortedFieldIndices,\n",
+ " \&${rn}RSET\n",
+ "};\n\n",
+ "#ifdef __cplusplus\n",
+ "extern \"C\" {\n",
+ "#endif\n\n";
+ print OUTFILE "dbRecordType * epicsShareAPI ${rn}RecordRegistrar(dbBase *pbase, int nDevs)\n",
+ "{\n",
+ " dbRecordType *prt = dbCreateRecordtype(&${rn}RecordMetaData, nDevs);\n";
+ print OUTFILE " ${rn}FieldMetaData[${rn}RecordDTYP].typDat.pdevMenu = \&prt->devMenu;\n";
+ while (my ($name, $menu) = each %{$menus_defined}) {
+ print OUTFILE " dbRegisterMenu(pbase, \&${name}MenuMetaData);\n";
+ }
+ print OUTFILE map {
+ " ${rn}FieldMetaData[${rn}Record" .
+ $_->name .
+ "].typDat.pmenu = \n".
+ " \&" .
+ $_->attribute('menu') .
+ "MenuMetaData;\n";
+ } @menu_fields;
+ print OUTFILE map {
+ " ${rn}FieldMetaData[${rn}Record" .
+ $_->name .
+ "].typDat.base = CT_HEX;\n";
+ } grep {
+ $_->attribute('base') eq 'HEX';
+ } $rtyp->fields;
+ print OUTFILE " dbRegisterRecordtype(pbase, prt);\n";
+ print OUTFILE " return prt;\n}\n\n",
+ "#ifdef __cplusplus\n",
+ "} /* extern \"C\" */\n",
+ "#endif\n\n";
+}
=== added directory 'src/tools/test'
=== added file 'src/tools/test/Breaktable.plt'
--- src/tools/test/Breaktable.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Breaktable.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,22 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 9;
+
+use DBD::Breaktable;
+
+my $bpt = DBD::Breaktable->new('test');
+isa_ok $bpt, 'DBD::Breaktable';
+is $bpt->name, 'test', 'Breakpoint table name';
+is $bpt->points, 0, 'Points == zero';
+$bpt->add_point(0, 0.5);
+is $bpt->points, 1, 'First point added';
+is_deeply $bpt->point(0), [0, 0.5], 'First point correct';
+$bpt->add_point(1, 1.5);
+is $bpt->points, 2, 'Second point added';
+is_deeply $bpt->point(0), [0, 0.5], 'First point still correct';
+is_deeply $bpt->point(1), [1, 1.5], 'Second point correct';
+is_deeply $bpt->point(2), undef, 'Third point undefined';
+
=== added file 'src/tools/test/DBD.plt'
--- src/tools/test/DBD.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/DBD.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,60 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 18;
+
+use DBD;
+
+my $dbd = DBD->new;
+isa_ok $dbd, 'DBD';
+
+is keys %{$dbd->breaktables}, 0, 'No breaktables yet';
+my $brk = DBD::Breaktable->new('Brighton');
+$dbd->add($brk);
+my %brks = %{$dbd->breaktables};
+is_deeply \%brks, {Brighton => $brk}, 'Added breaktable';
+
+is keys %{$dbd->drivers}, 0, 'No drivers yet';
+my $drv = DBD::Driver->new('Danforth');
+$dbd->add($drv);
+my %drvs = %{$dbd->drivers};
+is_deeply \%drvs, {Danforth => $drv}, 'Added driver';
+
+is keys %{$dbd->functions}, 0, 'No functions yet';
+my $fnc = DBD::Function->new('Frank');
+$dbd->add($fnc);
+my %fncs = %{$dbd->functions};
+is_deeply \%fncs, {Frank => $fnc}, 'Added function';
+
+is keys %{$dbd->menus}, 0, 'No menus yet';
+my $menu = DBD::Menu->new('Mango');
+$dbd->add($menu);
+my %menus = %{$dbd->menus};
+is_deeply \%menus, {Mango => $menu}, 'Added menu';
+is $dbd->menu('Mango'), $menu, 'Named menu';
+
+is keys %{$dbd->recordtypes}, 0, 'No recordtypes yet';
+my $rtyp = DBD::Recordtype->new('Rita');
+$dbd->add($rtyp);
+my %rtypes = %{$dbd->recordtypes};
+is_deeply \%rtypes, {Rita => $rtyp}, 'Added recordtype';
+is $dbd->recordtype('Rita'), $rtyp, 'Named recordtype';
+
+is keys %{$dbd->registrars}, 0, 'No registrars yet';
+my $reg = DBD::Registrar->new('Reggie');
+$dbd->add($reg);
+my %regs = %{$dbd->registrars};
+is_deeply \%regs, {Reggie => $reg}, 'Added registrar';
+
+is keys %{$dbd->variables}, 0, 'No variables yet';
+my $ivar = DBD::Variable->new('IntVar');
+my $dvar = DBD::Variable->new('DblVar', 'double');
+$dbd->add($ivar);
+my %vars = %{$dbd->variables};
+is_deeply \%vars, {IntVar => $ivar}, 'First variable';
+$dbd->add($dvar);
+%vars = %{$dbd->variables};
+is_deeply \%vars, {IntVar => $ivar, DblVar => $dvar}, 'Second variable';
+
=== added file 'src/tools/test/Device.plt'
--- src/tools/test/Device.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Device.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,33 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 16;
+
+use DBD::Device;
+
+my $dev = DBD::Device->new('VME_IO', 'test', '"Device"');
+isa_ok $dev, 'DBD::Device';
+is $dev->name, 'test', 'Device name';
+is $dev->link_type, 'VME_IO', 'Link type';
+is $dev->choice, 'Device', 'Choice string';
+ok $dev->legal_addr('#C0xFEED S123 @xxx'), 'Address legal';
+my %dev_addrs = (
+ CONSTANT => '12345',
+ PV_LINK => 'Any:Record.NAME CPP.MS',
+ VME_IO => '# C1 S2 @Anything',
+ CAMAC_IO => '# B1 C2 N3 A4 F5 @Anything',
+ RF_IO => '# R1 M2 D3 E4',
+ AB_IO => '# L1 A2 C3 S4 @Anything',
+ GPIB_IO => '# L1 A2 @Anything',
+ BITBUS_IO => '# L1 N2 P3 S4 @Anything',
+ BBGPIB_IO => '# L1 B2 G3 @Anything',
+ VXI_IO => '# V1 C2 S3 @Anything',
+ INST_IO => '@Anything'
+);
+while (my ($link, $addr) = each(%dev_addrs)) {
+ $dev->init($link, 'test', '"Device"');
+ ok $dev->legal_addr($addr), "$link address";
+}
+
=== added file 'src/tools/test/Driver.plt'
--- src/tools/test/Driver.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Driver.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 2;
+
+use DBD::Driver;
+
+my $drv = DBD::Driver->new('test');
+isa_ok $drv, 'DBD::Driver';
+is $drv->name, 'test', 'Driver name';
+
=== added file 'src/tools/test/Function.plt'
--- src/tools/test/Function.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Function.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 2;
+
+use DBD::Function;
+
+my $func = DBD::Function->new('test');
+isa_ok $func, 'DBD::Function';
+is $func->name, 'test', 'Function name';
+
=== added file 'src/tools/test/Makefile'
--- src/tools/test/Makefile 1970-01-01 00:00:00 +0000
+++ src/tools/test/Makefile 2012-03-14 21:45:30 +0000
@@ -0,0 +1,26 @@
+#*************************************************************************
+# Copyright (c) 2012 UChicago Argonne LLC, as Operator of Argonne
+# National Laboratory.
+# EPICS BASE is distributed subject to a Software License Agreement found
+# in the file LICENSE that is included with this distribution.
+#*************************************************************************
+TOP=../../..
+
+include $(TOP)/configure/CONFIG
+
+TESTS += Breaktable
+TESTS += DBD
+TESTS += Device
+TESTS += Driver
+TESTS += Function
+TESTS += macLib
+TESTS += Menu
+TESTS += Recfield
+TESTS += Recordtype
+TESTS += Registrar
+TESTS += Variable
+
+TESTSCRIPTS_HOST += $(TESTS:%=%.t)
+
+include $(TOP)/configure/RULES
+
=== added file 'src/tools/test/Menu.plt'
--- src/tools/test/Menu.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Menu.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,32 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 14;
+
+use DBD::Menu;
+
+my $menu = DBD::Menu->new('test');
+isa_ok $menu, 'DBD::Menu';
+is $menu->name, 'test', 'Menu name';
+is $menu->choices, 0, 'Choices == zero';
+$menu->add_choice('ch1', '"Choice 1"');
+is $menu->choices, 1, 'First choice added';
+ok $menu->legal_choice('Choice 1'), 'First choice legal';
+is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice found';
+$menu->add_choice('ch2', '"Choice 2"');
+is $menu->choices, 2, 'Second choice added';
+ok $menu->legal_choice('Choice 1'), 'First choice still legal';
+is_deeply $menu->choice(0), ['ch1', 'Choice 1'], 'First choice still found';
+ok $menu->legal_choice('Choice 2'), 'Second choice legal';
+is_deeply $menu->choice(1), ['ch2', 'Choice 2'], 'Second choice found';
+ok !$menu->legal_choice('Choice 3'), 'Third choice not legal';
+is_deeply $menu->choice(2), undef, 'Third choice undefined';
+
+like $menu->toDeclaration, qr/ ^
+ \s* typedef \s+ enum \s+ {
+ \s+ ch1 \s+ \/\* [^*]* \*\/,
+ \s+ ch2 \s+ \/\* [^*]* \*\/,
+ \s+ test_NUM_CHOICES ,?
+ \s+ } \s+ test; \s* $ /x, 'C declaration';
=== added file 'src/tools/test/Recfield.plt'
--- src/tools/test/Recfield.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Recfield.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,114 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 76;
+
+use DBD::Recfield;
+
+my $fld_string = DBD::Recfield->new('str', 'DBF_STRING');
+isa_ok $fld_string, 'DBD::Recfield';
+isa_ok $fld_string, 'DBD::Recfield::DBF_STRING';
+$fld_string->set_number(0);
+is $fld_string->number, 0, 'Field number';
+$fld_string->add_attribute("size", "41");
+is keys %{$fld_string->attributes}, 1, "Size set";
+ok $fld_string->legal_value("Hello, world!"), 'Legal value';
+ok !$fld_string->legal_value("x"x41), 'Illegal string';
+$fld_string->check_valid;
+like $fld_string->toDeclaration, qr/^\s*char\s+str\[41\];\s*$/, "C declaration";
+
+my $fld_char = DBD::Recfield->new('chr', 'DBF_CHAR');
+isa_ok $fld_char, 'DBD::Recfield';
+isa_ok $fld_char, 'DBD::Recfield::DBF_CHAR';
+is $fld_char->name, 'chr', 'Field name';
+is $fld_char->dbf_type, 'DBF_CHAR', 'Field type';
+ok !$fld_char->legal_value("-129"), 'Illegal - value';
+ok $fld_char->legal_value("-128"), 'Legal - value';
+ok $fld_char->legal_value("127"), 'Legal + value';
+ok !$fld_char->legal_value("0x80"), 'Illegal + hex value';
+$fld_char->check_valid;
+like $fld_char->toDeclaration, qr/^\s*epicsInt8\s+chr;\s*$/, "C declaration";
+
+my $fld_uchar = DBD::Recfield->new('uchr', 'DBF_UCHAR');
+isa_ok $fld_uchar, 'DBD::Recfield';
+isa_ok $fld_uchar, 'DBD::Recfield::DBF_UCHAR';
+is $fld_uchar->name, 'uchr', 'Field name';
+is $fld_uchar->dbf_type, 'DBF_UCHAR', 'Field type';
+ok !$fld_uchar->legal_value("-1"), 'Illegal - value';
+ok $fld_uchar->legal_value("0"), 'Legal 0 value';
+ok $fld_uchar->legal_value("0377"), 'Legal + value';
+ok !$fld_uchar->legal_value("0400"), 'Illegal + octal value';
+$fld_uchar->check_valid;
+like $fld_uchar->toDeclaration, qr/^\s*epicsUInt8\s+uchr;\s*$/, "C declaration";
+
+my $fld_short = DBD::Recfield->new('shrt', 'DBF_SHORT');
+isa_ok $fld_short, 'DBD::Recfield';
+isa_ok $fld_short, 'DBD::Recfield::DBF_SHORT';
+is $fld_short->name, 'shrt', 'Field name';
+is $fld_short->dbf_type, 'DBF_SHORT', 'Field type';
+ok !$fld_short->legal_value("-32769"), 'Illegal - value';
+ok $fld_short->legal_value("-32768"), 'Legal - value';
+ok $fld_short->legal_value("32767"), 'Legal + value';
+ok !$fld_short->legal_value("0x8000"), 'Illegal + hex value';
+$fld_short->check_valid;
+like $fld_short->toDeclaration, qr/^\s*epicsInt16\s+shrt;\s*$/, "C declaration";
+
+my $fld_ushort = DBD::Recfield->new('ushrt', 'DBF_USHORT');
+isa_ok $fld_ushort, 'DBD::Recfield';
+isa_ok $fld_ushort, 'DBD::Recfield::DBF_USHORT';
+is $fld_ushort->name, 'ushrt', 'Field name';
+is $fld_ushort->dbf_type, 'DBF_USHORT', 'Field type';
+ok !$fld_ushort->legal_value("-1"), 'Illegal - value';
+ok $fld_ushort->legal_value("0"), 'Legal 0 value';
+ok $fld_ushort->legal_value("65535"), 'Legal + value';
+ok !$fld_ushort->legal_value("0x10000"), 'Illegal + hex value';
+$fld_ushort->check_valid;
+like $fld_ushort->toDeclaration, qr/^\s*epicsUInt16\s+ushrt;\s*$/, "C declaration";
+
+my $fld_long = DBD::Recfield->new('lng', 'DBF_LONG');
+isa_ok $fld_long, 'DBD::Recfield';
+isa_ok $fld_long, 'DBD::Recfield::DBF_LONG';
+is $fld_long->name, 'lng', 'Field name';
+is $fld_long->dbf_type, 'DBF_LONG', 'Field type';
+ok $fld_long->legal_value("-12345678"), 'Legal - value';
+ok $fld_long->legal_value("0x12345678"), 'Legal + value';
+ok !$fld_long->legal_value("0xfigure"), 'Illegal value';
+$fld_long->check_valid;
+like $fld_long->toDeclaration, qr/^\s*epicsInt32\s+lng;\s*$/, "C declaration";
+
+my $fld_ulong = DBD::Recfield->new('ulng', 'DBF_ULONG');
+isa_ok $fld_ulong, 'DBD::Recfield';
+isa_ok $fld_ulong, 'DBD::Recfield::DBF_ULONG';
+is $fld_ulong->name, 'ulng', 'Field name';
+is $fld_ulong->dbf_type, 'DBF_ULONG', 'Field type';
+ok !$fld_ulong->legal_value("-1"), 'Illegal - value';
+ok $fld_ulong->legal_value("00"), 'Legal 0 value';
+ok $fld_ulong->legal_value("0xffffffff"), 'Legal + value';
+ok !$fld_ulong->legal_value("0xfacepaint"), 'Illegal value';
+$fld_ulong->check_valid;
+like $fld_ulong->toDeclaration, qr/^\s*epicsUInt32\s+ulng;\s*$/, "C declaration";
+
+my $fld_float = DBD::Recfield->new('flt', 'DBF_FLOAT');
+isa_ok $fld_float, 'DBD::Recfield';
+isa_ok $fld_float, 'DBD::Recfield::DBF_FLOAT';
+is $fld_float->name, 'flt', 'Field name';
+is $fld_float->dbf_type, 'DBF_FLOAT', 'Field type';
+ok $fld_float->legal_value("-1.2345678e9"), 'Legal - value';
+ok $fld_float->legal_value("0.12345678e9"), 'Legal + value';
+ok !$fld_float->legal_value("0x1.5"), 'Illegal value';
+$fld_float->check_valid;
+like $fld_float->toDeclaration, qr/^\s*epicsFloat32\s+flt;\s*$/, "C declaration";
+
+my $fld_double = DBD::Recfield->new('dbl', 'DBF_DOUBLE');
+isa_ok $fld_double, 'DBD::Recfield';
+isa_ok $fld_double, 'DBD::Recfield::DBF_DOUBLE';
+is $fld_double->name, 'dbl', 'Field name';
+is $fld_double->dbf_type, 'DBF_DOUBLE', 'Field type';
+ok $fld_double->legal_value("-12345e-67"), 'Legal - value';
+ok $fld_double->legal_value("12345678e+9"), 'Legal + value';
+ok !$fld_double->legal_value("e5"), 'Illegal value';
+$fld_double->check_valid;
+like $fld_double->toDeclaration, qr/^\s*epicsFloat64\s+dbl;\s*$/, "C declaration";
+
=== added file 'src/tools/test/Recordtype.plt'
--- src/tools/test/Recordtype.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Recordtype.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,57 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 17;
+
+use DBD::Recordtype;
+use DBD::Recfield;
+use DBD::Device;
+
+my $rtyp = DBD::Recordtype->new('test');
+isa_ok $rtyp, 'DBD::Recordtype';
+is $rtyp->name, 'test', 'Record name';
+is $rtyp->fields, 0, 'No fields yet';
+
+my $fld1 = DBD::Recfield->new('NAME', 'DBF_STRING');
+$fld1->add_attribute("size", "41");
+$fld1->check_valid;
+
+my $fld2 = DBD::Recfield->new('DTYP', 'DBF_DEVICE');
+$fld2->check_valid;
+
+$rtyp->add_field($fld1);
+is $rtyp->fields, 1, 'First field added';
+
+$rtyp->add_field($fld2);
+is $rtyp->fields, 2, 'Second field added';
+
+my @fields = $rtyp->fields;
+is_deeply \@fields, [$fld1, $fld2], 'Field list';
+
+my @names = $rtyp->field_names;
+is_deeply \@names, ['NAME', 'DTYP'], 'Field name list';
+
+is $rtyp->field('NAME'), $fld1, 'Field name lookup';
+
+is $fld1->number, 0, 'Field number 0';
+is $fld2->number, 1, 'Field number 1';
+
+is $rtyp->devices, 0, 'No devices yet';
+
+my $dev1 = DBD::Device->new('INST_IO', 'testDset', 'test device');
+$rtyp->add_device($dev1);
+is $rtyp->devices, 1, 'First device added';
+
+my @devices = $rtyp->devices;
+is_deeply \@devices, [$dev1], 'Device list';
+
+is $rtyp->device('test device'), $dev1, 'Device name lookup';
+
+is $rtyp->cdefs, 0, 'No cdefs yet';
+$rtyp->add_cdef("cdef");
+is $rtyp->cdefs, 1, 'First cdef added';
+
+my @cdefs = $rtyp->cdefs;
+is_deeply \@cdefs, ["cdef"], 'cdef list';
=== added file 'src/tools/test/Registrar.plt'
--- src/tools/test/Registrar.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Registrar.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,13 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 2;
+
+use DBD::Registrar;
+
+my $reg = DBD::Registrar->new('test');
+isa_ok $reg, 'DBD::Registrar';
+is $reg->name, 'test', 'Registrar name';
+
=== added file 'src/tools/test/Variable.plt'
--- src/tools/test/Variable.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/Variable.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,15 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 4;
+
+use DBD::Variable;
+
+my $ivar = DBD::Variable->new('test');
+isa_ok $ivar, 'DBD::Variable';
+is $ivar->name, 'test', 'Variable name';
+is $ivar->var_type, 'int', 'variable defaults to int';
+my $dvar = DBD::Variable->new('test', 'double');
+is $dvar->var_type, 'double', 'double variable';
=== added file 'src/tools/test/macLib.plt'
--- src/tools/test/macLib.plt 1970-01-01 00:00:00 +0000
+++ src/tools/test/macLib.plt 2012-03-14 21:45:30 +0000
@@ -0,0 +1,72 @@
+#!/usr/bin/perl
+
+use FindBin qw($Bin);
+use lib "$Bin/../../../../lib/perl";
+
+use Test::More tests => 34;
+
+use EPICS::macLib;
+
+use Data::Dumper;
+
+my $m = EPICS::macLib->new;
+isa_ok $m, 'EPICS::macLib';
+is $m->expandString(''), '', 'Empty string';
+is $m->expandString('$(undef)'), undef, 'Warning $(undef)';
+
+$m->suppressWarning(1);
+is $m->expandString('$(undef)'), '$(undef)', 'Suppressed $(undef)';
+
+$m->putValue('a', 'foo');
+is $m->expandString('$(a)'), 'foo', '$(a)';
+is $m->expandString('${a}'), 'foo', '${a}';
+is $m->expandString('$(a=bar)'), 'foo', '$(a=bar)';
+is $m->expandString('${a=bar}'), 'foo', '${a=bar}';
+is $m->expandString('$(undef)'), '$(undef)', '$(undef) again';
+is $m->expandString('${undef}'), '$(undef)', '${undef} again';
+
+$m->suppressWarning(0);
+is $m->expandString('$(undef=$(a))'), 'foo', '$(undef=$(a))';
+is $m->expandString('${undef=${a}}'), 'foo', '${undef=${a}}';
+is $m->expandString('${undef=$(a)}'), 'foo', '${undef=$(a)}';
+is $m->expandString('$(undef=${a})'), 'foo', '$(undef=${a})';
+is $m->expandString('$(a=$(undef))'), 'foo', '$(a=$(undef))';
+
+$m->putValue('b', 'baz');
+is $m->expandString('$(b)'), 'baz', '$(b)';
+is $m->expandString('$(a)'), 'foo', '$(a)';
+is $m->expandString('$(a)$(b)'), 'foobaz', '$(a)$(b)';
+is $m->expandString('$(a)/$(b)'), 'foo/baz', '$(a)/$(b)';
+is $m->expandString('$(a)\$(b)'), 'foo\$(b)', '$(a)\$(b)';
+is $m->expandString('$(a)$$(b)'), 'foo$baz', '$(a)$$(b)';
+
+$m->putValue('c', '$(a)');
+is $m->expandString('$(c)'), 'foo', '$(c)';
+is $m->expandString('$(undef=$(c))'), 'foo', '$(undef=$(c))';
+
+$m->putValue('d', 'c');
+is $m->expandString('$(d)'), 'c', '$(d)';
+is $m->expandString('$($(d))'), 'foo', '$($(d))';
+is $m->expandString('$($(b)=$(a))'), 'foo', '$($(b)=$(a))';
+
+$m->suppressWarning(1);
+$m->putValue('c', undef);
+is $m->expandString('$(c)'), '$(c)', '$(c) deleted';
+
+$m->installMacros('c=fum,d');
+is $m->expandString('$(c)'), 'fum', 'installMacros, $(c)';
+
+is $m->expandString('$(d)'), '$(d)', 'installMacros deletion';
+
+$m->pushScope;
+is $m->expandString('$(a)'), 'foo', 'pushScope, $(a)';
+$m->putValue('a', 'grinch');
+is $m->expandString('$(a)'), 'grinch', 'new $(a) in child';
+
+$m->putValue('b', undef);
+is $m->expandString('$(b)'), '$(b)', '$(b) deleted in child';
+
+$m->popScope;
+is $m->expandString('$(a)'), 'foo', 'popScope, $(a) restored';
+is $m->expandString('$(b)'), 'baz', '$(b) restored';
+
- Replies:
- Re: [Merge] lp:~anj/epics-base/compiled-dbd into lp:epics-base Andrew Johnson
- Re: [Merge] lp:~anj/epics-base/compiled-dbd into lp:epics-base Andrew Johnson
- [Merge] lp:~anj/epics-base/compiled-dbd into lp:epics-base noreply
- Navigate by Date:
- Prev:
DBF_STRING to DBF_ENUM/MENU/DEVICE Conversions Andrew Johnson
- Next:
Re: [Merge] lp:~anj/epics-base/compiled-dbd into lp:epics-base Andrew Johnson
- Index:
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
<2012>
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
- Navigate by Thread:
- Prev:
DBF_STRING to DBF_ENUM/MENU/DEVICE Conversions Andrew Johnson
- Next:
Re: [Merge] lp:~anj/epics-base/compiled-dbd into lp:epics-base Andrew Johnson
- Index:
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
<2012>
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
|
·
Home
·
News
·
About
·
Base
·
Modules
·
Extensions
·
Distributions
·
Download
·