home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a009 / 6.ddi / RL.LIF / RLBACK.PRG < prev    next >
Encoding:
Text File  |  1991-04-14  |  41.0 KB  |  1,514 lines
  1. ***
  2. *  Function   :  LBL_LOAD()
  3. *  Author     :  Kevin Shepherd
  4. *  Date       :  05/19/87
  5. *  Notice     :  Copyright 1987 Nantucket Corporation
  6. *  Purpose    :  Reads a label <.LBL> file into the label system
  7. *             :  <.MEM> and <.DBF> files.
  8. *
  9. *  Convention :
  10. *
  11. *     status = LBL_LOAD(lbl_file, dbf_file, mem_file)
  12. *
  13. *  Parameters :
  14. *
  15. *     lbl_file -  string, label file to load.
  16. *     dbf_file -  string, data file for contents description.
  17. *     mem_file -  string, memory file for specs.
  18. *
  19. *  Return     :
  20. *
  21. *     status   -  logical, sucess of load operation.
  22. *
  23. *  Externals  :
  24. *
  25. *     FOPEN(), FCLOSE() FREAD(), FERROR(), CREATE_DBF(), WORD_2_NUM()
  26. *
  27. *  Notes      :   Label file passed with extension.     
  28. *             :   <.LBL> not found, init <.DBF> and <.MEM> with defaults.
  29. *             :   File error number placed in file_error.
  30. *
  31.  
  32. FUNCTION LBL_LOAD
  33.  
  34. PARAMETERS label_file, dbf_file, mem_file
  35.  
  36. PRIVATE i, buff_size, buff, handle, read_count, status, offset,;
  37.    lbl_remark, lbl_height, lbl_width, lbl_margin, lbl_lines, lbl_spaces,;
  38.    lbl_across
  39.  
  40. buff_size = 1034              && size of label file.
  41. buff      = SPACE(buff_size)          
  42.  
  43. i          = 0
  44. handle     = 0
  45. read_count = 0                    && read/write and content record counter.
  46. status     = .F.
  47. offset     = 74                   && start of label content descriptions.
  48.  
  49. DECLARE ffield[1]
  50. DECLARE ftype[1]
  51. DECLARE flength[1]
  52. DECLARE fdecimal[1]
  53.  
  54. ffield[1]   = "CONTENTS"
  55. ftype[1]    = "C"
  56. flength[1]  = 60
  57. fdecimal[1] = 0
  58.  
  59. ** Create label line transfer <.DBF>. **
  60. IF CREATE_DBF(dbf_file, 1, ffield, ftype, flength, fdecimal)
  61.  
  62.    ** Open the label file **
  63.    handle = FOPEN(label_file)
  64.  
  65.    ** File does not exist **
  66.    file_error = FERROR()
  67.    IF file_error = 2
  68.  
  69.       ** Initialize default values **
  70.       lbl_remark = SPACE(60)
  71.       lbl_height = 5
  72.          lbl_width  = 35
  73.          lbl_margin = 0
  74.          lbl_lines  = 1
  75.          lbl_spaces = 0
  76.          lbl_across = 1
  77.  
  78.       SAVE ALL LIKE lbl_* TO &mem_file
  79.  
  80.       ** Append default number blank lines to file  **
  81.       USE &dbf_file
  82.       FOR count = 0 to (lbl_height - 1)
  83.          APPEND BLANK
  84.          REPLACE contents WITH SPACE(60)
  85.       NEXT
  86.       CLOSE DATABASES
  87.  
  88.       status = .T.
  89.  
  90.    ELSE
  91.  
  92.       ** OPEN ok? **
  93.       IF file_error = 0
  94.  
  95.          ** Read label file **
  96.          read_count = FREAD(handle, @buff, buff_size)         
  97.  
  98.          ** READ ok? **
  99.          IF read_count = 0
  100.             file_error = -3         && file is empty.
  101.          ELSE
  102.             file_error = FERROR()   && check for DOS errors
  103.          ENDIF
  104.  
  105.          IF file_error = 0
  106.  
  107.             ** Load label dimension to mem file **
  108.             lbl_remark = SUBSTR(buff, 2, 60)
  109.             lbl_height = WORD_2_NUM(SUBSTR(buff, 62, 2))
  110.             lbl_width  = WORD_2_NUM(SUBSTR(buff, 64, 2))
  111.             lbl_margin = WORD_2_NUM(SUBSTR(buff, 66, 2))
  112.             lbl_lines  = WORD_2_NUM(SUBSTR(buff, 68, 2))
  113.             lbl_spaces = WORD_2_NUM(SUBSTR(buff, 70, 2))
  114.             lbl_across = WORD_2_NUM(SUBSTR(buff, 72, 2))
  115.  
  116.             SAVE ALL LIKE lbl_* TO &mem_file
  117.  
  118.             ** Load label line content expressions to file **
  119.             USE &dbf_file
  120.             FOR i = 0 to (lbl_height - 1)
  121.                APPEND BLANK
  122.                REPLACE contents WITH SUBSTR(buff, offset, 60) 
  123.                offset = offset + 60
  124.             NEXT
  125.             CLOSE DATABASES
  126.    
  127.             ** Close file **
  128.             FCLOSE(handle)
  129.             file_error = FERROR()
  130.          ENDIF
  131.       ENDIF   
  132.    
  133.       ** Label file loaded ok? **
  134.       status = (file_error = 0)
  135.  
  136.    ENDIF
  137. ENDIF
  138.  
  139. RETURN (status)
  140.  
  141. *
  142. ** eofunc LBL_LOAD
  143.  
  144.  
  145. ***
  146. *  Function   :  LBL_SAVE()
  147. *  Author     :  Kevin Shepherd
  148. *  Date       :  05/20/87
  149. *  Notice     :  Copyright 1987 Nantucket Corporation
  150. *  Purpose    :  Writes contents of the label system <.DBF> and
  151. *             :  <.MEM> files to a <.LBL> file.
  152. *
  153. *  Convention :
  154. *
  155. *     status = LBL_SAVE(lbl_file, dbf_file, mem_file)
  156. *
  157. *  Parameters :
  158. *
  159. *     lbl_file -  string, label file to load.
  160. *     dbf_file -  string, data file containing label line contents.
  161. *     mem_file -  string, memory file label dimension.
  162. *
  163. *  Return     :
  164. *
  165. *     status   -  logical, success of save operation.
  166. *     
  167. *  Externals  :
  168. *
  169. *     FCREATE(), FCLOSE(), FWRITE(), FERROR(), NUM_2_WORD()
  170. *
  171. *  Notes      :   Label file name passed with extension.     
  172. *             :   File error number placed in file_error.
  173. *
  174.  
  175. FUNCTION LBL_SAVE
  176.  
  177. PARAMETERS label_file, dbf_file, mem_file
  178.  
  179. PRIVATE label_image, label_size, content_size, handle, write_count,;
  180.    status, i, lbl_remark, lbl_height, lbl_width, lbl_margin, lbl_lines,;
  181.    lbl_spaces, lbl_across
  182.  
  183. label_size   = 1034        && size of label file.
  184. label_image  = ""          && holds modified label for write operation.
  185. content_size = 960         && content area of file holds 16 60-byte records.
  186.  
  187. write_count = 0            && bytes written.
  188. handle      = 0
  189. i           = 0            && record counter.
  190. status      = .F.
  191.  
  192. ** Create the label file **
  193. handle = FCREATE(label_file)
  194.  
  195. ** Open ok? **
  196. file_error = FERROR()
  197. status = (file_error = 0)
  198.  
  199. IF status
  200.    ** Restore label dimension values **
  201.    RESTORE ADDITIVE FROM &mem_file
  202.    
  203.    ** Build new file image. **
  204.    label_image = CHR(2) + lbl_remark + CHR(lbl_height) + CHR(0);
  205.                + CHR(lbl_width) + CHR(0) + CHR(lbl_margin);
  206.                + CHR(0) + CHR(lbl_lines) + CHR(0) + CHR(lbl_spaces);
  207.                + CHR(0) + CHR(lbl_across) + CHR(0)
  208.  
  209.    ** Add contents fields to label file image **
  210.    USE &dbf_file
  211.    FOR i = 0 to (lbl_height - 1)
  212.       label_image = label_image + contents
  213.       SKIP
  214.    NEXT
  215.    CLOSE DATABASES
  216.    
  217.    ** Pad if needed **
  218.    IF i < 16
  219.       label_image = label_image + SPACE(content_size - (60 * i))
  220.    ENDIF
  221.  
  222.    ** Label file signature, 1034th byte **
  223.    label_image = label_image + CHR(2)
  224.  
  225.    ** Write new image to label file **
  226.    write_count = FWRITE(handle, label_image, label_size)
  227.  
  228.    ** WRITE error? **
  229.    IF write_count = 0
  230.       file_error = -2
  231.    ELSE
  232.       file_error = FERROR()
  233.    ENDIF
  234.  
  235.    ** Close file **
  236.    IF !FCLOSE(handle)
  237.       file_error = FERROR()         && write error detect may be covered up
  238.    ENDIF                            &&    if done differently.
  239.  
  240.    status = (file_error = 0)
  241.  
  242. ENDIF
  243.  
  244. RETURN (status)
  245.  
  246. *
  247. ** eofunc LBL_SAVE
  248.  
  249.  
  250. ***
  251. *  Function   :  FRM_LOAD()
  252. *  Author     :  Kevin Shepherd
  253. *  Date       :  05/22/87
  254. *  Notice     :  Copyright 1987 Nantucket Corporation
  255. *  Purpose    :  Reads a report <.FRM> file into the report system
  256. *             :  <.MEM> and <.DBF> files.
  257. *
  258. *  Convention :
  259. *
  260. *     status = FRM_LOAD(report_file, dbf_file, mem_file)
  261. *
  262. *  Parameters :
  263. *
  264. *     report_file  -  string, report file to load.
  265. *     dbf_file     -  string, data file for column expressions.
  266. *     mem_file     -  string, memory file for report dimension.
  267. *
  268. *  Return     :
  269. *
  270. *     status   -  logical, success of load operation.
  271. *
  272. *  Externals  :
  273. *
  274. *     GET_EXPR(), GET_FIELD(), CREATE_DBF(), FOPEN(), FCLOSE(),
  275. *     FSEEK(), FREAD(), FERROR(), WORD_2_NUM()
  276. *
  277. *  Notes      :   Report file name has extension.     
  278. *             :   File error number placed in file_error.
  279. *             :   WARNING!!!!!!->   Offsets start at 1.
  280. *             :      Offsets are into a CLIPPER STRING, 1 to 1990
  281. *             :
  282. *             :   WARNING!!!!!!->   The offsets mentioned in these notes
  283. *             :      are actual DOS FILE offsets. NOT like the offsets
  284. *             :      declared in the body of FRM_LOAD() which are CLIPPER
  285. *             :      STRING offsets.
  286. *             :
  287. *             :   Report file length is 7C6h (1990d) bytes.
  288. *             :   Expression length array starts at 04h (4d) and can
  289. *             :      contain upto 55 short (2 byte) numbers.
  290. *             :   Expression offset index array starts at 72h (114d) and
  291. *             :      can contain upto 55 short (2 byte) numbers.
  292. *             :   Expression area starts at offset E0h (224d).
  293. *             :   Expression area length is 5A0h (1440d).
  294. *             :   Expressions in expression area are null terminated.
  295. *             :   Field expression area starts at offset 680h (1664d).
  296. *             :   Field expressions (column definition) are null terminated. 
  297. *             :   Field expression area can contain upto 25 12-byte blocks.
  298. *
  299.  
  300. FUNCTION FRM_LOAD
  301.  
  302. PARAMETERS report_file, dbf_file, mem_file
  303.  
  304. ** Shared by FRM_LOAD() and its ancillary functions **
  305. PRIVATE lengths_buff, offsets_buff, expr_buff, fields_buff,;
  306.    field_width_offset, field_totals_offset, field_decimals_offset,;
  307.    field_content_expr_offset, field_header_expr_offset
  308.  
  309. PRIVATE i,  handle, read_count, status, pointer, fcount, fld_offset,;
  310.    file_buff, params_buff, size_file_buff, size_lengths_buff,;
  311.    size_offsets_buff, size_expr_buff, size_fields_buff, size_params_buff,;
  312.    expr_offset, offsets_offset, lengths_offset, fields_offset,;
  313.    page_hdr_offset, grp_expr_offset, sub_expr_offset, grp_hdr_offset,;
  314.    sub_hdr_offset, page_width_offset, lns_per_page_offset, left_mrgn_offset,;
  315.    right_mgrn_offset, col_count_offset, dbl_space_offset,;
  316.    summary_rpt_offset, pe_offset, plnpg_peap_pebp_offset, plus_byte,;
  317.    frm_pagehdr, frm_grpexpr, frm_subexpr, frm_grphdr, frm_subhdr,;
  318.    frm_pagewidth, frm_linespage, frm_leftmarg, frm_rightmarg,;
  319.    frm_colcount, frm_dblspaced, frm_summary, frm_pe, frm_pebp, frm_peap,;
  320.    frm_plainpage
  321.  
  322. i          = 0
  323. handle     = 0
  324. read_count = 0              && read/write and content record counter.
  325. pointer    = 0             && points to an offset into EXPR_BUFF string.
  326. status     = .F.
  327.  
  328. size_file_buff = 1990           && size of report file.
  329. file_buff = SPACE(size_file_buff)
  330.  
  331. size_lengths_buff = 110
  332. size_offsets_buff = 110
  333. size_expr_buff    = 1440
  334. size_fields_buff  = 300
  335. size_params_buff  = 24
  336.  
  337. lengths_buff = ""
  338. offsets_buff = ""
  339. expr_buff    = ""
  340. fields_buff  = ""
  341. params_buff  = ""
  342.  
  343. ** There are offsets into the FILE_BUFF string **
  344. lengths_offset = 5      && start of expression length array.
  345. offsets_offset = 115    && start of expression position array.
  346. expr_offset    = 225    && start of expression data area.
  347. fields_offset  = 1665   && start of report columns (fields).
  348. params_offset  = 1965   && start of report parameters block.
  349.  
  350. ** These are offsets into the FIELDS_BUFF string to actual values **
  351. ** Values are added to a block offset FLD_OFFSET that is moved in **
  352. **    increments of 12 **
  353. fld_offset            = 0
  354. field_width_offset    = 1 
  355. field_totals_offset   = 6
  356. field_decimals_offset = 7   
  357.  
  358. ** These are offsets into FIELDS_BUFF which are used to 'point' into **
  359. **    the EXPR_BUFF string which contains the textual data **
  360. field_content_expr_offset = 9
  361. field_header_expr_offset  = 11
  362.  
  363. ** These are actual offsets into the PARAMS_BUFF string which **
  364. **    are used to 'point' into the EXPR_BUFF string **
  365. page_hdr_offset = 1
  366. grp_expr_offset = 3
  367. sub_expr_offset = 5
  368. grp_hdr_offset  = 7
  369. sub_hdr_offset  = 9
  370.  
  371. ** These are actual offsets into the PARAMS_BUFF string to actual values **
  372. page_width_offset      = 11
  373. lns_per_page_offset    = 13
  374. left_mrgn_offset       = 15
  375. right_mgrn_offset      = 17
  376. col_count_offset       = 19
  377. dbl_space_offset       = 21
  378. summary_rpt_offset     = 22
  379. pe_offset              = 23
  380. plnpg_peap_pebp_offset = 24
  381.  
  382.  
  383. ** Default report values **
  384. frm_pagehdr   = SPACE(240)
  385. frm_grpexpr   = SPACE(200)
  386. frm_subexpr   = SPACE(200)
  387. frm_grphdr    = SPACE(50)
  388. frm_subhdr    = SPACE(50)
  389. frm_pagewidth = 80
  390. frm_linespage = 58
  391. frm_leftmarg  = 8
  392. frm_rightmarg = 0
  393. frm_colcount  = 0
  394. frm_dblspaced = "N"
  395. frm_summary   = "N"
  396. frm_pe        = "N"
  397. frm_pebp      = "Y"
  398. frm_peap      = "N"
  399. frm_plainpage = "N"
  400.  
  401.  
  402. ** Initialize transfer dbf creation arrays **
  403. fcount = 5
  404. DECLARE ffield[fcount]
  405. DECLARE ftype[fcount]
  406. DECLARE flength[fcount]
  407. DECLARE fdecimal[fcount]
  408.  
  409. ffield[1]   = "WIDTH"
  410. ftype[1]    = "N"
  411. flength[1]  = 2
  412. fdecimal[1] = 0
  413.  
  414. ffield[2]   = "TOTALS"
  415. ftype[2]    = "C"
  416. flength[2]  = 1
  417. fdecimal[2] = 0
  418.  
  419. ffield[3]   = "DECIMALS"
  420. ftype[3]    = "N"
  421. flength[3]  = 2
  422. fdecimal[3] = 0
  423.  
  424. ffield[4]   = "CONTENTS"
  425. ftype[4]    = "C"
  426. flength[4]  = 254
  427. fdecimal[4] = 0
  428.  
  429. ffield[5]   = "HEADER"
  430. ftype[5]    = "C"
  431. flength[5]  = 260
  432. fdecimal[5] = 0
  433.  
  434. ** CREATE the Report FIELDS reocrd transfer file. **
  435. IF CREATE_DBF(dbf_file, fcount, ffield, ftype, flength, fdecimal)
  436.  
  437.    ** Open the report file **
  438.    handle = FOPEN(report_file)
  439.  
  440.    ** File does not exist **
  441.    file_error = FERROR()
  442.    IF file_error = 2
  443.  
  444.       ** Save default report variables as initialize above **
  445.       SAVE ALL LIKE frm_* TO &mem_file
  446.  
  447.       ** Load at least one FIELDS (column) record **
  448.       USE &dbf_file
  449.       APPEND BLANK
  450.   
  451.       REPLACE width WITH 10
  452.       REPLACE totals WITH "N"
  453.       REPLACE decimals WITH 0
  454.       REPLACE contents WITH SPACE(254)
  455.       REPLACE header WITH SPACE(260)
  456.  
  457.       CLOSE DATABASES
  458.  
  459.       status = .T.
  460.  
  461.    ENDIF
  462.  
  463.    ** OPEN ok? **
  464.    IF file_error = 0
  465.  
  466.       ** Go to START of report file **
  467.       FSEEK(handle, 0)
  468.  
  469.       ** SEEK ok? **
  470.       file_error = FERROR()
  471.       IF file_error = 0
  472.  
  473.          ** Read entire file into process buffer **
  474.          read_count = FREAD(handle, @file_buff, size_file_buff)
  475.  
  476.          ** READ ok? **
  477.          IF read_count = 0
  478.             file_error = -3         && file is empty.
  479.          ELSE
  480.             file_error = FERROR()   && check for DOS errors
  481.          ENDIF
  482.  
  483.          IF file_error = 0
  484.  
  485.             ** Is this a .FRM type file (2 at start and end of file) **
  486.             IF WORD_2_NUM(SUBSTR(file_buff, 1, 2)) = 2 .AND.;
  487.                WORD_2_NUM(SUBSTR(file_buff, size_file_buff - 1, 2)) = 2
  488.  
  489.                file_error = 0
  490.             ELSE
  491.                file_error = -1
  492.             ENDIF
  493.          ENDIF
  494.       ENDIF
  495.  
  496.       ** Close file **
  497.       IF !FCLOSE(handle)
  498.          file_error = FERROR()
  499.       ENDIF
  500.    ENDIF
  501.  
  502.    ** File existed, was opened and read ok and is a .FRM file **
  503.    IF file_error = 0
  504.  
  505.       ** Fill processing buffers **
  506.       lengths_buff = SUBSTR(file_buff, lengths_offset, size_lengths_buff)
  507.       offsets_buff = SUBSTR(file_buff, offsets_offset, size_offsets_buff)
  508.       expr_buff    = SUBSTR(file_buff, expr_offset, size_expr_buff)
  509.       fields_buff  = SUBSTR(file_buff, fields_offset, size_fields_buff)
  510.       params_buff  = SUBSTR(file_buff, params_offset, size_params_buff)
  511.  
  512.       ** Extract Numerics **
  513.       frm_pagewidth = WORD_2_NUM(SUBSTR(params_buff,page_width_offset,2))
  514.       frm_linespage = WORD_2_NUM(SUBSTR(params_buff,lns_per_page_offset,2))
  515.       frm_leftmarg  = WORD_2_NUM(SUBSTR(params_buff,left_mrgn_offset,2))
  516.       frm_rightmarg = WORD_2_NUM(SUBSTR(params_buff,right_mgrn_offset,2))
  517.       frm_colcount  = WORD_2_NUM(SUBSTR(params_buff,col_count_offset,2))
  518.  
  519.       ** Extract characters **
  520.       frm_dblspaced = SUBSTR(params_buff, dbl_space_offset, 1)
  521.       frm_summary   = SUBSTR(params_buff, summary_rpt_offset, 1)
  522.       frm_pe        = SUBSTR(params_buff, pe_offset, 1)
  523.    
  524.       ** Process packed 'plus byte' **
  525.       plus_byte = ASC(SUBSTR(params_buff, plnpg_peap_pebp_offset, 1))
  526.       IF plus_byte / 4 = 1
  527.          frm_plainpage = "Y"
  528.          plus_byte = plus_byte - 4
  529.       ENDIF
  530.       IF plus_byte / 2 = 1
  531.          frm_peap = "Y"
  532.          plus_byte = plus_byte - 2
  533.       ENDIF
  534.       IF plus_byte / 1 = 1
  535.          frm_pebp = "N"
  536.          plus_byte = plus_byte - 1
  537.       ENDIF
  538.  
  539.       ** Extract expression (strings) pointed to by pointers **
  540.  
  541.       ** Page Heading, Report Title **
  542.       pointer = WORD_2_NUM(SUBSTR(params_buff, page_hdr_offset, 2))
  543.       frm_pagehdr = GET_EXPR(pointer)
  544.  
  545.       ** Grouping expression **
  546.       pointer = WORD_2_NUM(SUBSTR(params_buff, grp_expr_offset, 2))
  547.       frm_grpexpr = GET_EXPR(pointer)
  548.  
  549.       ** Sub-grouping expression **
  550.       pointer = WORD_2_NUM(SUBSTR(params_buff, sub_expr_offset, 2))
  551.       frm_subexpr = GET_EXPR(pointer)
  552.  
  553.       ** Group header **
  554.       pointer = WORD_2_NUM(SUBSTR(params_buff, grp_hdr_offset, 2))
  555.       frm_grphdr = GET_EXPR(pointer)
  556.  
  557.       ** Sub-group header **
  558.       pointer = WORD_2_NUM(SUBSTR(params_buff, sub_hdr_offset, 2))
  559.       frm_subhdr = GET_EXPR(pointer)
  560.  
  561.       SAVE ALL LIKE frm_* TO &mem_file
  562.  
  563.       ** EXTRACT FIELDS (columns) **
  564.  
  565.       fld_offset = 12      && dBASE skips first 12 byte fields block.
  566.       USE &dbf_file
  567.       FOR i = 1 to frm_colcount
  568.  
  569.          ** APPEND and REPLACEs happen in GET_FIELD() **
  570.          fld_offset = GET_FIELD(fld_offset)
  571.  
  572.       NEXT
  573.       CLOSE DATABASES
  574.  
  575.       ** If we have gotten this far assume that the file is ok **
  576.       status = (file_error = 0)
  577.  
  578.    ENDIF   
  579. ENDIF
  580.  
  581. RETURN (status)
  582.  
  583. *
  584. ** eofunc FRM_LOAD
  585.  
  586.  
  587. ***
  588. *  Function   :  GET_EXPR()
  589. *  Author     :  Kevin Shepherd
  590. *  Date       :  06/01/87
  591. *  Notice     :  Copyright 1987 Nantucket Corporation
  592. *  Purpose    :  Reads an expression from EXPR_BUFF via the OFFSETS_BUFF.
  593. *
  594. *  Convention :
  595. *
  596. *     string = GET_EXPR(pointer)
  597. *
  598. *  Parameters :
  599. *
  600. *     pointer  -  numeric, 'pointer' to offset contained in OFFSETS_BUFF
  601. *                    string that inturn 'points' to an expression located
  602. *                    in the EXPR_BUFF string.
  603. *
  604. *  Return     :
  605. *
  606. *     string   -  string, retrieved expression, NULL ("") is empty.
  607. *     
  608. *  Externals  :
  609. *     
  610. *     WORD_2_NUM()
  611. *
  612. *  Notes      :   The expression is empty if......
  613. *             :      1. Passed pointer is equal to 65535.
  614. *             :      2. Character following character pointed to by
  615. *             :         pointer is CHR(0) (NULL).
  616. *             :   Called by the FRM_LOAD(), GET_FIELD()
  617. *             :   File error number placed in file_error.
  618. *
  619.  
  620. FUNCTION GET_EXPR
  621.  
  622. PARAMETERS pointer
  623.  
  624. PRIVATE expr_offset, expr_length, offset_offset, string
  625.  
  626. expr_offset   = 0
  627. expr_length   = 0
  628. offset_offset = 0
  629.  
  630. string = ""
  631.  
  632. ** Stuff for dBASE compatability. **
  633. IF pointer != 65535
  634.  
  635.    ** Convert DOS FILE offset to CLIPPER string offset **
  636.    pointer = pointer + 1
  637.  
  638.    ** Calculate offset into OFFSETS_BUFF **
  639.    IF pointer > 1
  640.       offset_offset = (pointer * 2) - 1
  641.    ENDIF
  642.  
  643.    expr_offset = WORD_2_NUM(substr(offsets_buff, offset_offset, 2))
  644.    expr_length = WORD_2_NUM(substr(lengths_buff, offset_offset, 2))
  645.  
  646.    ** EXPR_OFFSET points to a NULL, so add one (+1) to get the string **
  647.    ** and subtract one (-1) from EXPR_LENGTH for correct length **
  648.  
  649.    expr_offset = expr_offset + 1
  650.    expr_length = expr_length - 1   
  651.  
  652.    ** Extract string **
  653.    string = substr(expr_buff, expr_offset, expr_length)
  654.  
  655.    ** dBASE does this so we must do it too **
  656.    ** Character following character pointed to by pointer is NULL **
  657.    IF CHR(0) = SUBSTR(string, 1, 1) .AND. LEN(SUBSTR(string,1,1)) = 1
  658.       string = ""
  659.    ENDIF
  660. ENDIF
  661.  
  662. RETURN (string)
  663.  
  664. *
  665. *
  666. ** eofunc GET_EXPR()
  667.  
  668.  
  669. ***
  670. *  Function   :  GET_FIELD()
  671. *  Author     :  Kevin Shepherd
  672. *  Date       :  06/01/87
  673. *  Notice     :  Copyright 1987 Nantucket Corporation
  674. *  Purpose    :  Get a FIELDS element from FIELDS_BUFF string.
  675. *
  676. *  Convention :
  677. *
  678. *     offset = GET_FIELD(offset)
  679. *
  680. *  Parameters :
  681. *
  682. *     offset   -  numeric, current FIELDS_OFFSET block.
  683. *
  684. *  Return     :
  685. *
  686. *     offset   -  numeric, next FIELDS_OFFSET block.
  687. *     
  688. *  Externals  :
  689. *
  690. *     GET_EXPR(), WORD_2_NUM()
  691. *
  692. *  Notes      :   The Header or Contents expressions are empty if......
  693. *             :      1. Passed pointer is equal to 65535.
  694. *             :      2. Character following character pointed to by
  695. *             :         pointer is CHR(0) (NULL).
  696. *             :   Called by the FRM_LOAD()
  697. *             :   File error number placed in file_error.
  698. *
  699.  
  700. FUNCTION GET_FIELD
  701.  
  702. PARAMETERS offset
  703.  
  704. PRIVATE pointer, number
  705.  
  706. pointer = 0
  707. number  = 0
  708.  
  709. APPEND BLANK
  710.  
  711. ** Column width **
  712. number = WORD_2_NUM(SUBSTR(fields_buff, offset + field_width_offset, 2)) 
  713. REPLACE width WITH number
  714.  
  715.  
  716. ** Total **
  717. REPLACE totals WITH SUBSTR(fields_buff, offset + field_totals_offset, 1) 
  718.  
  719.  
  720. ** Decimals width **
  721. number = WORD_2_NUM(SUBSTR(fields_buff, offset +;
  722.             field_decimals_offset, 2)) 
  723. REPLACE decimals WITH number
  724.  
  725. ** Offset (relative to FIELDS_OFFSET), 'point' to **
  726. **    expression area via array OFFSETS[]. **
  727.  
  728.  
  729. ** Content expression **
  730. pointer = WORD_2_NUM(SUBSTR(fields_buff, offset +;
  731.                field_content_expr_offset, 2))
  732. REPLACE contents WITH GET_EXPR(pointer)
  733.   
  734.  
  735. ** Header expression **
  736. pointer = WORD_2_NUM(SUBSTR(fields_buff, offset +;
  737.                field_header_expr_offset, 2))
  738. REPLACE header WITH GET_EXPR(pointer)
  739.  
  740. RETURN (offset + 12)
  741.  
  742. *
  743. *
  744. ** eofunc GET_FIELD()
  745.  
  746.  
  747. ***
  748. *  Function   :  FRM_SAVE()
  749. *  Author     :  Kevin Shepherd
  750. *  Date       :  05/22/87
  751. *  Notice     :  Copyright 1987 Nantucket Corporation
  752. *  Purpose    :  Writes contents of the report system <.DBF> and
  753. *             :  <.MEM> files to a <.FRM> file.
  754. *
  755. *  Convention :
  756. *
  757. *     status = FRM_SAVE(frm_file, dbf_file, mem_file)
  758. *
  759. *  Parameters :
  760. *
  761. *     frm_file -  string, destination report form.
  762. *     dbf_file -  string, data file for column expressions.
  763. *     mem_file -  string, memory file for report dimension.
  764. *
  765. *  Return     :
  766. *
  767. *     status   -  logical, sucess of save operation.
  768. *     
  769. *  Externals  :
  770. *
  771. *     WRITE_EXPR(), WRITE_FIELD(), WRITE_PARAMS(), FCREATE(), FCLOSE(),
  772. *     FERROR(), FWRITE()
  773. *
  774. *  Notes      :   Report file name has extension.     
  775. *             :   File error number placed in file_error.
  776. *             :   WARNING!!!!!!->   Offsets start are from 0.
  777. *             :      Offsets are into a DOS FILE, 0 to 1989
  778. *             :
  779. *             :   WARNING!!!!!!->   The offsets mentioned in these notes
  780. *             :      are actual DOS FILE offsets.  These ARE NOT the same
  781. *             :      as those declared in FRM_LOAD().
  782. *             :
  783. *             :   WARNING!!!!!!->   An exception to this is the fields
  784. *             :      (columns) related offsets which are relative to the
  785. *             :      FIELDS_OFFSET offset.
  786. *             :
  787. *             :   Report file length is 7C6h (1990d) bytes.
  788. *             :   Expression length array starts at 04h (4d) and can
  789. *             :      contain upto 55 short (2 byte) numbers.
  790. *             :   Expression offset index array starts at 72h (114d) and
  791. *             :      can contain upto 55 short (2 byte) numbers.
  792. *             :   Expression area starts at offset E0h (224d).
  793. *             :   Expression area length is 5A0h (1440d).
  794. *             :   Expressions in expression area are null terminated.
  795. *             :   Expression lengths include the null terminator.
  796. *             :   Field expression area starts at offset 680h (1664d).
  797. *             :   Field expressions (column definition) are null terminated. 
  798. *             :   Field expression area can contain upto 25 12 byte elements
  799. *             :      describing a column layout.
  800. *
  801.  
  802. FUNCTION FRM_SAVE
  803.  
  804. PARAMETERS report_file, dbf_file, mem_file
  805.  
  806. ** Shared by FRM_SAVE() and its ancillary functions **
  807. PRIVATE handle, expr_offset, offsets_offset, lengths_offset, fields_offset,;
  808.    page_hdr_num, grp_expr_num, sub_expr_num, grp_hdr_num, sub_hdr_num,;
  809.    next_free_offset, last_expr, expr_count
  810.  
  811. PRIVATE report_size, report_image, status, expr_count, i, j, write_count,;
  812.    frm_pagehdr, frm_grpexpr, frm_subexpr, frm_grphdr, frm_subhdr,;
  813.    frm_pagewidth, frm_linespage, frm_leftmarg, frm_rightmarg,;
  814.    frm_colcount, frm_dblspaced, frm_summary, frm_pe, frm_pebp, frm_peap,;
  815.    frm_plainpage
  816.  
  817. report_size  = 1990              && size of report file.
  818. report_image = ""
  819.  
  820. i           = 0
  821. j           = 0
  822. handle      = 0
  823. write_count = 0                       && read/write and content record counter.
  824. status      = .F.
  825.  
  826. expr_num   = 0                   && expression record count.
  827. last_expr  = 0                   && end of last expression in area + 1.
  828. expr_count = -1                  && first expression at offset 0.
  829.  
  830. ** Offsets into the report file **
  831. next_free_offset = 2             && first un-USEd expr area offset. 
  832. lengths_offset   = 4             && start of expression length array.
  833. offsets_offset   = 114           && start of expression position array.
  834. expr_offset      = 224           && start of expression data area.
  835. fields_offset    = 1664          && start of report columns (fields).
  836. end_offset       = 1964          && start of last 24 bytes to write.
  837.  
  838. ** Offsets array index numbers to these expressions **
  839. page_hdr_num = 0
  840. grp_expr_num = 0
  841. sub_expr_num = 0
  842. grp_hdr_num  = 0
  843. sub_hdr_num  = 0
  844.  
  845. ** Create the label file **
  846. handle = FCREATE(report_file)
  847.  
  848. ** Open ok? **
  849. file_error = FERROR()
  850. IF file_error = 0
  851.    ** Restore report dimension values **
  852.    RESTORE ADDITIVE FROM &mem_file
  853.  
  854.    ** Write a NULL filled report 'skeleton' **
  855.    report_image = CHR(2) + CHR(0) + replicate(CHR(0), (1990 - 4)) +;
  856.                      CHR(2) + CHR(0)
  857.    write_count = FWRITE(handle, report_image, report_size)
  858.  
  859.    ** Skeleton WRITE ok? **
  860.    IF write_count = 0
  861.       file_error = -2
  862.    ELSE
  863.       file_error = FERROR()
  864.    ENDIF
  865.  
  866.    IF file_error = 0
  867.  
  868.       ** Write Page Heading info **
  869.       page_hdr_num = WRITE_EXPR(frm_pagehdr, .T.)
  870.  
  871.       ** WRITE ok? **            
  872.       IF page_hdr_num != -1
  873.  
  874.          ** Write Grouping expression info **
  875.          grp_expr_num = WRITE_EXPR(frm_grpexpr, .T.)
  876.  
  877.          ** WRITE ok? **            
  878.          IF grp_expr_num != -1
  879.  
  880.             ** Write Sub-grouping expression info **
  881.             sub_expr_num = WRITE_EXPR(frm_subexpr, .T.)
  882.                                           
  883.             ** WRITE ok? **            
  884.             IF sub_expr_num != -1
  885.  
  886.                ** Write Group Heading info **
  887.                grp_hdr_num = WRITE_EXPR(frm_grphdr, .T.)
  888.  
  889.                ** WRITE ok? **            
  890.                IF grp_hdr_num != -1
  891.  
  892.                   ** Write Sub-group Heading info **
  893.                   sub_hdr_num = WRITE_EXPR(frm_subhdr, .F.)
  894.  
  895.                   ** WRITE ok? **            
  896.                   status = (sub_hdr_num != -1)
  897.  
  898.                ENDIF
  899.             ENDIF
  900.          ENDIF
  901.       ENDIF
  902.  
  903.       ** Headers, grouping and sub-group info writen ok? **
  904.       IF status
  905.  
  906.          ** Write FIELDS (columns) info **
  907.          USE &dbf_file
  908.          j = lastrec()
  909.          FOR i = 1 to j
  910.             ** Write contents of FIELDS record to report file.
  911.             status = WRITE_FIELD()
  912.  
  913.             ** Ok? **
  914.             IF status
  915.                SKIP                    && pass, go next.
  916.             ELSE               
  917.                i = j + 1               && error, break out.
  918.             ENDIF
  919.          NEXT
  920.          CLOSE DATABASES
  921.       ENDIF
  922.  
  923.       ** Column info written ok? **
  924.       IF status
  925.          ** Write last 24 bytes of report and update next_free_offset **
  926.          status = WRITE_PARAMS()
  927.       ENDIF   
  928.    ENDIF
  929.  
  930.    ** CLOSE ok? **
  931.    IF !FCLOSE(handle)
  932.       file_error = FERROR()
  933.       status = .F.
  934.    ENDIF
  935. ENDIF
  936.  
  937. RETURN (status)
  938.  
  939. *
  940. ** eofunc FRM_SAVE
  941.  
  942.  
  943. ***
  944. *  Function   :  WRITE_EXPR()
  945. *  Author     :  Kevin Shepherd
  946. *  Date       :  05/28/87
  947. *  Notice     :  Copyright 1987 Nantucket Corporation
  948. *  Purpose    :  Writes an expression to Report expression area.
  949. *
  950. *  Convention :
  951. *
  952. *     expr_num = WRITE_EXPR(string, blank)
  953. *
  954. *  Parameters :
  955. *
  956. *     string   -  string, thing to write to expression area.
  957. *     blank    -  logical, test for dBASE like blank expression handling
  958. *                    and return a 65535 if expression to write is blank.
  959. *
  960. *  Return     :
  961. *
  962. *     expr_num -  numeric, expression count (0 to 55 inclusive) or
  963. *                    65535 (if blank = .T. and EMPTY(string) = .T.) or
  964. *                    -1 (if WRITE/SEEK error).
  965. *     
  966. *  Externals  :
  967. *
  968. *     FWRITE(), FSEEK(), FERROR(), NUM_2_WORD()
  969. *
  970. *  Notes      :   Called by the FRM_SAVE()
  971. *             :   Updates lengths_offset, offsets_offset, last_expr,
  972. *             :      expr_count
  973. *             :   Special dBASE test - string is EMPTY() and = CHR(0).
  974. *             :   File error number placed in file_error.
  975. *             :   DISK FULL error, file_error = -2.
  976. *
  977.  
  978. FUNCTION WRITE_EXPR
  979.  
  980. PARAMETERS string, blank
  981.  
  982. PRIVATE status, write_item, write_len, write_count, return_count
  983.  
  984. status       = .F.
  985. write_item   = ""
  986. write_len    = 0
  987. write_count  = 0
  988. return_count = 0        && expression count/65535 if empty/-1 error.
  989.  
  990. ** For dBASE compatability **
  991. IF blank .AND. LEN(string) = 0
  992.    status = .T.
  993. ELSE
  994.  
  995.    write_item = string + CHR(0)
  996.    write_len = LEN(write_item)  
  997.  
  998.    ** Move to the next free area **
  999.    FSEEK(handle, expr_offset + last_expr)
  1000.  
  1001.    file_error = FERROR()
  1002.    IF file_error = 0
  1003.               
  1004.       ** Write the expression **      
  1005.       write_count = FWRITE(handle, write_item, write_len)            
  1006.  
  1007.       ** WRITE error? **
  1008.       IF write_count = 0
  1009.          file_error = -2
  1010.       ELSE
  1011.          file_error = FERROR()
  1012.       ENDIF
  1013.  
  1014.       IF file_error = 0
  1015.          FSEEK(handle, offsets_offset)
  1016.  
  1017.          file_error = FERROR()
  1018.          IF file_error = 0
  1019.  
  1020.             ** Add an offset to the offsets array. **
  1021.             write_count = FWRITE(handle, NUM_2_WORD(last_expr), 2)
  1022.  
  1023.             ** WRITE error? **
  1024.             IF write_count = 0
  1025.                file_error = -2
  1026.             ELSE
  1027.                file_error = FERROR()
  1028.             ENDIF
  1029.  
  1030.             IF file_error = 0
  1031.                FSEEK(handle, lengths_offset)
  1032.  
  1033.                file_error = FERROR()
  1034.                IF file_error = 0
  1035.  
  1036.                   ** Add the expression length to the lengths array **
  1037.                   write_count = FWRITE(handle, NUM_2_WORD(write_len), 2)
  1038.  
  1039.                   ** WRITE error? **
  1040.                   IF write_count = 0
  1041.                      file_error = -2
  1042.                   ELSE
  1043.                      file_error = FERROR()
  1044.                   ENDIF
  1045.  
  1046.                   ** Move offsets to next position **
  1047.                   IF file_error = 0
  1048.                      last_expr = last_expr + write_len
  1049.                      lengths_offset = lengths_offset + 2
  1050.                      offsets_offset = offsets_offset + 2
  1051.  
  1052.                      ** Write was performed ok **
  1053.                      status = .T.
  1054.  
  1055.                   ENDIF
  1056.                ENDIF
  1057.             ENDIF
  1058.          ENDIF
  1059.       ENDIF
  1060.    ENDIF
  1061. ENDIF
  1062.  
  1063. ** If the write ok, bump the expression count. **
  1064. IF status
  1065.    IF blank .and. LEN(string) = 0
  1066.       return_count = 65535                && if the expression was empty.
  1067.    ELSE
  1068.       expr_count = expr_count + 1         && global increment.
  1069.       return_count = expr_count           && local return.
  1070.    ENDIF
  1071. ELSE
  1072.    return_count = -1                      && WRITE/SEEK ops error.
  1073. ENDIF
  1074.  
  1075. RETURN (return_count)
  1076.  
  1077. *
  1078. *
  1079. ** eofunc WRITE_EXPR()
  1080.  
  1081.  
  1082. ***
  1083. *  Function   :  WRITE_FIELD()
  1084. *  Author     :  Kevin Shepherd
  1085. *  Date       :  05/28/87
  1086. *  Notice     :  Copyright 1987 Nantucket Corporation
  1087. *  Purpose    :  Writes a FIELDS element to the FIELDS area.
  1088. *
  1089. *  Convention :
  1090. *
  1091. *     status = WRITE_FIELD()
  1092. *
  1093. *  Parameters :
  1094. *
  1095. *     (none)
  1096. *
  1097. *  Return     :
  1098. *
  1099. *     status   -  logical, success or fail of write operation.
  1100. *     
  1101. *  Externals  :
  1102. *
  1103. *     FWRITE(), FSEEK(), FERROR(), WRITE_EXPR(), NUM_2_WORD()
  1104. *
  1105. *  Notes      :   Called by the FRM_SAVE()
  1106. *             :   Updates fields_offset, lengths_offset, offsets_offset,
  1107. *             :      last_expr
  1108. *             :   File error number placed in file_error.
  1109. *
  1110.  
  1111. FUNCTION WRITE_FIELD
  1112.  
  1113. PRIVATE status, write_item, write_len, write_count, cnts_offset, hdr_offset
  1114.  
  1115. status      = .F.
  1116. write_item  = ""
  1117. write_len   = 0
  1118. write_count = 0
  1119. cnts_offset = 65535
  1120. hdr_offset  = 65535
  1121.  
  1122. ** Write Contents **
  1123. cnts_offset = WRITE_EXPR(trim(contents), .F.)
  1124.  
  1125. ** WRITE ok? **
  1126. IF cnts_offset != -1
  1127.  
  1128.    ** Write Header **
  1129.    hdr_offset = WRITE_EXPR(trim(header), .T.)
  1130.  
  1131.    ** WRITE ok? **
  1132.    IF hdr_offset != -1
  1133.  
  1134.       ** Seek to the next free FIELDS area **   
  1135.       fields_offset = fields_offset + 12
  1136.       FSEEK(handle, fields_offset)
  1137.       
  1138.       ** SEEK ok? **
  1139.       file_error = FERROR()
  1140.       IF file_error = 0
  1141.  
  1142.          write_item = NUM_2_WORD(width) +;
  1143.                          replicate(CHR(0), 3) +;
  1144.                          totals +;
  1145.                          NUM_2_WORD(decimals) +;
  1146.                          NUM_2_WORD(cnts_offset) +;
  1147.                          NUM_2_WORD(hdr_offset)
  1148.          write_len = LEN(write_item)                
  1149.  
  1150.          ** Write the FIELDS info **
  1151.          write_count = FWRITE(handle, write_item, write_len)
  1152.  
  1153.          ** WRITE error? **
  1154.          IF write_count = 0
  1155.             file_error = -2
  1156.          ELSE
  1157.             file_error = FERROR()
  1158.          ENDIF
  1159.       
  1160.          ** WRITE ok? **
  1161.          status = (file_error = 0)
  1162.  
  1163.       ENDIF
  1164.    ENDIF
  1165. ENDIF
  1166.  
  1167. RETURN (status)
  1168.  
  1169. *
  1170. *
  1171. ** eofunc WRITE_FIELD()
  1172.  
  1173.  
  1174. ***
  1175. *  Function   :  WRITE_PARAMS()
  1176. *  Author     :  Kevin Shepherd
  1177. *  Date       :  05/28/87
  1178. *  Notice     :  Copyright 1987 Nantucket Corporation
  1179. *  Purpose    :  Writes the last 24 bytes of the report file plus
  1180. *             :      updates the first un-used offset. (last_offset)
  1181. *
  1182. *  Convention :
  1183. *
  1184. *     status = WRITE_PARAMS()
  1185. *
  1186. *  Parameters :
  1187. *
  1188. *     (none)
  1189. *
  1190. *  Return     :
  1191.  
  1192. *     status   -  logical, success or fail of write operation.
  1193. *     
  1194. *  Externals  :
  1195. *
  1196. *     FSEEK(), FWRITE(), FERROR(), NUM_2_WORD()
  1197. *
  1198. *  Notes      :   Called by the FRM_SAVE()
  1199. *             :   File error number placed in file_error.
  1200. *
  1201.  
  1202. FUNCTION WRITE_PARAMS
  1203.  
  1204. PRIVATE status, write_item, write_len, write_count, plus_byte
  1205.  
  1206. status      = .F.
  1207. write_item  = ""
  1208. write_len   = 0
  1209. write_count = 0
  1210. plus_byte   = 0
  1211.  
  1212. ** Calculate plus byte **
  1213. IF frm_plainpage = "Y"
  1214.    plus_byte = plus_byte + 4
  1215. ENDIF
  1216. IF frm_peap = "Y"
  1217.    plus_byte = plus_byte + 2
  1218. ENDIF
  1219. IF frm_pebp = "N"
  1220.    plus_byte = plus_byte + 1
  1221. ENDIF
  1222.  
  1223. ** Prepare miscellaneous data area string for write ops **
  1224. write_item = NUM_2_WORD(page_hdr_num) +;
  1225.                 NUM_2_WORD(grp_expr_num) +;
  1226.                 NUM_2_WORD(sub_expr_num) +;
  1227.                 NUM_2_WORD(grp_hdr_num) +;
  1228.                 NUM_2_WORD(sub_hdr_num) +;
  1229.                 NUM_2_WORD(frm_pagewidth) +;
  1230.                 NUM_2_WORD(frm_linespage) +;
  1231.                 NUM_2_WORD(frm_leftmarg) +;
  1232.                 NUM_2_WORD(frm_rightmarg) +;
  1233.                 NUM_2_WORD(frm_colcount) +;
  1234.                 frm_dblspaced +;
  1235.                 frm_summary +;
  1236.                 frm_pe +;
  1237.                 CHR(plus_byte)
  1238. write_len = LEN(write_item)                
  1239.  
  1240. ** Seek to first parameters area **
  1241. FSEEK(handle, end_offset)
  1242.  
  1243. ** SEEK ok? **
  1244. file_error = FERROR()
  1245. IF file_error = 0
  1246.    write_count = FWRITE(handle, write_item, write_len)
  1247.  
  1248.    ** WRITE error? **
  1249.    IF write_count = 0
  1250.       file_error = -2
  1251.    ELSE
  1252.       file_error = FERROR()
  1253.    ENDIF
  1254.  
  1255.    IF file_error = 0
  1256.       FSEEK(handle, next_free_offset)
  1257.  
  1258.       ** SEEK ok? **
  1259.       file_error = FERROR()
  1260.       IF file_error = 0
  1261.  
  1262.          ** Update the next free expression offset **
  1263.          write_count = FWRITE(handle, NUM_2_WORD(last_expr), 2)
  1264.  
  1265.          ** WRITE error? **
  1266.          IF write_count = 0
  1267.             file_error = -2
  1268.          ELSE
  1269.             file_error = FERROR()
  1270.          ENDIF
  1271.  
  1272.          status = (file_error = 0)
  1273.  
  1274.       ENDIF
  1275.    ENDIF
  1276. ENDIF
  1277.  
  1278.       
  1279. RETURN (status)
  1280.  
  1281. *
  1282. *
  1283. ** eofunc WRITE_PARAMS()
  1284.  
  1285.  
  1286. ***
  1287. *  Function   :  CREATE_DBF()
  1288. *  Author     :  Kevin Shepherd
  1289. *  Date       :  05/22/87
  1290. *  Notice     :  Copyright 1987 Nantucket Corporation
  1291. *  Purpose    :  Creates a <.DBF> file.
  1292. *
  1293. *  Convention :
  1294. *
  1295. *    status = CREATE_DBF(file, size, field, ftype, flength, fdecimal)
  1296. *
  1297. *  Parameters :
  1298. *
  1299. *     file     -  string, dbf file name to create.
  1300. *     size     -  numeric, number of fields. (for speed)
  1301. *     field    -  array, field name(s).
  1302. *     ftype    -  array, field type(s).
  1303. *     flength  -  array, field length(s).
  1304. *     fdecimal -  array, field decimal length(s).
  1305. *
  1306. *  Return     :
  1307. *
  1308. *     status   -  logical, success of create operation.
  1309. *     
  1310. *  Externals  :
  1311. *
  1312. *     FCREATE(), FCLOSE(), FWRITE(), FERROR(), NUM_2_WORD()
  1313. *
  1314. *  Notes      :   File error number placed in file_error.
  1315. *
  1316.  
  1317. FUNCTION CREATE_DBF
  1318.  
  1319. PARAMETERS file, size, fieldname, ftype, flength, fdecimal
  1320.  
  1321. PRIVATE header_image, field_image, tail_image, block_size, handle,;
  1322.    i, write_count, field_count, data_offset, record_size, status
  1323.  
  1324. ** DBF file creation variables **
  1325. i           = 0                  && array subscript.
  1326. handle      = 0
  1327. block_size  = 32                 && header and field block size.
  1328. data_offset = block_size         && field records start are offset 32d.
  1329. record_size = 0                  
  1330. write_count = 0                  && bytes writen.
  1331. field_count = 0                  && fields to create.
  1332. status = .T.
  1333.  
  1334. ** NO extension **
  1335. IF AT(".", file) = 0
  1336.    file = TRIM(file) + ".DBF"
  1337. ENDIF
  1338.  
  1339. ** Calculate record_size, field_count and data_offset **
  1340. FOR i = 1 to size
  1341.    record_size = record_size + flength[i]   
  1342.    data_offset = data_offset + block_size
  1343. NEXT
  1344.  
  1345. field_count = i - 1
  1346. record_size = record_size + 1       && + one byte of pad.
  1347. data_offset = data_offset + 2       && + 2 for CR and NULL.
  1348.  
  1349. header_image = CHR(3) +;                        && dbf id.      (byte)
  1350.                   replicate(CHR(0), 3) +;       && last update. (byte)
  1351.                   replicate(CHR(0), 4) +;       && last record. (long)
  1352.                   NUM_2_WORD(data_offset) +;    && data offset. (word)
  1353.                   NUM_2_WORD(record_size) +;    && record size. (word)
  1354.                   replicate(CHR(0), 20)         && 20 byte pad.
  1355.  
  1356. field_image = ""                                && filled in later.
  1357. tail_image = CHR(13) + CHR(0) + CHR(26)         && CR, pad, EOF
  1358.  
  1359. ** Create label content dbf file **   
  1360. handle = FCREATE(file)
  1361.  
  1362. ** CREATEd ok? **
  1363. file_error = FERROR()
  1364. status = (file_error = 0)
  1365.  
  1366. IF status
  1367.  
  1368.    ** Write dbf header image **
  1369.    write_count = FWRITE(handle, header_image, block_size)
  1370.  
  1371.    ** Header WRITE ok? **
  1372.    IF write_count = 0
  1373.       file_error = -2
  1374.    ELSE
  1375.       file_error = FERROR()
  1376.    ENDIF
  1377.    status = (file_error = 0)
  1378.  
  1379.    IF status
  1380.  
  1381.       ** Make a FIELD header block **
  1382.       FOR i = 1 to field_count
  1383.  
  1384.          ** Build it **
  1385.          field_image = fieldname[i] +;                   && field name + pad
  1386.                          replicate(CHR(0), 11 - LEN(fieldname[i])) +;
  1387.                          ftype[i] +;                 && field type   (byte)
  1388.                          replicate(CHR(0), 4) +;     && 4 byte pad
  1389.                          CHR(flength[i] % 256) +;    && field length (byte)
  1390.                          IF(ftype[i] = "C",;         && for "C" type > 256
  1391.                             CHR(flength[i] / 256),;  && low + high bytes
  1392.                             CHR(fdecimal[i])) +;     && decimals     (byte)
  1393.                          replicate(CHR(0), 14)       && 14 byte pad
  1394.  
  1395.          ** Write it **
  1396.          write_count = FWRITE(handle, field_image, block_size)
  1397.  
  1398.          ** WRITE ok? **
  1399.          IF write_count = 0
  1400.             file_error = -2
  1401.          ELSE
  1402.             file_error = FERROR()
  1403.          ENDIF
  1404.          status = (file_error = 0)
  1405.  
  1406.          IF !status
  1407.             i = field_count + 1        && breakout of FOR loop.
  1408.          ENDIF
  1409.       NEXT
  1410.  
  1411.    ENDIF
  1412.  
  1413.    ** If file created ok so far... **
  1414.    IF status
  1415.       ** Write Tail CR + NULL + EOF (0Dh + 00h + 1Ah) **
  1416.       write_count = FWRITE(handle, tail_image, 3)
  1417.  
  1418.       ** WRITE error? **
  1419.       IF write_count = 0
  1420.          file_error = -2
  1421.       ELSE
  1422.          file_error = FERROR()
  1423.       ENDIF
  1424.  
  1425.       status = (file_error = 0)
  1426.  
  1427.    ENDIF
  1428.  
  1429.    ** Close file **
  1430.    status = FCLOSE(handle)
  1431.    IF !status
  1432.       file_error = FERROR()
  1433.    ENDIF
  1434. ENDIF
  1435.  
  1436. RETURN (status)
  1437.  
  1438. *
  1439. ** eofunc CREATE_DBF
  1440.  
  1441.  
  1442. ***
  1443. *  Function   :  WORD_2_NUM()
  1444. *  Author     :  Kevin Shepherd
  1445. *  Date       :  05/24/87
  1446. *  Notice     :  Copyright 1987 Nantucket Corporation
  1447. *  Purpose    :  Converts a 2 byte string to numeric.
  1448. *
  1449. *  Convention :
  1450. *
  1451. *     num = WORD_2_NUM(hex_string)
  1452. *
  1453. *  Parameters :
  1454. *
  1455. *     string   -  hex_string, 2 hex bytes in LSB, MSB order
  1456. *
  1457. *  Return     :
  1458. *
  1459. *     num      -  numeric, converted number.
  1460. *     
  1461. *
  1462.  
  1463. FUNCTION WORD_2_NUM
  1464.  
  1465. PARAMETERS byte_string
  1466.  
  1467. PRIVATE numeric
  1468.  
  1469. numeric = ASC(SUBSTR(byte_string, 1, 1)) +;           && extract LSB
  1470.              ASC(SUBSTR(byte_string, 2, 1)) * 256     && extract MSB
  1471.  
  1472. RETURN (numeric)
  1473.  
  1474. *
  1475. ** eofunc WORD_2_NUM()
  1476.  
  1477.  
  1478. ***
  1479. *  Function   :  NUM_2_WORD()
  1480. *  Author     :  Kevin Shepherd
  1481. *  Date       :  05/24/87
  1482. *  Notice     :  Copyright 1987 Nantucket Corporation
  1483. *  Purpose    :  Converts a numeric to a 2 byte string.
  1484. *
  1485. *  Convention :
  1486. *
  1487. *     byte_string = NUM_2_WORD(numeric)
  1488. *
  1489. *  Parameters :
  1490. *
  1491. *     numeric       -  numeric, number to convert.
  1492. *
  1493. *  Return     :
  1494. *
  1495. *     byte_string   -  string, 2 bytes in LSB, MSB order
  1496. *     
  1497. *
  1498.  
  1499. FUNCTION NUM_2_WORD
  1500.  
  1501. PARAMETERS numeric
  1502.  
  1503. PRIVATE byte_string
  1504.  
  1505. byte_string = CHR(numeric % 256) +;         && make LSB
  1506.                 CHR(numeric / 256)          && make MSB
  1507.  
  1508. RETURN (byte_string)
  1509.  
  1510. *
  1511. ** eofunc NUM_2_WORD()
  1512.  
  1513.  
  1514.