Viewing contents of file '../idllib/uit/pro/dbcreate.pro'
pro dbcreate,name,newindex,newdb,maxitems
;+
; NAME:
; DBCREATE
; PURPOSE:
; Create new data base file or modify description. A database
; definition file (.dbd) file must already exist.
; The default directory must be a ZDBASE: directory.
;
; CALLING SEQUENCE:
; dbcreate, name,[ newindex, newdb, maxitems]
;
; INPUT:
; name- name of the data base (with no qualifier), scalar string.
; The description will be read from the file "NAME".dbd
;
; OPTIONAL INPUTS:
; newindex - if non-zero then a new index file is created,
; otherwise it is assumed that changes do not affect the
; index file. (default=0)
; newdb - if non-zero then a new data base file (.dbf) will
; be created. Otherwise changes are assumed not to affect
; the file's present format.
; maxitems - maximum number of items in data base.
; If not supplied then the number of items is
; limited to 200.
; OUTPUTS:
; none
;
; SIDE EFFECTS:
; data base description file ZDBASE:name.dbc is created
; and optionally ZDBASE:name.dbf (data file) and
; ZDBASE.dbx (index file) if it is a new data base.
;
; RESTRICTIONS:
; If newdb=0 is not specified, the changes to the .dbd file can
; not alter the length of the records in the data base file.
; and may not alter positions of current fields in the file.
; permissible changes are:
; 1) utilization of spares to create a item or field
; 2) change in field name(s)
; 3) respecification of index items
; 4) changes in default print formats
; 5) change in data base title
; 6) changes in pointer specification to other data
; data bases
;
; !priv must be 2 or greater to execute this routine.
;
; HISTORY:
; version 2 D. Lindler OCT, 1987
; Modified to work under IDL version 2. M. Greason, STX, June 1990.
; Modified to work under Unix D. Neill, ACC, Feb 1991.
;-
;----------------------------------------------------------
On_error,2 ;Return to caller
if N_Params() LT 1 then begin
print,'Syntax - dbcreate, name, [ newindex, newdb, maxitems ]
print,' !PRIV must be 2 or greater to execute this routine'
return
endif
;
; check privilege
;
if !priv LT 2 then $
message,'!PRIV must be 2 or greater to execute this routine'
;
; check parameters
;
zparcheck, 'DBCREATE', name, 1, 7, 0, 'Database Name'
if N_params() LT 2 then newindex = 0
if N_params() LT 3 then newdb = 0
if N_params() LT 4 then maxitems = 200
filename = strtrim(name,2)
;
; set up data buffers
;
names = strarr(maxitems) ;names of items
numvals = intarr(maxitems)+1 ;number of values
type = intarr(maxitems) ;data type
nbytes = intarr(maxitems) ;number of bytes in item
desc = strarr(maxitems) ;descriptions of items
sbyte = intarr(maxitems) ;starting byte position
format = strarr(maxitems) ;print formats
headers = strarr(3,maxitems) ;print headers
headers(*,*)=' ' ;init headers
title = '' ;data base title
index = intarr(maxitems) ;index type
pointers = strarr(maxitems) ;pointer array
npointers = 0
maxentries = 30000L
alloc = 100L
;
; first item is always entry number
;
names(0) = 'ENTRY'
type(0) = 3 ;longword integer
nbytes(0) = 4 ;four bytes
desc(0) = 'Entry or Record Number'
format(0) = 'I8'
headers(1,0) = 'ENTRY'
nitems = 1
nextbyte = 4 ;next byte position in record
;
; open .dbd file
;
get_lun, unit ;get free unit number
On_ioerror, BAD_IO ;On I/O errors go to BAD_IO
openr, unit, getlog('zdbase') + filename + '.dbd'
;
; read and process input data
;
block='TITLE' ;assume first block is title
inputst=''
while not eof(unit) do begin ;loop on records in the file
;
; process next line of input
;
readf,unit,inputst
print,inputst
st=gettok(inputst,';')
if strtrim(st,2) eq '' then goto,next ;skip blank lines
if strmid(st,0,1) eq '#' then begin
block=strupcase(strmid(st,1,strlen(st)-1));begin new block
goto,next
end
;
case strtrim(block,2) of
'TITLE' : title=st
'MAXENTRIES' : maxentries=long(strtrim(st,2))
'ITEMS' : begin
;
; process statement in form
; <itemname> <datatype> <description>
;
item_name=" "
item_name=strupcase(gettok(st,' '))
st = strtrim(st, 1)
item_type = " "
item_type=gettok(st,' ')
st = strtrim(st, 1)
desc(nitems)=st
if item_name eq '' then $
message,'Invalid item name',/IOERROR
names(nitems)=gettok(item_name,'(')
if item_name ne '' then $ ;is it a vector
numvals(nitems)=fix(gettok(item_name,')'))
if item_type eq '' then $
message,'Item data type not supplied for item ' + $
strupcase(item_name),/IOERROR
data_type=strmid(strupcase(gettok(item_type,'*')),0,1)
num_bytes=item_type
if num_bytes eq '' then num_bytes='4'
if (data_type eq 'R') or (data_type eq 'I') then $
data_type=data_type+num_bytes
case data_type of
'B' : begin & idltype= 1 & nb=1 & ff='I6' & end
'L' : begin & idltype= 1 & nb=1 & ff='I6' & end
'I2': begin & idltype= 2 & nb=2 & ff='I7' & end
'I4': begin & idltype= 3 & nb=4 & ff='I11' & end
'R4': begin & idltype= 4 & nb=4 & ff='G12.6' & end
'R8': begin & idltype= 5 & nb=8 & ff='G20.12' & end
'C' : begin
idltype = 7
nb=fix(num_bytes)
ff='A'+num_bytes
end
else: message,'Invalid data type "'+ item_type+ $
'" specified',/IOERROR
endcase
format(nitems)=ff ;default print format
headers(1,nitems)=names(nitems) ;default print header
type(nitems)=idltype ;idl data type for item
nbytes(nitems)=nb ;number of bytes for item
sbyte(nitems)=nextbyte ;position in record for item
nextbyte=nextbyte+nb*numvals(nitems) ;next byte position
if nextbyte LT 0 then message, $ ;overflow?
'ERROR - Total database length must be less than 32767 bytes'
nitems=nitems+1
end
'FORMATS': begin
;
; process strings in form:
; <item name> <format> <header1>,<header2>,<header3>
;
item_name=" "
item_name=strupcase(gettok(st,' '))
item_no=0
while item_no lt nitems do begin
if strtrim(names(item_no)) eq item_name then begin
st = strtrim(st, 1)
format(item_no)=gettok(st,' ')
if strtrim(st,2) ne '' then begin
st = strtrim(st, 1)
headers(0,item_no)=gettok(st,',')
headers(1,item_no)=gettok(st,',')
headers(2,item_no)=strtrim(st)
endif
endif
item_no=item_no+1
endwhile
end
'POINTERS': begin
;
; process record in form:
; <item name> <data base name>
;
item_name=strupcase(gettok(st,' '))
item_no=0
while item_no lt nitems do begin
if strtrim(names(item_no)) eq item_name then $
pointers(item_no)=strupcase(strtrim(st, 1))
item_no=item_no+1
endwhile
endcase
'INDEX': begin
;
; process record of type:
; <item name> <index type>
;
item_name=strupcase(gettok(st,' '))
st = strtrim(st, 1)
indextype=gettok(st,' ')
item_no=0
while item_no lt nitems do begin
if strtrim(names(item_no)) eq item_name then begin
case strupcase(indextype) of
'INDEX' : index(item_no)=1
'SORTED': index(item_no)=2
'SORT' : index(item_no)=3
'SORT/INDEX' : index(item_no)=4
else : message,'Invalid index type',/IOERROR
endcase
endif
item_no=item_no+1
endwhile
end
else : begin
print,'DBCREATE-- invalid block specfication of ',block
print,' Valid values are #TITLE, #ITEMS, #FORMATS, #INDEX,'
print,' #MAXENTRIES or #POINTERS'
end
endcase
next:
endwhile; loop on records
;
; create data base descriptor record --------------------------------------
;
; byte array of 150 values
;
; bytes
; 0-18 data base name character*19
; 19-79 data base title character*61
; 80-81 number of items (integer*2)
; 82-83 record length of DBF file (integer*2)
; 84-119 values filled in by DBOPEN
;
totbytes = ((nextbyte+3)/4*4) ;make record length a multiple of 4
drec=bytarr(120)
for i=0,79 do drec(i)=32b ;blanks
drec(0) = byte(strupcase(filename))
drec(19) = byte(title)
drec(80) = byte(nitems,0,2)
drec(82) = byte(totbytes,0,2)
;
; create item description records
;
; irec(*,i) contains decription of item number i with following
; byte assignments:
; 0-19 item name (character*20)
; 20-21 IDL data type (integet*2)
; 22-23 Number of values for item (1 for scalar) (integer*2)
; 24-25 Starting byte position i record (integer*2)
; 26-27 Number of bytes per data value (integer*2)
; 28 Index type
; 29-97 Item description
; 98-99 Field length of the print format
; 100 Pointer flag
; 101-119 Data base this item points to
; 120-125 Print format
; 126-170 Print headers
; 171-199 Added by DBOPEN
irec = bytarr(200,nitems)
rec = bytarr(200)
headers = strmid(headers,0,15) ;Added 15-Sep-92
for i=0,nitems-1 do begin
rec(0:19)=32b & rec(101:170)=32b ;Default string values are blanks
rec(29:87) = 32b
rec(0) = byte(names(i))
rec(20) = byte(type(i),0,2)
rec(22) = byte(numvals(i),0,2)
rec(24) = byte(sbyte(i),0,2)
rec(26) = byte(nbytes(i),0,2)
rec(28) = index(i)
rec(29) = byte(desc(i))
if strtrim(pointers(i)) ne '' then rec(100)=1 else rec(100)=0
rec(101)= byte(strupcase(pointers(i)))
rec(120)= byte(format(i))
ff=strtrim(format(i))
flen=fix(gettok(strmid(ff,1,strlen(ff)-1),'.'))
rec(98) = byte(flen,0,2)
rec(126)= byte(headers(0,i)) > 32b ;Modified Nov-91
rec(141)= byte(headers(1,i)) > 32b
rec(156)= byte(headers(2,i)) > 32b
irec(0,i)=rec
end
;
; Make sure user is on ZDBASE and write description file
;
close,unit
openw,unit,filename+'.dbh',/segmented
;Make sure on ZDBASE:
test2 = findfile(getlog('zdbase')+filename+'.dbh',count=nfound)
if nfound EQ 0 then $
message,'The default directory is not a ZDBASE directory',/IOERROR
;
On_ioerror, NULL
writeu, unit, drec
writeu, unit, irec
;
; if new data base create .dbf and .dbx files -----------------------------
;
if newdb then begin
close,unit
if !VERSION.OS EQ "vms" then $
openw, unit, filename+'.dbf', totbytes, /NONE $
else openw, unit, filename+'.dbf'
header = bytarr(totbytes)
p = assoc(unit,header)
p(0) = header
end
;
; determine if any indexed items
;
nindex = total(index GT 0)
;
; create empty index file if needed
;
if (nindex GT 0) and (newindex) then begin
indexed = where(index GT 0)
;
; create header array
; header=intarr(7,nindex)
; header(i,*) contains values
; i=0 item number
; i=1 index type
; i=2 idl data type for the item
; i=3 starting block for header
; i=4 starting block for data
; i=5 starting block for indices (type 3)
; i=6 starting block for unsorted data (type 4)
;
nb = (maxentries+511)/512 ;number of 512 value groups
nextblock = 1
header = lonarr(7,nindex)
for ii = 0, nindex-1 do begin
item = indexed(ii)
header(0,ii) = item
header(1,ii) = index(item)
header(2,ii) = type(item)
data_blocks = nbytes(item)*nb
if index(item) NE 1 $
then header_blocks = (nbytes(item)*nb+511)/512 $
else header_blocks = 0
if (index(item) eq 3) or (index(item) EQ 4) then $
index_blocks=(4*nb) else index_blocks=0
if index(item) EQ 4 then unsort_blocks = data_blocks else $
unsort_blocks=0
header(3,ii) = nextblock
header(4,ii) = nextblock+header_blocks
header(5,ii) = header(4,ii)+data_blocks
header(6,ii) = header(5,ii)+index_blocks
nextblock = header(6,ii)+unsort_blocks
end
totblocks = nextblock
close, unit
openw, unit, filename+'.dbx', 512, /BLOCK
p = assoc(unit,lonarr(2))
p(0) = [long(nindex),maxentries]
p = assoc(unit,lonarr(7,nindex),8)
p(0) = header
endif
free_lun, unit
return
BAD_IO: free_lun,unit
print, !MSG_PREFIX+!ERR_STRING
print, !SYSERR_STRING
return
end