From:	SMTP%"RELAY-INFO-VAX@CRVAX.SRI.COM" 12-JUL-1993 09:01:16.82
To:	EVERHART
CC:	
Subj:	DCL database for DCL gurus

X-Newsgroups: comp.os.vms
Subject: DCL database for DCL gurus
Message-Id: <1993Jul11.113242.948@iwsd01.itwol.bhp.com.au>
From: WETIBD@itwol.bhp.com.au (Daiajo Tibdixious)
Date: 11 Jul 93 11:32:40 +1000
Distribution: world
Organization: BHP Information Technology
Nntp-Posting-Host: devax1
Nntp-Posting-User: wetibd
X-News-Reader: VMS NEWS 1.11
In-Reply-To: root@ifwb.w.open.de's message of Tue, 6 Jul 1993 15:50:16 GMT
Lines: 404
To: Info-VAX@kl.sri.com
X-Gateway-Source-Info: USENET

There was a slight interest in this.

DB.COM gives a simple callable or interactive access to RMS indexed files (one
at a time) with a single string key.

It was written to show how generic DB's conform to the
DISPLAY,ADD,UPDATE,DELETE model of flow of control. It also shows how fancy you
can get in DCL, and how unmodifiable large complex DCL becomes.

I actually use it, as it makes adding an database to another DCL procedure very
easy. I have included a sample application IMAIL.COM which is my nickname
database for internet mail.

DB.COM is the actual procedure, and I advise "$ @IMAIL EDIT" as the best way to
learn to use it. "?" will work at most prompts.

To use multiple relations, create a separate "DB" like symbol for each
relation. You can only return one row from one relation per call.

You can provide your own FDL for the file, or use the default one builtin to
the procedure.

If playing with DCL is not your idea of fun, then skip this article.

-- IMAIL.COM 
$	act = P1
$	it = P2
$	key = P2
$	address = P3
$	subject = P4
$	comment = P4
$!
$	self = f$element ( 0 , ";" , f$environment ( "PROCEDURE" ) )
$	here = f$element ( 0 , "]" , self )
$	me = f$parse ( self ,,, "NAME" , "SYNTAX_ONLY" )
$	tmp = f$parse ( me , "SYS$SCRATCH:.TMP" ) - ";"
$!
$	DB := @ UTILITY_ROOT:[COM]DB 'here']'me'|31|NICKNAME
$	say := write SYS$OUTPUT
$	field = "|ADDRESS|COMMENT"
$!
$	goto ACTION_'act'
--------------------------------------------------------------------------------
$ action_SEND :
$	if act .eqs. "" then act = "SEND"
$	if it .eqs. "" then inquire it
$	if it .eqs. "" then exit
$	if f$search ( it ) .eqs. ""
$	then	say it , " not found"
$		exit
$	endif
$!
$	if subject .eqs. "" then inquire subject
$	if subject .eqs. "" then subject = "Hello"
$!
$	data_address = ""
$	if f$length ( address ) .le. 31 .and. -
		 address .eqs. address - "." - "@" - "%"
$	then	DB_match = "EQ"
$		DB EXIT 'address' "" data_nickname 'field'
$		data_address = f$element ( 1 , "|" , data_nickname ) - "|"
$		delete /symbol /global data_nickname
$	endif
$!
$	if data_address .nes. "" then address = data_address
$	if address .eqs. "" then inquire address
$!
$	if address .eqs. address - "." - "@" - "%"
$	then	say "Not an internet address: """ , address , """"
$		exit
$	endif
$!
$	append SIGNATURE 'it'
$	mail 'it' "IWSD01::MX%""''address'""" /subject = "''subject'"
$	if $status then delete /log 'it';*
$	exit
--------------------------------------------------------------------------------
$ action_TEST :
$	if f$search ( tmp ) .eqs. ""
$	then	create 'tmp'
If this message doesn't bounce, a real message will follow.
$	endif
$	it = tmp
$	subject = "Testing for bounce."
$	goto action_SEND
--------------------------------------------------------------------------------
$ action_EDIT :
$	if f$mode() .nes. "INTERACTIVE"
$	then	"EDIT only works interactively"
$		exit
$	endif
$	DB "" "" "" "" "''field'"
$	exit
--------------------------------------------------------------------------------
$ action_ADD :
$	DB 'act' 'key' "''address'|''comment'" "" 'field'
$	exit
-- DB.COM
$	data_DB = P1
$	list_cmd = P2
$	key_in = P3
$	data_in = P4
$	data_out = P5
$	data_field = P6
$	set NOon
$!
$	self = f$element ( 0 , ";" , f$environment ( "PROCEDURE" ) )
$	me = f$parse ( self ,,, "NAME" , "SYNTAX_ONLY" )
$	PID = f$getjpi ( "" , "PID" )
$!
$	ask := read SYS$COMMAND code_input /prompt =
$	say := write SYS$OUTPUT
$!
$	inform = say
$	if list_cmd .nes. "" then inform = "!"
$!
$	DB_key_length = f$element ( 1 , "|" , data_DB ) - "|"
$	if DB_key_length .eqs. "" then DB_key_length = "2"
$	DB_key_length = 'DB_key_length'
$!
$	name_key = f$element ( 2 , "|" , data_DB ) - "|"
$	if name_key .eqs. "" then name_key = "KEY"
$!
$	code_field_clear = f$element ( 3 , "|" , data_DB ) - "|"
$	if code_field_clear .eqs. "" then code_field_clear = "\"
$!
$	name_fdl = f$element ( 4 , "|" , data_DB ) - "|"
$	if data_field .eqs. "" then data_field = "|Data"
$	delimeter_field = f$extract ( 0 , 1 , data_field )
$	data_field = data_field - delimeter_field
$!
$	DB_match = f$element ( 1 , "|" , key_in ) - "|"
$	if DB_match .eqs. "" then DB_match = "GE"
$	key_in = key_in - DB_match - "|"
$!
$	name_file_temp = f$element ( 0 , ";" , -
		f$parse ( "SYS$SCRATCH:" + me + "_" + PID + ".TMP" ) )
$	if name_file_temp .eqs. ""
$	then	say "Define SYS$SCRATCH for temporary files."
$		exit
$	endif
$!
$	key = key_in
$	goto DISPLAY
$ CLEAR :
$	key = ""
$ CANCEL :
$ DISPLAY :
$	mode = "DISPLAY"
$	gosub input_key
$ show :
$	mode = "DISPLAY"
$	gosub DB_get
$	gosub display_data
$	if DB_match .eqs. "GT" .and. data_out .eqs. "" then goto show
$	if DB_n .gt. 1 then inform DB_N , " records."
$	if DB_data .nes. "" then data = DB_data
$	gosub cmd_get
$	mode = cmd
$	goto 'mode'
$ DELETE :
$	gosub display_data
$	gosub cmd_get
$	if cmd .nes. mode then goto 'cmd'
$	gosub DB_delete
$	goto DISPLAY
$ UPDATE :
$ REPEAT :
$ ADD :	DB_key = key
$	gosub input_data
$	gosub display_data
$	gosub cmd_get
$	if cmd .nes. mode then goto 'cmd'
$	gosub DB_write
$	goto show
$ EXIT :
$	if data_out .nes. "" then 'data_out' == DB_key + delimeter_field + data
$	exit
--------------------------------------------------------------------------------
$ display_data :
$	if data .eqs. "" then return
$	say mode , " (" , DB_key_save , ") """ , DB_key , """..."
$	index_field = 0
$  display_data_loop :
$	name_field = f$element ( index_field , delimeter_field , data_field ) -
		- delimeter_field
$	if name_field .eqs. "" then return
$	text_field = f$element ( index_field , delimeter_field , data ) -
		- delimeter_field
$	say "	" , name_field , " = """ , text_field , """"
$	index_field = index_field + 1
$	goto display_data_loop
$	return
--------------------------------------------------------------------------------
$ input_key :
$	code_input = key
$	if list_cmd .eqs. "" then ask "''mode' ''name_key' [''key']: "
$	code_input := 'code_input'
$	if code_input .nes. "" then key = code_input
$	return
--------------------------------------------------------------------------------
$ input_data :
$	if data .eqs. "" then data = data_in
$	data_input = ""
$	index_field = 0
$  input_data_loop :
$	name_field = f$element ( index_field , delimeter_field , data_field ) -
		- delimeter_field
$	if name_field .eqs. "" then goto input_data_end
$	text_field = f$element ( index_field , delimeter_field , data ) -
		- delimeter_field
$	code_input = text_field
$  input_data_ask :
$	if list_cmd .eqs. "" then ask -
		"''mode' ""''key'"" ''name_field' [''text_field']: "
$	code_input := 'code_input'
$	if code_input .eqs. "?"
$	then	say "Press return to get the default shown in brackets."
$		if text_field .nes. "" then say -
			"Enter " , code_field_clear , " to enter a null value."
$		if text_field .eqs. "?" then text_field = ""
$		goto input_data_ask
$	endif
$	if code_input .nes. "" then text_field = code_input
$	if code_input .eqs. code_field_clear then text_field = ""
$	data_input = data_input + delimeter_field + text_field
$	index_field = index_field + 1
$	goto input_data_loop
$  input_data_end :
$	data = data_input - delimeter_field
$	return
--------------------------------------------------------------------------------
$ cmd_get :
$	cmds = "?"
$	if mode .nes. "DISPLAY"
$	then	cmds = cmds + ",CANCEL"
$		if cmd .nes. "DELETE" then cmds = cmds + ",REPEAT"
$		goto cmd_ask
$	endif
$	cmds = cmds + ",EXIT"
$	if key .eqs. "" then goto cmd_ask
$	cmds = cmds + ",CLEAR"
$	if DB_data .eqs. ""
$	then	cmds = cmds + ",ADD"
$	else	cmds = cmds + ",UPDATE,DELETE"
$	endif
$  cmd_ask :
$	if list_cmd .eqs. ""
$	then	ask "''mode' Command (''cmds') [''mode']: "
$		list_cmd := 'code_input'
$	else	inform "''mode' Command (''cmds') [''mode']: " , list_cmd
$	endif
$	cmd = f$element ( 0 , "," , list_cmd )
$	list_cmd = list_cmd - cmd - ","
$	if cmd .eqs. "" then cmd = mode
$	if cmd .eqs. mode then return
$	if cmd .eqs. "?" then goto cmd_help
$	i = f$locate ( "," + cmd , "," + cmds )
$	l = f$length ( cmds )
$	if i .ge. l
$	then	say mode , " Invalid command """ , cmd , """."
$		goto cmd_ask
$	endif
$	cmd = f$element ( 0 , "," , f$extract ( i , l , cmds ) )
$	return
$  cmd_help :
$	type SYS$INPUT

Command HELP...

Enter a unique prefix for any of the commands shown in parentheses.
The default command is shown in brackets. To choose it, either enter a null
command (just press return), or enter the FULL name of the command.

$	goto cmd_ask
--------------------------------------------------------------------------------
$ DB_error :
$	say f$message ( $status )
$	key = DB_key_save
$ DB_abort :
$	data = ""
$	DB_match = "GE"
$	return
$ DB_open :
$	DB = f$element ( 0 , "|" , data_DB )
$	if DB .eqs. "" then DB = me
$	DB = f$parse ( DB , f$trnlnm ( DB + "_DB" ) , ".DAT" )
$	if f$search ( DB ) .eqs. ""
$	then	inform "No DB """ , DB , """."
$		if DB .eqs. "" then exit
$		gosub DB_create
$		goto DB_open
$	endif
$	gosub DB_close
$	open /share = WRITE /write /read /error = DB_error DB_file 'DB'
$	return
$ DB_get :
$	if f$type ( DB_key ) .eqs. "" .or. DB_match .eqs. "GE"
$	then	DB_key = key
$		DB_key_save = DB_key
$		DB_data = ""
$		DB_N = 0
$	else	key = DB_key
$	endif
$	if DB_match .eqs. "GE" .and. key .eqs. "" then gosub DB_open
$	if f$trnlnm ( "DB_file" ) .eqs. "" then gosub DB_open
$	DB_access = "/key = ""''key'"""
$	if key .eqs. "" then DB_access = ""
$	read /error = DB_error /end = DB_end /match = 'DB_match' -
		'DB_access' DB_file data 
$	DB_key = f$extract ( 0 , DB_key_length , data )
$	data = data - DB_key
$	DB_key = f$edit ( DB_key , "TRIM" )
$	if f$locate ( DB_key_save , DB_key ) .ne. 0
$	then	key = DB_key_save
$		if DB_match .eqs. "GE"
$		then	inform "Record not found."
$			goto DB_abort
$		endif
$	endif
$	DB_N = DB_N + 1
$	if DB_key_save .eqs. DB_key
$	then	DB_data = data
$	else	DB_match = "GT"
$	endif
$	return
$ DB_end :
$	say f$message ( $status )
$	gosub DB_open
$	goto DB_abort
$ DB_delete :
$	read /delete /error = DB_error /key = "''key'" DB_file data
$	return
$ DB_write :
$	DB_write = ""
$	if mode .eqs. "UPDATE" then DB_write = "/" + mode
$	DB_key = f$extract ( 0 , DB_key_length , key + f$fao ( "!''DB_key_length'* " ) )
$	write 'DB_write' DB_file DB_key , data
$	return
$ DB_close :
$	if f$trnlnm ( "DB_file" ) .nes. "" then close DB_file
$	return
$ DB_create :
$	if name_fdl .eqs. "" then name_fdl = name_file_temp
$	if f$search ( name_fdl ) .nes. "" then goto DB_create_DB
$	copy SYS$INPUT 'name_fdl'
TITLE	"GENERIC DATABASE"

IDENT	"28-FEB-1992 14:40:04   VAX-11 FDL Editor"

SYSTEM
	SOURCE			"VAX/VMS"

FILE
	ORGANIZATION		indexed

RECORD
	CARRIAGE_CONTROL	carriage_return
	FORMAT			variable
	SIZE			80

AREA 0
	ALLOCATION		9
	BEST_TRY_CONTIGUOUS	yes
	BUCKET_SIZE		3
	EXTENSION		3

AREA 1
	ALLOCATION		9
	BEST_TRY_CONTIGUOUS	yes
	BUCKET_SIZE		3
	EXTENSION		3

KEY 0
	CHANGES			no
	DATA_AREA		0
	DATA_FILL		100
	DATA_KEY_COMPRESSION	no
	DATA_RECORD_COMPRESSION	no
	DUPLICATES		no
	INDEX_AREA		1
	INDEX_COMPRESSION	no
	INDEX_FILL		100
	LEVEL1_INDEX_AREA	1
	NAME			"KEY"
	PROLOG			3
	SEG0_POSITION		0
	TYPE			string
$	open /append file_fdl 'name_fdl'
$	write file_fdl "	SEG0_LENGTH		" , DB_key_length
$	close file_fdl
$ DB_create_DB :
$	create /FDL = 'name_fdl' 'DB'
$	if $status .and. name_fdl .eqs. name_file_temp then -
		delete 'name_fdl';*
$	if f$search ( DB ) .eqs. "" then goto EXIT
$	directory /NOhead /NOtrail /size = ALL /width = file = 50 'DB'
$	inform "... new database created."
$	return

--
Daiajo Tibdixious	wetibd%devax1.dnet@itwol.bhp.com.au
Australia  BHP IT Wol  Facilities Management  DEC System Support
Dawn - Bright light comming over the horizon.

