steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

calendar: value checking to make it hard to create invalid timestamps

char-rename
Björn Lindqvist 2017-01-05 13:28:13 +01:00
parent 48c69cb8ea
commit 4c097a396a
3 changed files with 46 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/calendar/calendar-docs.factor
View File

@ -304,14 +304,6 @@ HELP: before
}
} ;
HELP: <zero>
{ $values { "timestamp" timestamp } }
{ $description "Returns a zero timestamp that consists of zeros for every slot. Used to see if timestamps are valid." } ;
HELP: valid-timestamp?
{ $values { "timestamp" timestamp } { "?" boolean } }
{ $description "Tests if a timestamp is valid or not." } ;
HELP: unix-1970
{ $values { "timestamp" timestamp } }
{ $description "Returns the beginning of UNIX time, or midnight, January 1, 1970." } ;

26
basis/calendar/calendar-tests.factor
View File

@ -1,15 +1,17 @@
USING: accessors kernel math.order random threads tools.test ;
IN: calendar
{ f } [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
{ f } [ 2004 2 30 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
{ f } [ 2003 2 29 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
{ f } [ 2004 -2 9 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
{ f } [ 2004 12 0 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
{ f } [ 2004 12 1 24 0 0 instant <timestamp> valid-timestamp? ] unit-test
{ f } [ 2004 12 1 23 60 0 instant <timestamp> valid-timestamp? ] unit-test
{ f } [ 2004 12 1 23 59 60 instant <timestamp> valid-timestamp? ] unit-test
{ t } [ now valid-timestamp? ] unit-test
[ 2004 12 32 0 0 0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
[ 2004 2 30 0 0 0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
[ 2003 2 29 0 0 0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
[ 2004 -2 9 0 0 0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
[ 2004 12 0 0 0 0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
[ 2004 12 1 24 0 0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
[ 2004 12 1 23 60 0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
[ 2004 12 1 23 59 60 instant <timestamp> ] [ not-in-interval? ] must-fail-with
{ } [
2014 12 1 23 59 59+99/100 instant <timestamp> drop
] unit-test
{ f } [ 1900 leap-year? ] unit-test
{ t } [ 1904 leap-year? ] unit-test
@ -186,3 +188,9 @@ IN: calendar
{ 0 }
[ gmt gmt-offset>> duration>seconds ] unit-test
! am
[ now 30 am ] [ not-in-interval? ] must-fail-with
! pm
[ now 30 pm ] [ not-in-interval? ] must-fail-with

58
basis/calendar/calendar.factor
View File

@ -2,10 +2,15 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.tuple combinators
combinators.short-circuit kernel locals math math.functions
math.order sequences summary system vocabs vocabs.loader
math.intervals math.order sequences summary system vocabs vocabs.loader
assocs ;
IN: calendar
ERROR: not-in-interval value interval ;
: check-interval ( value interval -- value )
2dup interval-contains? [ drop ] [ not-in-interval ] if ;
HOOK: gmt-offset os ( -- hours minutes seconds )
HOOK: gmt os ( -- timestamp )
@ -31,7 +36,27 @@ TUPLE: timestamp
{ second real }
{ gmt-offset duration } ;
C: <timestamp> timestamp
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
dup 100 divisor? 400 4 ? divisor? ;
M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ;
: (days-in-month) ( year month -- n )
dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
:: <timestamp> ( year month day hour minute second gmt-offset -- timestamp )
year
month 1 12 [a,b] check-interval
day 1 year month (days-in-month) [a,b] check-interval
hour 0 23 [a,b] check-interval
minute 0 59 [a,b] check-interval
second 0 60 [a,b) check-interval
gmt-offset timestamp boa ;
M: timestamp clone (clone) [ clone ] change-gmt-offset ;
@ -50,8 +75,6 @@ M: timestamp clone (clone) [ clone ] change-gmt-offset ;
: <year-gmt> ( year -- timestamp )
1 1 <date-gmt> ; inline
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
CONSTANT: average-month 30+5/12
CONSTANT: months-per-year 12
CONSTANT: days-per-year 3652425/10000
@ -123,14 +146,6 @@ M: timestamp easter ( timestamp -- timestamp )
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
dup 100 divisor? 400 4 ? divisor? ;
M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ;
<PRIVATE
GENERIC: +year ( timestamp x -- timestamp )
@ -327,13 +342,6 @@ M: duration time-
2drop <duration>
] if ;
: <zero> ( -- timestamp )
0 0 0 <date-gmt> ; inline
: valid-timestamp? ( timestamp -- ? )
clone instant >>gmt-offset
dup <zero> time- <zero> time+ = ;
: unix-1970 ( -- timestamp )
1970 <year-gmt> ; inline
@ -371,9 +379,6 @@ GENERIC: days-in-year ( obj -- n )
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ;
M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: (days-in-month) ( year month -- n )
dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
: days-in-month ( timestamp -- n )
>date< drop (days-in-month) ;
@ -507,16 +512,11 @@ M: timestamp december clone 12 >>month ;
: o'clock ( timestamp n -- new-timestamp )
[ midnight ] dip >>hour ;
ERROR: twelve-hour-expected n ;
: check-twelve-hour ( n -- n )
dup 0 12 between? [ twelve-hour-expected ] unless ;
: am ( timestamp n -- new-timestamp )
check-twelve-hour o'clock ;
0 12 [a,b] check-interval o'clock ;
: pm ( timestamp n -- new-timestamp )
check-twelve-hour 12 + o'clock ;
0 12 [a,b] check-interval 12 + o'clock ;
GENERIC: beginning-of-year ( object -- new-timestamp )
M: timestamp beginning-of-year beginning-of-month 1 >>month ;