* xBase Data file export utility.
* dumpdbf.prg - Andrew Bedno - 1993.10.11

* Replace occurrences of ??? with appropriate specifics.

* **************************  MAIN  **************************

* Initialize
CLEAR ALL
SET PROCEDURE TO dumpdbf
PUBLIC cfg_dbf, cfg_txt
PUBLIC firstfld, firstrec, err_msg, dflt_dbf
PUBLIC reccnt, recttl
SET TALK OFF
ON ESCAPE DO esc_trap 
ON ERROR DO err_trap 
SET SCOREBOARD OFF
SET STATUS OFF
SET EXCLUSIVE OFF
SET DELETED OFF
@ 0, 0 CLEAR
@ 0, 0 SAY 'DUMPDBF: Version 1.00 1993.10.11 AIB'

* Set a default dump database here.
STORE '???' TO cfg_dbf
STORE cfg_dbf + '.ASC' TO cfg_txt

* Process the file.
@ 1, 0 CLEAR
@ 1, 0 SAY 'Dumping .' + cfg_dbf + '.DBF'
@ 2, 0 SAY '     to .' + cfg_txt
@ 3, 0 SAY '(Press <ESCAPE> to interrupt.)'
@ 4, 0 SAY ''
DO cont_msg
@ 5, 0 SAY ''
DO dbf_open
DO txt_open
DO out_file
DO dbf_close
STORE 'closing dump file' TO err_msg
DO txt_close
DO end_prog

RETURN

* **************************  UTILITIES  **************************


* End program.
PROCEDURE end_prog
  DO cont_msg
  QUIT
RETURN


* Handle errors.
PROCEDURE err_trap
  DO txt_close
  @ 14, 0 SAY 'Error ' + err_msg + '.'
  @ 15, 0 SAY 'Program terminated!'
  @ 16, 0 SAY ''
  DO end_prog  
RETURN


* Handle <ESC>
PROCEDURE esc_trap
  STORE '- User interrupt' TO err_msg
  DO err_trap
RETURN


* Wait for user keypress.
PROCEDURE cont_msg
  @ 22, 0 CLEAR
  @ 22, 0 SAY 'Press any key to continue . . .'
  WAIT ''
  @ 22, 0 CLEAR
RETURN


* Close all files.
PROCEDURE dbf_close
  STORE 'closing database' TO err_msg
  SET EXCLUSIVE OFF
  CLOSE ALL
RETURN


* Open the database.
PROCEDURE dbf_open
  PRIVATE d_o_name
  STORE 'opening database' TO err_msg
  STORE cfg_dbf TO d_o_name
  USE &d_o_name ALIAS SOURCE
  GOTO TOP
  RELEASE d_o_name
  STORE 'Y' TO firstrec
RETURN


* Close the text output file.
PROCEDURE txt_close
  SET ALTERNATE OFF
  CLOSE ALTERNATE
  SET ALTERNATE TO
  * SET CONSOLE ON
RETURN


* Open the text output file.
PROCEDURE txt_open
  STORE 'opening dump file' TO err_msg
  IF FILE(cfg_txt)
    DELETE FILE &cfg_txt
  ENDIF
  SET ALTERNATE TO &cfg_txt
  SET ALTERNATE ON
  SET CONSOLE OFF
RETURN


* Output a delimiter if needed.
PROCEDURE out_dlm
  IF firstfld = 'Y'
    IF firstrec = 'N'
      ? ''
    ENDIF
  ELSE    
    ?? '|'
  ENDIF
  STORE 'N' TO firstfld
  STORE 'N' TO firstrec
RETURN


* Output a left justified string in a space padded field.
PROCEDURE out_str
  PARAMETERS os_in, os_size
  PRIVATE os_trim, os_out
  DO out_dlm
  STORE RTRIM(TRIM( os_in )) TO os_trim
  IF LEN( os_trim ) > os_size
    STORE SUBSTR( os_trim, 1, os_size ) TO os_trim
  ENDIF
  STORE os_trim + SPACE( os_size - LEN( os_trim ) ) TO os_out
  ?? os_out
  RELEASE os_trim, os_out
RETURN


* Output a right justified number in a zero padded field.
PROCEDURE out_num
  PARAMETERS on_in, on_size, on_dec
  PRIVATE on_str, on_trim, on_out, on_sgn
  DO out_dlm
  IF on_dec > 0
    STORE on_size + 1 TO on_size
  ENDIF
  STORE '+' TO on_sgn
  IF on_in < 0
    STORE '-' TO on_sgn
    STORE 0 - on_in TO on_in
  ENDIF
  STORE STR( on_in, on_size, on_dec ) TO on_str
  STORE RTRIM(TRIM( on_str )) TO on_trim
  STORE on_sgn + REPLICATE( '0', on_size - LEN( on_trim ) ) + on_trim TO on_out
  ?? on_out
  RELEASE on_str, on_trim, on_out, on_sgn
RETURN


* Output a date in YYYYMMDD format
PROCEDURE out_date
  PARAMETERS od_in
  PRIVATE od_out
  DO out_dlm
  STORE TRIM(RTRIM(STR(YEAR(od_in)))) + ;
        TRIM(RTRIM(STR(MONTH(od_in)))) + ;
        TRIM(RTRIM(STR(DAY(od_in)))) TO od_out
  ?? od_out
  RELEASE od_out
RETURN


* Output a whole record.
PROCEDURE out_rec
  * Put one line here for each field in the database.
  * Use out_str, out_num or out_date, depending on the field type.
  * Sample: output string ??? in a ??? wide field.
  DO out_str WITH SOURCE->???, ???
  * Sample: output number ??? in a ??? wide field with ??? decimal places.
  DO out_num WITH SOURCE->???, ???, ???
  * Sample: output date ??? in an eight character wide field.
  DO out_date WITH SOURCE->???
RETURN


* Process the export.
PROCEDURE out_file
  STORE 'processing export' TO err_msg
  @ 9, 0 SAY 'Exporting . . .'
  STORE 0 TO reccnt
  STORE RECCOUNT() TO recttl
  DO WHILE (.NOT. EOF())
    STORE reccnt + 1 TO reccnt
    @10, 0 SAY 'Record ' + STR(reccnt) + ' of ' + STR(recttl)
    @11, 0 SAY ''
    STORE 'Y' TO firstfld
    DO out_rec
    SKIP 1
  ENDDO
  @ 20, 0 CLEAR
  @ 20, 0 SAY 'Done!'
RETURN