extra/tzinfo/tzinfo.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors alien.c-types alien.data alien.endian arrays
   5 assocs calendar classes.struct combinators endian hashtables io
   6 io.encodings.binary io.files kernel locals math math.order
   7 sequences strings ;
   8
   9 IN: tzinfo
  10
  11 <PRIVATE
  12
  13 STRUCT: tzhead
  14     { tzh_reserved char[16] }
  15     { tzh_ttisgmtcnt be32 }
  16     { tzh_ttisstdcnt be32 }
  17     { tzh_leapcnt be32 }
  18     { tzh_timecnt be32 }
  19     { tzh_typecnt be32 }
  20     { tzh_charcnt be32 } ;
  21
  22 PACKED-STRUCT: ttinfo
  23     { tt_gmtoff be32 }
  24     { tt_isdst uchar }
  25     { tt_abbrind uchar } ;
  26
  27 ERROR: bad-magic ;
  28
  29 : check-magic ( -- )
  30     4 read "TZif" sequence= [ bad-magic ] unless ;
  31
  32 TUPLE: tzfile header transition-times local-times types abbrevs
  33 leaps is-std is-gmt ;
  34
  35 C: <tzfile> tzfile
  36
  37 : read-be32 ( -- n )
  38     4 read be32 deref ;
  39
  40 : read-tzfile ( -- tzfile )
  41     check-magic tzhead read-struct dup {
  42         [ tzh_timecnt>> [ read-be32 ] replicate ]
  43         [ tzh_timecnt>> [ read1 ] replicate ]
  44         [ tzh_typecnt>> [ ttinfo read-struct ] replicate ]
  45         [ tzh_charcnt>> read ]
  46         [ tzh_leapcnt>> [ read-be32 read-be32 2array ] replicate ]
  47         [ tzh_ttisstdcnt>> read ]
  48         [ tzh_ttisgmtcnt>> read ]
  49     } cleave <tzfile> ;
  50
  51 :: tznames ( abbrevs -- assoc )
  52     0 [
  53         0 over abbrevs index-from dup
  54     ] [
  55         [ dupd abbrevs subseq >string 2array ] keep 1 + swap
  56     ] produce 2nip >hashtable ;
  57
  58 TUPLE: local-time gmt-offset dst? abbrev std? gmt? ;
  59
  60 C: <local-time> local-time
  61
  62 TUPLE: transition seconds timestamp local-time ;
  63
  64 C: <transition> transition
  65
  66 :: tzfile>transitions ( tzfile -- transitions )
  67     tzfile abbrevs>> tznames :> abbrevs
  68     tzfile is-std>> :> is-std
  69     tzfile is-gmt>> :> is-gmt
  70     tzfile types>> [
  71         [
  72             {
  73                 [ tt_gmtoff>> seconds ]
  74                 [ tt_isdst>> 1 = ]
  75                 [ tt_abbrind>> abbrevs at ]
  76             } cleave
  77         ] dip
  78         [ is-std ?nth dup [ 1 = ] when ]
  79         [ is-gmt ?nth dup [ 1 = ] when ] bi <local-time>
  80     ] map-index :> local-times
  81     tzfile transition-times>>
  82     tzfile local-times>> [
  83         [ dup unix-time>timestamp ] [ local-times nth ] bi*
  84         <transition>
  85     ] 2map ;
  86
  87 TUPLE: tzinfo tzfile transitions ;
  88
  89 C: <tzinfo> tzinfo
  90
  91 : find-transition ( timestamp tzinfo -- transition )
  92     [ timestamp>unix-time ] [ transitions>> ] bi*
  93     [ [ seconds>> before? ] with find drop ]
  94     [ swap [ 1 [-] swap nth ] [ last ] if* ] bi ;
  95
  96 PRIVATE>
  97
  98 : file>tzinfo ( path -- tzinfo )
  99     binary [
 100         read-tzfile dup tzfile>transitions <tzinfo>
 101     ] with-file-reader ;
 102
 103 : from-utc ( timestamp tzinfo -- timestamp' )
 104     [ drop instant >>gmt-offset ]
 105     [ find-transition local-time>> gmt-offset>> ] 2bi
 106     convert-timezone ;
 107
 108 : normalize ( timestamp tzinfo -- timestamp' )
 109     [ instant convert-timezone ] [ from-utc ] bi* ;
 110
 111 : load-tzinfo ( name -- tzinfo )
 112     "/usr/share/zoneinfo/" prepend file>tzinfo ;