extra/dbf/dbf.factor

   1 ! Copyright (C) 2018 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors alien.c-types alien.endian alien.strings assocs
   5 calendar calendar.parser classes.struct combinators endian fry
   6 io io.encodings.8-bit io.encodings.ascii
   7 io.encodings.binary io.encodings.string io.files
   8 io.streams.byte-array kernel math math.parser namespaces
   9 sequences splitting strings ;
  10
  11 IN: dbf
  12
  13 SYMBOL: dbf-encoding
  14
  15 CONSTANT: dbf-encodings H{
  16     { 0x00 ascii }
  17     { 0x01 cp437 }
  18     { 0x02 cp850 }
  19     { 0x03 windows-1252 }
  20     { 0x04 mac-roman }
  21     { 0x08 cp865 }
  22     { 0x09 cp437 }
  23     { 0x0A cp850 }
  24     { 0x0B cp437 }
  25     { 0x0D cp437 }
  26     { 0x0E cp850 }
  27     { 0x0F cp437 }
  28     { 0x10 cp850 }
  29     { 0x11 cp437 }
  30     { 0x12 cp850 }
  31     { 0x13 "cp932" }
  32     { 0x14 cp850 }
  33     { 0x15 cp437 }
  34     { 0x16 cp850 }
  35     { 0x17 cp865 }
  36     { 0x18 cp437 }
  37     { 0x19 cp437 }
  38     { 0x1A cp850 }
  39     { 0x1B cp437 }
  40     { 0x1C cp863 }
  41     { 0x1D cp850 }
  42     { 0x1F cp852 }
  43     { 0x22 cp852 }
  44     { 0x23 cp852 }
  45     { 0x24 cp860 }
  46     { 0x25 cp850 }
  47     { 0x26 cp866 }
  48     { 0x37 cp850 }
  49     { 0x40 cp852 }
  50     { 0x4D "cp936" }
  51     { 0x4E "cp949" }
  52     { 0x4F "cp950" }
  53     { 0x50 "cp874" }
  54     { 0x57 windows-1252 }
  55     { 0x58 windows-1252 }
  56     { 0x59 windows-1252 }
  57     { 0x64 cp852 }
  58     { 0x65 cp866 }
  59     { 0x66 cp865 }
  60     { 0x67 cp861 }
  61     { 0x68 f }
  62     { 0x69 f }
  63     { 0x6a "cp737" }
  64     { 0x6b cp857 }
  65     { 0x6c cp863 }
  66     { 0x78 "cp950" }
  67     { 0x79 "cp949" }
  68     { 0x7a "cp936" }
  69     { 0x7b "cp932" }
  70     { 0x7c "cp874" }
  71     { 0x7d windows-1255 }
  72     { 0x7e windows-1256 }
  73     { 0x86 "cp737" }
  74     { 0x87 cp852 }
  75     { 0x88 cp857 }
  76     { 0x96 "mac-cyrillic" }
  77     { 0x97 "mac-latin2" }
  78     { 0x98 "mac-greek" }
  79     { 0xc8 windows-1250 }
  80     { 0xc9 windows-1251 }
  81     { 0xca windows-1254 }
  82     { 0xcb windows-1253 }
  83     { 0xcc windows-1250 }
  84 }
  85
  86 CONSTANT: dbf-file-types H{
  87     { 0x02 "FoxBASE" }
  88     { 0x03 "FoxBASE+/dBase III plus, no memo" }
  89     { 0x04 "dBase IV, no memo" }
  90     { 0x05 "dBase V, no memo" }
  91     { 0x07 "Visual Objects 1.x" }
  92     { 0x30 "Visual FoxPro" }
  93     { 0x31 "Visual FoxPro, autoincrement enabled" }
  94     { 0x32 "Visual FoxPro with field type Varchar or Varbinary" }
  95     { 0x43 "dBase IV SQL table files, no memo" }
  96     { 0x63 "dBase IV SQL system files, no memo" }
  97     { 0x7b "dBase IV, with memo" }
  98     { 0x83 "FoxBASE+/dBase III PLUS, with memo" }
  99     { 0x87 "Visual Objects 1.x, with memo" }
 100     { 0x8B "dBase IV with memo" }
 101     { 0x8E "dBase IV with SQL table" }
 102     { 0xCB "dBase IV SQL table files, with memo" }
 103     { 0xE5 "HiPer-Six format with SMT memo file" }
 104     { 0xF5 "FoxPro 2.x (or earlier) with memo" }
 105     { 0xFB "FoxBASE" }
 106 }
 107
 108 STRUCT: dbf-file-header
 109     { file-type uint8_t }
 110     { year uint8_t }
 111     { month uint8_t }
 112     { day uint8_t }
 113     { #records uint32_t }
 114     { header-length uint16_t }
 115     { record-length uint16_t }
 116     { reserved1 uint16_t }
 117     { incomplete-transaction uint8_t }
 118     { encryption-flag uint8_t }
 119     { free-record-thread uint32_t }
 120     { reserved2 uint32_t }
 121     { reserved3 uint32_t }
 122     { mdx-flag uint8_t }
 123     { language-driver uint8_t }
 124     { reserved4 uint16_t } ;
 125
 126 : read-file-header ( -- file-header )
 127     dbf-file-header read-struct ;
 128
 129 CONSTANT: dbf-field-flags H{
 130     { 0x01 "System Column (not visible to user)" }
 131     { 0x02 "Column can store null values" }
 132     { 0x04 "Binary column (for CHAR and MEMO only)" }
 133     { 0x06 "(0x02+0x04) When a field is NULL and binary (Integer, Currency, and Character/Memo fields)" }
 134     { 0x0C "Column is autoincrementing" }
 135 }
 136
 137 STRUCT: dbf-field-header
 138     { name uint8_t[11] }
 139     { type uint8_t }
 140     { address uint32_t }
 141     { length uint8_t }
 142     { #decimals uint8_t }
 143     { reserved1 uint16_t }
 144     { workarea-id uint8_t }
 145     { reserved2 uint8_t }
 146     { reserved3 uint8_t }
 147     { set-fields-flag uint8_t }
 148     { reserved4 uint8_t[7] }
 149     { index-field-flag uint8_t } ;
 150
 151 : read-field-headers ( -- field-headers )
 152     [ read1 dup { CHAR: \r CHAR: \n f } member? not ] [
 153         dbf-field-header heap-size 1 - read swap prefix
 154         dbf-field-header memory>struct
 155     ] produce nip ;
 156
 157 : check-field-header ( field-header -- field-header )
 158     dup type>> {
 159         { CHAR: I [ dup length>> 4 assert= ] }
 160         { CHAR: L [ dup length>> 1 assert= ] }
 161         { CHAR: O [ dup length>> 8 assert= ] }
 162         { CHAR: Y [ dup length>> 8 assert= ] }
 163         { CHAR: D [ dup length>> 8 assert= ] }
 164         { CHAR: T [ dup length>> 8 assert= ] }
 165         { CHAR: M [ dup length>> 10 assert= ] }
 166         [ drop ]
 167     } case ;
 168
 169 : check-record-length ( file-header field-headers -- )
 170     [ record-length>> ] [ [ length>> ] map-sum ] bi* assert= ;
 171
 172 DEFER: parse-field
 173
 174 TUPLE: record deleted? values ;
 175
 176 : read-records ( field-headers -- records )
 177     [ read1 dup { 0x1a f } member? not ]
 178     [
 179         CHAR: * = over [
 180             [ length>> read ]
 181             [ type>> parse-field ] bi
 182         ] map record boa
 183     ] produce 2nip ;
 184
 185 TUPLE: dbf file-header field-headers records ;
 186
 187 : load-dbf ( path -- dbf )
 188     binary [
 189         read-file-header
 190         read-field-headers
 191         over header-length>> seek-absolute seek-input
 192         over language-driver>> dbf-encodings at dbf-encoding [
 193             dup read-records dbf boa
 194         ] with-variable
 195     ] with-file-reader ;
 196
 197 : seek-record ( n file-header -- )
 198     [ record-length>> * ] [ header-length>> ] bi +
 199     seek-absolute seek-input ;
 200
 201 : parse-string ( byte-array -- string )
 202     [ " \0" member? ] trim-tail dbf-encoding get decode ;
 203
 204 : parse-date ( byte-array -- date/f )
 205     dup [ " \0" member? ] all? [ drop f ] [
 206         binary [ read-ymd <date-gmt> ] with-byte-reader
 207     ] if ;
 208
 209 : parse-float ( byte-array -- n )
 210     [ "\r\n\t *" member? ] trim string>number ;
 211
 212 : parse-int ( byte-array -- n )
 213     dup length 4 assert= le> ;
 214
 215 : parse-short ( byte-array -- n )
 216     dup length 2 assert= le> ;
 217
 218 SYMBOL: unknown
 219
 220 ERROR: illegal-logical value ;
 221
 222 : parse-logical ( byte-array -- n )
 223     first {
 224         { [ dup "TtYy" member? ] [ drop t ] }
 225         { [ dup "FfNn" member? ] [ drop f ] }
 226         { [ dup "? " member? ] [ drop unknown ] }
 227         [ illegal-logical ]
 228     } cond ;
 229
 230 : parse-numeric ( byte-array -- n )
 231     [ "\r\n\t *" member? ] trim
 232     H{ { CHAR: , CHAR: . } } substitute string>number ;
 233
 234 : parse-double ( byte-array -- n )
 235     dup length 8 assert= le> bits>double ;
 236
 237 : parse-currency ( byte-array -- n )
 238     dup length 8 assert= le> 10000 / ;
 239
 240 : parse-timestamp ( byte-array -- timestamp )
 241     [ -4713 1 1 <date> ] dip 4 cut [ le> ] bi@
 242     [ days time+ ] [ milliseconds time+ ] bi* ;
 243
 244 ERROR: unsupported-field-type type ;
 245
 246 : parse-field ( byte-array type -- data )
 247     {
 248         { CHAR: \0 [ ] }
 249         { CHAR: 2  [ parse-short ] }
 250         { CHAR: 4  [ parse-int ] }
 251         { CHAR: 8  [ parse-double ] }
 252         { CHAR: C  [ parse-string ] }
 253         { CHAR: D  [ parse-date ] }
 254         { CHAR: F  [ parse-float ] }
 255         { CHAR: I  [ parse-int ] }
 256         { CHAR: L  [ parse-logical ] }
 257         { CHAR: N  [ parse-numeric ] }
 258         { CHAR: O  [ parse-double ] }
 259         { CHAR: V  [ parse-string ] }
 260         { CHAR: Y  [ parse-currency ] }
 261         { CHAR: @  [ parse-timestamp ] }
 262         ! { CHAR: +  [ parse-autoincrement ] }
 263         ! { CHAR: M  [ parse-memo ] }
 264         ! { CHAR: T  [ parse-datetime ] }
 265         ! { CHAR: B  [ parse-double? ] } ! (only on dbversion in [0x30, 0x31, 0x32])
 266         ! { CHAR: G  [ parse-general ] }
 267         ! { CHAR: P  [ parse-picture ] }
 268         ! { CHAR: Q  [ parse-varbinary ] }
 269         [ unsupported-field-type ]
 270     } case ;
 271
 272 : dbase3-memo ( n path -- data )
 273     binary [
 274         512 * seek-absolute seek-input
 275         B{ } [
 276             512 read
 277             dup [ B{ 0 0x1a } member? ] find drop
 278             [ head f ] [ t ] if* [ append ] dip
 279         ] loop
 280     ] with-file-reader ;
 281
 282 LE-STRUCT: db4-memo-header
 283     { reserved uint } ! B{ 0xff 0xff 0x08 0x08 }
 284     { length uint } ;
 285
 286 : dbase4-memo ( n path -- data )
 287     binary [
 288         512 * seek-absolute seek-input
 289         db4-memo-header read-struct length>> read
 290     ] with-file-reader ;
 291
 292 BE-STRUCT: vfp-file-header
 293     { nextblock uint }
 294     { reserved1 ushort }
 295     { blocksize ushort }
 296     { reserved2 uchar[504] } ;
 297
 298 BE-STRUCT: vfp-memo-header
 299     { type uint }
 300     { length uint } ;
 301
 302 CONSTANT: vfp-memo-types H{
 303     { 0x0 "picture memo" }
 304     { 0x1 "text memo" }
 305     { 0x2 "object memo" }
 306 }
 307
 308 : vfp-memo ( n path -- data )
 309     binary [
 310         vfp-file-header read-struct blocksize>> *
 311         seek-absolute seek-input
 312         vfp-memo-header read-struct length>> read
 313     ] with-file-reader ;