/pliant/language/type/misc/datetime.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring3.pli" 
 18   
 19   
 20  type Time 
 21    field Float seconds 
 22   
 23  type Date 
 24    field Int days 
 25   
 26  type DateTime 
 27    field Float seconds 
 28   
 29   
 30  function build  t 
 31    arg_w Time t 
 32    seconds := undefined 
 33   
 34  function build  d 
 35    arg_w Date d 
 36    days := undefined 
 37   
 38  function build  dt 
 39    arg_w DateTime dt 
 40    dt seconds := undefined 
 41   
 42   
 43  # ancient C codage under OS/2 : DateTime 0 <=> 31/12/0 0:0:0 
 44  # new Pliant codage: DateTime 0 <=> 1/1/1 0:0:0 
 45   
 46   
 47  (gvar Array:Int month_max) size := 13 
 48  for (gvar Int i) 1 12 
 49    month_max := shunt i%2=(shunt i<=7 1 0) 31 30 
 50  month_max := 0 
 51  month_max := 29 
 52   
 53  (gvar Array:Int month_base) size := 13 
 54  for 0 12 
 55    month_base := shunt i>month_base:(i-1)+month_max:(i-1) 0 
 56   
 57  function year_base year -> base 
 58    arg Int year base 
 59    return year*365+year\4-year\100+year\400 
 60   
 61  function year_is_normal year -> normal 
 62    arg Int year ; arg CBool normal 
 63    normal := year%4<>or (year%100=and year%400<>0) 
 64   
 65   
 66 
 
 67  #  building 
 68   
 69   
 70  function date year month day -> d 
 71    arg Int year month day ; arg Date d 
 72    if month<or month>12 or day<or day>month_max:month 
 73      days := undefined 
 74      return 
 75    var CBool norm := year_is_normal year 
 76    if month=and day=29 and norm 
 77      days := undefined 
 78      return 
 79    days := year_base:(year-1) month_base:month+(shunt norm and month>2 (-1) 0) day-1 
 80   
 81   
 82  function time hour minute second fraction -> t 
 83    arg Int hour minute second ; arg Float fraction ; arg Time t 
 84    if hour<or hour>=24 or minute<or minute>=60 or second<or second>=60 
 85      seconds := undefined 
 86      return 
 87    seconds := hour*3600 minute*60 second fraction 
 88   
 89   
 90  function datetime year month day hour minute second fraction -> dt 
 91    arg Int year month day hour minute second ; arg Float fraction ; arg DateTime dt 
 92    var Date := date year month day 
 93    if d:days=undefined 
 94      dt seconds := undefined 
 95      return 
 96    var Time := time hour minute second fraction 
 97    if t:seconds=undefined 
 98      dt seconds := undefined 
 99      return 
 100    dt seconds := d:days*86400.0 t:seconds 
 101   
 102   
 103 
 
 104  #  splitting 
 105   
 106   
 107  function try_month month norm remain day -> ok 
 108    arg Int month ; arg CBool norm ; arg Int remain ; arg_rw Int day ; arg CBool ok 
 109    var Int := remain month_base:month + (shunt norm and month>2 1 0) 
 110    if r<or r>=month_max:month+(shunt norm and month=2 (-1) 0) 
 111      return false 
 112    day := r+1 
 113    return true 
 114   
 115  function try_year year remain month day -> ok 
 116    arg Int year remain ; arg_w Int month day ; arg CBool ok 
 117    var CBool norm := year_is_normal year 
 118    var Int := remain-year_base:(year-1) 
 119    if r<or r>(shunt norm 364 365) 
 120      return false 
 121    month := r*2\61+1 
 122    if (try_month month norm day) 
 123      return true 
 124    if (try_month month+norm day) 
 125      month := month+1 
 126      return true 
 127    if (try_month month-norm day) 
 128      month := month-1 
 129      return true 
 130    error error_id_check "Failed to extract Date month" 
 131   
 132  method d split year month day 
 133    arg Date d ; arg_w Int year month day 
 134    if d:days=defined 
 135      var Int days := days 
 136      year := cast (days+14.75)/365.25+1-0.5 Int 
 137      if (try_year year days month day) 
 138        void 
 139      eif (try_year year+days month day) 
 140        year := year+1 
 141      eif (try_year year-days month day) 
 142        year := year-1 
 143      else 
 144        year := undefined ; month := undefined ; day := undefined 
 145        # error error_id_check "Failed to extract Date year" 
 146    else 
 147      year := undefined ; month := undefined ; day := undefined 
 148   
 149   
 150  method t split seconds fraction 
 151    arg Time t ; arg_w Int seconds ; arg_w Float fraction 
 152    if t:seconds=defined 
 153      seconds := cast t:seconds-0.5 Int 
 154      fraction := t:seconds-seconds 
 155      if fraction<0 
 156        fraction := fraction+1 ; seconds := seconds-1 
 157      eif fraction>=1 
 158        fraction := fraction-1 ; seconds := seconds+1 
 159      check fraction>=and fraction<1 
 160    else 
 161      seconds := undefined ; fraction := undefined 
 162   
 163  method t split hour minute second fraction 
 164    arg Time t ; arg_w Int hour minute second ; arg_w Float fraction 
 165    var Int seconds 
 166    split seconds fraction 
 167    if seconds=defined 
 168      hour := seconds\3600 
 169      minute := seconds\60%60 
 170      second := seconds%60 
 171    else 
 172      hour := undefined ; minute := undefined ; second := undefined 
 173   
 174   
 175  method dt split d t 
 176    arg DateTime dt ; arg_w Date d ; arg_w Time t 
 177    if dt:seconds=defined 
 178      days := cast dt:seconds/86400-0.5 Int 
 179      seconds := dt:seconds-86400.0*d:days 
 180      if t:seconds<0 
 181        seconds := t:seconds+86400 ; days := d:days-1 
 182      eif t:seconds>=86400 
 183        seconds := t:seconds-86400 ; days := d:days+1 
 184      check t:seconds>=and t:seconds<86400 
 185    else 
 186      d:days := undefined ; t:seconds := undefined 
 187   
 188  method dt split year month day hour minute second fraction 
 189    arg DateTime dt ; arg_w Int year month day hour minute second ; arg_w Float fraction 
 190    var Date d ; var Time t 
 191    dt split t 
 192    split year month day 
 193    split hour minute second fraction 
 194   
 195   
 196   
 197 
 
 198  #  fields 
 199   
 200   
 201  method d year -> y 
 202    arg Date d ; arg Int y 
 203    split y (var Int mo) (var Int da) 
 204   
 205  method d month -> m 
 206    arg Date d ; arg Int m 
 207    split (var Int ye) m (var Int da) 
 208   
 209  method d day -> da 
 210    arg Date d ; arg Int da 
 211    split (var Int ye) (var Int mo) da 
 212   
 213  method d day_of_week -> dow 
 214    arg Date d ; arg Int dow 
 215    if d:days=defined 
 216      dow := (d:days+1)%7 
 217    else 
 218      dow := undefined 
 219   
 220  gvar Array:Str day_name 
 221  day_name size := 7 
 222  day_name := "sunday" 
 223  day_name := "monday" 
 224  day_name := "tuesday" 
 225  day_name := "wednesday" 
 226  day_name := "thursday" 
 227  day_name := "friday" 
 228  day_name := "saturday" 
 229   
 230   
 231  method t hour -> h 
 232    arg Time t ; arg Int h 
 233    split (var Int seconds) (var Float fraction) 
 234    if seconds=defined 
 235      := seconds\3600 
 236    else 
 237      := undefined 
 238   
 239  method t minute -> m 
 240    arg Time t ; arg Int m 
 241    split (var Int seconds) (var Float fraction) 
 242    if seconds=defined 
 243      := seconds\60%60 
 244    else 
 245      := undefined 
 246   
 247  method t second -> s 
 248    arg Time t ; arg Int s 
 249    split (var Int seconds) (var Float fraction) 
 250    if seconds=defined 
 251      := seconds%60 
 252    else 
 253      := undefined 
 254   
 255  method t fraction -> f 
 256    arg Time t ; arg Float f 
 257    split (var Int seconds) f 
 258   
 259   
 260  method dt date -> d 
 261    arg DateTime dt ; arg Date d 
 262    dt split d (var Time t) 
 263   
 264  method dt time -> t 
 265    arg DateTime dt ; arg Time t 
 266    dt split (var Date d) t 
 267   
 268  method dt year -> y 
 269    arg DateTime dt ; arg Int y 
 270    := dt:date year 
 271   
 272  method dt month -> m 
 273    arg DateTime dt ; arg Int m 
 274    := dt:date month 
 275   
 276  method dt day -> d 
 277    arg DateTime dt ; arg Int d 
 278    := dt:date day 
 279   
 280  method dt day_of_week -> dow 
 281    arg DateTime dt ; arg Int dow 
 282    dow := dt:date day_of_week 
 283   
 284  method dt hour -> h 
 285    arg DateTime dt ; arg Int h 
 286    := dt:time hour 
 287   
 288  method dt minute -> m 
 289    arg DateTime dt ; arg Int m 
 290    := dt:time minute 
 291   
 292  method dt second -> s 
 293    arg DateTime dt ; arg Int s 
 294    := dt:time second 
 295   
 296  method dt fraction -> f 
 297    arg DateTime dt ; arg Float f 
 298    := dt:time fraction 
 299   
 300   
 301 
 
 302  #  comparing 
 303   
 304   
 305  function compare a b -> c 
 306    arg Date b ; arg Int c 
 307    := compare a:days b:days 
 308   
 309  function compare a b -> c 
 310    arg Time b ; arg Int c 
 311    := compare a:seconds b:seconds 
 312   
 313  function compare a b -> c 
 314    arg DateTime b ; arg Int c 
 315    := compare a:seconds b:seconds 
 316   
 317   
 318 
 
 319  #  computing 
 320   
 321   
 322  function '+' d1 days -> d2 
 323    arg Date d1 d2 ; arg Int days 
 324    d2:days := d1:days days 
 325   
 326  function '-' d1 days -> d2 
 327    arg Date d1 d2 ; arg Int days 
 328    d2:days := d1:days days 
 329   
 330  function '-' d1 d2 -> days 
 331    arg Date d1 d2 ; arg Int days 
 332    days := d1:days d2:days 
 333   
 334   
 335  function '+' t1 seconds -> t2 
 336    arg Time t1 t2 ; arg Float seconds 
 337    t2:seconds := t1:seconds seconds 
 338   
 339  function '-' t1 seconds -> t2 
 340    arg Time t1 t2 ; arg Float seconds 
 341    t2:seconds := t1:seconds seconds 
 342   
 343  function '+' t1 t2 -> t3 
 344    arg Time t1 t2 t3 
 345    t3 seconds := t1:seconds t2:seconds 
 346   
 347  function '-' t1 t2 -> seconds 
 348    arg Time t1 t2 ; arg Float seconds 
 349    seconds := t1:seconds t2:seconds 
 350   
 351   
 352  function '+' dt1 t -> dt2 
 353    arg DateTime dt1 dt2 ; arg Time t 
 354    dt2:seconds := dt1:seconds t:seconds 
 355   
 356  function '-' dt1 t -> dt2 
 357    arg DateTime dt1 dt2 ; arg Time t 
 358    dt2:seconds := dt1:seconds t:seconds 
 359   
 360  function '-' dt1 dt2 -> t 
 361    arg DateTime dt1 dt2 ; arg Time t 
 362    t:seconds := dt1:seconds dt2:seconds 
 363   
 364   
 365  export Date date '. days' 
 366  export Time time '. seconds' 
 367  export DateTime datetime 
 368  export '. split' '. date' '. time' '. year' '. month' '. day' '. day_of_week' 
 369  export '. hour' '. minute' '. second' '. fraction' 
 370  export '+' '-' 
 371  export day_name 
 372   
 373   
 374 
 
 375  #  status 
 376   
 377   
 378  function 'cast Status' d -> s 
 379    arg Date d ; arg Status s 
 380    explicit 
 381    := cast d:days Status 
 382   
 383  function 'cast Date' s -> d 
 384    arg Status s ; arg Date d 
 385    extension 
 386    if s<>undefined 
 387      error error_id_unexpected "Unexpected Status value" 
 388    days := undefined 
 389   
 390   
 391  function 'cast Status' t -> s 
 392    arg Time t ; arg Status s 
 393    explicit 
 394    := cast t:seconds Status 
 395   
 396  function 'cast Time' s -> t 
 397    arg Status s ; arg Time t 
 398    reduction 
 399    if s<>undefined 
 400      error error_id_unexpected "Unexpected Status value" 
 401    seconds := undefined 
 402   
 403   
 404  function 'cast Status' dt -> s 
 405    arg DateTime dt ; arg Status s 
 406    := cast dt:seconds Status 
 407   
 408  function 'cast DateTime' s -> dt 
 409    arg Status s ; arg DateTime dt 
 410    extension 
 411    if s<>undefined 
 412      error error_id_unexpected "Unexpected Status value" 
 413    dt seconds := undefined 
 414   
 415   
 416  export compare 'cast Status' 'cast Date' 'cast Time' 'cast DateTime' 
 417   
 418   
 419 
 
 420  #  current date/time 
 421   
 422   
 423  if os_api="linux" or os_api="posix" 
 424   
 425    constant os_datetime_origin (datetime 1970 1 1 0 0 0 0) 
 426   
 427    function datetime -> dt 
 428      arg DateTime dt 
 429      os_gettimeofday (var os_timeval tv) (var os_timezone tz) 
 430      dt seconds := os_datetime_origin:seconds tv:tv_sec tv:tv_usec/1000000 
 431   
 432    function sleep s 
 433      arg Float s 
 434      var os_timespec spec 
 435      spec tv_sec := cast s-0.5 Int 
 436      spec tv_nsec := cast (s-spec:tv_sec)*1000^Int 
 437      if spec:tv_nsec>=1000^3 
 438        spec tv_sec := spec:tv_sec 1 ; spec tv_nsec := spec:tv_nsec 1000^3 
 439      eif spec:tv_nsec<0 
 440        spec tv_sec := spec:tv_sec 1 ; spec tv_nsec := spec:tv_nsec 1000^3 
 441      os_nanosleep spec (null map os_timespec) 
 442   
 443    export datetime sleep os_datetime_origin 
 444   
 445  eif os_api="win32" 
 446   
 447    function datetime -> dt 
 448      arg DateTime dt 
 449      os_GetSystemTime (var os_SYSTEMTIME t) 
 450      dt := datetime t:wYear t:wMonth t:wDay t:wHour t:wMinute t:wSecond t:wMilliseconds/1000 
 451   
 452    function sleep s 
 453      arg Float s 
 454      os_Sleep (cast s*1000 Int) 
 455   
 456    export datetime sleep 
 457   
 458  eif os_api="os2" 
 459   
 460    function datetime -> dt 
 461      arg DateTime dt 
 462      os_DosGetDateTime (var os_DATETIME t) 
 463      dt := datetime t:year t:month t:day t:hours t:minutes t:seconds t:hundredths/100 
 464   
 465    function sleep s 
 466      arg Float s 
 467      os_DosSleep (cast s*1000 Int) 
 468   
 469    export datetime sleep 
 470   
 471   
 472 
 
 473  #  parsing 
 474   
 475   
 476  method data 'to string' options -> s 
 477    arg Time data ; arg Str options ; arg Str s 
 478    if data=undefined 
 479      return (shunt options="db" or options="raw" "" "?") 
 480    data split (var Int hour) (var Int minute) (var Int second) (var Float fraction) 
 481    := (right (string hour) "0")+":"+(right (string minute) "0")+":"+(right (string second) "0") 
 482   
 483   
 484  method data 'from string' string options may_skip skiped offset -> status 
 485    arg_w Time data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 486    if (string eparse any:(var Str drop1) (var Int hour) ":" (var Int minute) ":" (var Int second) offset:offset any:(var Str drop2)) 
 487      skiped := drop1 len 
 488      data := time hour minute second 0 
 489      status := success 
 490    eif (string eparse any:(var Str drop1) "?" offset:offset any:(var Str drop2)) 
 491      skiped := drop1 len 
 492      data := undefined 
 493      status := success 
 494    else 
 495      data := undefined 
 496      status := shunt string="" and (options="db" or options="raw") success failure 
 497   
 498   
 499  method data 'to string' options -> s 
 500    arg Date data ; arg Str options ; arg Str s 
 501    if data=undefined 
 502      return (shunt options="db" or options="raw" "" "?") 
 503    data split (var Int year) (var Int month) (var Int day) 
 504    := (right (string year) "0")+"/"+(right (string month) "0")+"/"+(right (string day) "0") 
 505   
 506   
 507  method data 'from string' string options may_skip skiped offset -> status 
 508    arg_w Date data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 509    if (string eparse any:(var Str drop1) (var Int year) "/" (var Int month) "/" (var Int day) offset:offset any:(var Str drop2)) 
 510      skiped := drop1 len 
 511      data := date year month day 
 512      status := success 
 513    eif (string eparse any:(var Str drop1) "?" offset:offset any:(var Str drop2)) 
 514      skiped := drop1 len 
 515      data := undefined 
 516      status := success 
 517    else 
 518      data := undefined 
 519      status := shunt string="" and (options="db" or options="raw") success failure 
 520   
 521   
 522  method data 'to string' options -> s 
 523    arg DateTime data ; arg Str options ; arg Str s 
 524    if data=undefined 
 525      return (shunt options="db" or options="raw" "" "?") 
 526    data split (var Int year) (var Int month) (var Int day) (var Int hour) (var Int minute) (var Int second) (var Float fraction) 
 527    := (right (string year) "0")+"/"+(right (string month) "0")+"/"+(right (string day) "0")+" "+(right (string hour) "0")+":"+(right (string minute) "0")+":"+(right (string second) "0") 
 528   
 529   
 530  method data 'from string' string options may_skip skiped offset -> status 
 531    arg_w DateTime data ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status 
 532    if (string eparse any:(var Str drop1) (var Int year) "/" (var Int month) "/" (var Int day) _ (var Int hour) ":" (var Int minute) ":" (var Int second) offset:offset any:(var Str drop2)) 
 533      skiped := drop1 len 
 534      data := datetime year month day hour minute second 0 
 535      status := success 
 536    eif (string eparse any:(var Str drop1) "?" offset:offset any:(var Str drop2)) 
 537      skiped := drop1 len 
 538      data := undefined 
 539      status := success 
 540    else 
 541      data := undefined 
 542      status := shunt string="" and (options="db" or options="raw") success failure