/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	t seconds := undefined
33
34	function build  d
35	arg_w Date d
36	d 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 i := shunt i%2=(shunt i<=7 1 0) 31 30
50	month_max 0 := 0
51	month_max 2 := 29
52
53	(gvar Array:Int month_base) size := 13
54	for i 0 12
55	month_base i := shunt i>1 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<>0 or (year%100=0 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<1 or month>12 or day<1 or day>month_max:month
73	d days := undefined
74	return
75	var CBool norm := year_is_normal year
76	if month=2 and day=29 and norm
77	d days := undefined
78	return
79	d 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<0 or hour>=24 or minute<0 or minute>=60 or second<0 or second>=60
85	t seconds := undefined
86	return
87	t 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 d := date year month day
93	if d:days=undefined
94	dt seconds := undefined
95	return
96	var Time t := 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 r := remain - month_base:month + (shunt norm and month>2 1 0)
110	if r<0 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 r := remain-year_base:(year-1)
119	if r<0 or r>(shunt norm 364 365)
120	return false
121	month := r*2\61+1
122	if (try_month month norm r day)
123	return true
124	if (try_month month+1 norm r day)
125	month := month+1
126	return true
127	if (try_month month-1 norm r 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 := d 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+1 days month day)
140	year := year+1
141	eif (try_year year-1 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>=0 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	t 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	d days := cast dt:seconds/86400-0.5 Int
179	t seconds := dt:seconds-86400.0*d:days
180	if t:seconds<0
181	t seconds := t:seconds+86400 ; d days := d:days-1
182	eif t:seconds>=86400
183	t seconds := t:seconds-86400 ; d days := d:days+1
184	check t:seconds>=0 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 d t
192	d split year month day
193	t 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	d split y (var Int mo) (var Int da)
204
205	method d month -> m
206	arg Date d ; arg Int m
207	d split (var Int ye) m (var Int da)
208
209	method d day -> da
210	arg Date d ; arg Int da
211	d 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 0 := "sunday"
223	day_name 1 := "monday"
224	day_name 2 := "tuesday"
225	day_name 3 := "wednesday"
226	day_name 4 := "thursday"
227	day_name 5 := "friday"
228	day_name 6 := "saturday"
229
230
231	method t hour -> h
232	arg Time t ; arg Int h
233	t split (var Int seconds) (var Float fraction)
234	if seconds=defined
235	h := seconds\3600
236	else
237	h := undefined
238
239	method t minute -> m
240	arg Time t ; arg Int m
241	t split (var Int seconds) (var Float fraction)
242	if seconds=defined
243	m := seconds\60%60
244	else
245	m := undefined
246
247	method t second -> s
248	arg Time t ; arg Int s
249	t split (var Int seconds) (var Float fraction)
250	if seconds=defined
251	s := seconds%60
252	else
253	s := undefined
254
255	method t fraction -> f
256	arg Time t ; arg Float f
257	t 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	y := dt:date year
271
272	method dt month -> m
273	arg DateTime dt ; arg Int m
274	m := dt:date month
275
276	method dt day -> d
277	arg DateTime dt ; arg Int d
278	d := 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	h := dt:time hour
287
288	method dt minute -> m
289	arg DateTime dt ; arg Int m
290	m := dt:time minute
291
292	method dt second -> s
293	arg DateTime dt ; arg Int s
294	s := dt:time second
295
296	method dt fraction -> f
297	arg DateTime dt ; arg Float f
298	f := dt:time fraction
299
300
301
302	#  comparing
303
304
305	function compare a b -> c
306	arg Date a b ; arg Int c
307	c := compare a:days b:days
308
309	function compare a b -> c
310	arg Time a b ; arg Int c
311	c := compare a:seconds b:seconds
312
313	function compare a b -> c
314	arg DateTime a b ; arg Int c
315	c := 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	s := 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	d days := undefined
389
390
391	function 'cast Status' t -> s
392	arg Time t ; arg Status s
393	explicit
394	s := 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	t seconds := undefined
402
403
404	function 'cast Status' dt -> s
405	arg DateTime dt ; arg Status s
406	s := 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^3 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	s := (right (string hour) 2 "0")+":"+(right (string minute) 2 "0")+":"+(right (string second) 2 "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	s := (right (string year) 4 "0")+"/"+(right (string month) 2 "0")+"/"+(right (string day) 2 "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	s := (right (string year) 4 "0")+"/"+(right (string month) 2 "0")+"/"+(right (string day) 2 "0")+" "+(right (string hour) 2 "0")+":"+(right (string minute) 2 "0")+":"+(right (string second) 2 "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