123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695 |
- #----------------------------------------------------------------------
- #
- # clock.tcl --
- #
- # This file implements the portions of the [clock] ensemble that
- # are coded in Tcl. Refer to the users' manual to see the description
- # of the [clock] command and its subcommands.
- #
- #
- #----------------------------------------------------------------------
- #
- # Copyright (c) 2004,2005,2006,2007 by Kevin B. Kenny
- # See the file "license.terms" for information on usage and redistribution
- # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- #
- #----------------------------------------------------------------------
- # We must have message catalogs that support the root locale, and
- # we need access to the Registry on Windows systems.
- uplevel \#0 {
- package require msgcat 1.4
- if { $::tcl_platform(platform) eq {windows} } {
- if { [catch { package require registry 1.1 }] } {
- namespace eval ::tcl::clock [list variable NoRegistry {}]
- }
- }
- }
- # Put the library directory into the namespace for the ensemble
- # so that the library code can find message catalogs and time zone
- # definition files.
- namespace eval ::tcl::clock \
- [list variable LibDir [file dirname [info script]]]
- #----------------------------------------------------------------------
- #
- # clock --
- #
- # Manipulate times.
- #
- # The 'clock' command manipulates time. Refer to the user documentation
- # for the available subcommands and what they do.
- #
- #----------------------------------------------------------------------
- namespace eval ::tcl::clock {
- # Export the subcommands
- namespace export format
- namespace export clicks
- namespace export microseconds
- namespace export milliseconds
- namespace export scan
- namespace export seconds
- namespace export add
- # Import the message catalog commands that we use.
- namespace import ::msgcat::mcload
- namespace import ::msgcat::mclocale
- }
- #----------------------------------------------------------------------
- #
- # ::tcl::clock::Initialize --
- #
- # Finish initializing the 'clock' subsystem
- #
- # Results:
- # None.
- #
- # Side effects:
- # Namespace variable in the 'clock' subsystem are initialized.
- #
- # The '::tcl::clock::Initialize' procedure initializes the namespace
- # variables and root locale message catalog for the 'clock' subsystem.
- # It is broken into a procedure rather than simply evaluated as a script
- # so that it will be able to use local variables, avoiding the dangers
- # of 'creative writing' as in Bug 1185933.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::Initialize {} {
- rename ::tcl::clock::Initialize {}
- variable LibDir
- # Define the Greenwich time zone
- proc InitTZData {} {
- variable TZData
- array unset TZData
- set TZData(:Etc/GMT) {
- {-9223372036854775808 0 0 GMT}
- }
- set TZData(:GMT) $TZData(:Etc/GMT)
- set TZData(:Etc/UTC) {
- {-9223372036854775808 0 0 UTC}
- }
- set TZData(:UTC) $TZData(:Etc/UTC)
- set TZData(:localtime) {}
- }
- InitTZData
- # Define the message catalog for the root locale.
- ::msgcat::mcmset {} {
- AM {am}
- BCE {B.C.E.}
- CE {C.E.}
- DATE_FORMAT {%m/%d/%Y}
- DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
- DAYS_OF_WEEK_ABBREV {
- Sun Mon Tue Wed Thu Fri Sat
- }
- DAYS_OF_WEEK_FULL {
- Sunday Monday Tuesday Wednesday Thursday Friday Saturday
- }
- GREGORIAN_CHANGE_DATE 2299161
- LOCALE_DATE_FORMAT {%m/%d/%Y}
- LOCALE_DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y}
- LOCALE_ERAS {}
- LOCALE_NUMERALS {
- 00 01 02 03 04 05 06 07 08 09
- 10 11 12 13 14 15 16 17 18 19
- 20 21 22 23 24 25 26 27 28 29
- 30 31 32 33 34 35 36 37 38 39
- 40 41 42 43 44 45 46 47 48 49
- 50 51 52 53 54 55 56 57 58 59
- 60 61 62 63 64 65 66 67 68 69
- 70 71 72 73 74 75 76 77 78 79
- 80 81 82 83 84 85 86 87 88 89
- 90 91 92 93 94 95 96 97 98 99
- }
- LOCALE_TIME_FORMAT {%H:%M:%S}
- LOCALE_YEAR_FORMAT {%EC%Ey}
- MONTHS_ABBREV {
- Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
- }
- MONTHS_FULL {
- January February March
- April May June
- July August September
- October November December
- }
- PM {pm}
- TIME_FORMAT {%H:%M:%S}
- TIME_FORMAT_12 {%I:%M:%S %P}
- TIME_FORMAT_24 {%H:%M}
- TIME_FORMAT_24_SECS {%H:%M:%S}
- }
- # Define a few Gregorian change dates for other locales. In most cases
- # the change date follows a language, because a nation's colonies changed
- # at the same time as the nation itself. In many cases, different
- # national boundaries existed; the dominating rule is to follow the
- # nation's capital.
- # Italy, Spain, Portugal, Poland
- ::msgcat::mcset it GREGORIAN_CHANGE_DATE 2299161
- ::msgcat::mcset es GREGORIAN_CHANGE_DATE 2299161
- ::msgcat::mcset pt GREGORIAN_CHANGE_DATE 2299161
- ::msgcat::mcset pl GREGORIAN_CHANGE_DATE 2299161
- # France, Austria
- ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227
- # For Belgium, we follow Southern Netherlands; Liege Diocese
- # changed several weeks later.
- ::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238
- ::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238
- # Austria
- ::msgcat::mcset de_AT GREGORIAN_CHANGE_DATE 2299527
- # Hungary
- ::msgcat::mcset hu GREGORIAN_CHANGE_DATE 2301004
- # Germany, Norway, Denmark (Catholic Germany changed earlier)
- ::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032
- ::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032
- # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed
- # at various times)
- ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165
- # Protestant Switzerland (Catholic cantons changed earlier)
- ::msgcat::mcset fr_CH GREGORIAN_CHANGE_DATE 2361342
- ::msgcat::mcset it_CH GREGORIAN_CHANGE_DATE 2361342
- ::msgcat::mcset de_CH GREGORIAN_CHANGE_DATE 2361342
- # English speaking countries
- ::msgcat::mcset en GREGORIAN_CHANGE_DATE 2361222
- # Sweden (had several changes onto and off of the Gregorian calendar)
- ::msgcat::mcset sv GREGORIAN_CHANGE_DATE 2361390
- # Russia
- ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639
- # Romania (Transylvania changed earler - perhaps de_RO should show
- # the earlier date?)
- ::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063
- # Greece
- ::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480
-
- #------------------------------------------------------------------
- #
- # CONSTANTS
- #
- #------------------------------------------------------------------
- # Paths at which binary time zone data for the Olson libraries
- # are known to reside on various operating systems
- variable ZoneinfoPaths {}
- foreach path {
- /usr/share/zoneinfo
- /usr/share/lib/zoneinfo
- /usr/lib/zoneinfo
- /usr/local/etc/zoneinfo
- } {
- if { [file isdirectory $path] } {
- lappend ZoneinfoPaths $path
- }
- }
- # Define the directories for time zone data and message catalogs.
- variable DataDir [file join $LibDir tzdata]
- variable MsgDir [file join $LibDir msgs]
- # Number of days in the months, in common years and leap years.
- variable DaysInRomanMonthInCommonYear \
- { 31 28 31 30 31 30 31 31 30 31 30 31 }
- variable DaysInRomanMonthInLeapYear \
- { 31 29 31 30 31 30 31 31 30 31 30 31 }
- variable DaysInPriorMonthsInCommonYear [list 0]
- variable DaysInPriorMonthsInLeapYear [list 0]
- set i 0
- foreach j $DaysInRomanMonthInCommonYear {
- lappend DaysInPriorMonthsInCommonYear [incr i $j]
- }
- set i 0
- foreach j $DaysInRomanMonthInLeapYear {
- lappend DaysInPriorMonthsInLeapYear [incr i $j]
- }
- # Another epoch (Hi, Jeff!)
- variable Roddenberry 1946
- # Integer ranges
- variable MINWIDE -9223372036854775808
- variable MAXWIDE 9223372036854775807
- # Day before Leap Day
- variable FEB_28 58
- # Translation table to map Windows TZI onto cities, so that
- # the Olson rules can apply. In some cases the mapping is ambiguous,
- # so it's wise to specify $::env(TCL_TZ) rather than simply depending
- # on the system time zone.
- # The keys are long lists of values obtained from the time zone
- # information in the Registry. In order, the list elements are:
- # Bias StandardBias DaylightBias
- # StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek
- # StandardDate.wDay StandardDate.wHour StandardDate.wMinute
- # StandardDate.wSecond StandardDate.wMilliseconds
- # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
- # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
- # DaylightDate.wSecond DaylightDate.wMilliseconds
- # The values are the names of time zones where those rules apply.
- # There is considerable ambiguity in certain zones; an attempt has
- # been made to make a reasonable guess, but this table needs to be
- # taken with a grain of salt.
- variable WinZoneInfo [dict create {*}{
- {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein
- {-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway
- {-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu
- {-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage
- {-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles
- {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana
- {-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver
- {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua
- {-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix
- {-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina
- {-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago
- {-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City
- {-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York
- {-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis
- {-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas
- {-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999}
- :America/Santiago
- {-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus
- {-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax
- {-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns
- {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo
- {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab
- {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires
- {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia
- {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo
- {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha
- {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores
- {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde
- {0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC
- {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London
- {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa
- {3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET
- {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare
- {7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0}
- :Africa/Cairo
- {7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki
- {7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem
- {7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest
- {7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens
- {7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman
- {7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0}
- :Asia/Beirut
- {7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek
- {10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh
- {10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad
- {10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow
- {12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran
- {14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku
- {14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat
- {14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi
- {16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul
- {18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Karachi
- {18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yekaterinburg
- {19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Calcutta
- {20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Katmandu
- {21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Dhaka
- {21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Novosibirsk
- {23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Rangoon
- {25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Bangkok
- {25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Krasnoyarsk
- {28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Chongqing
- {28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Irkutsk
- {32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Tokyo
- {32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yakutsk
- {34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Adelaide
- {34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Darwin
- {36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Brisbane
- {36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Vladivostok
- {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0} :Australia/Hobart
- {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney
- {39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea
- {43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland
- {43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji
- {46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
- }]
- # Groups of fields that specify the date, priorities, and
- # code bursts that determine Julian Day Number given those groups.
- # The code in [clock scan] will choose the highest priority
- # (lowest numbered) set of fields that determines the date.
- variable DateParseActions {
- { seconds } 0 {}
- { julianDay } 1 {}
- { era century yearOfCentury month dayOfMonth } 2 {
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { era century yearOfCentury dayOfYear } 2 {
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
- { century yearOfCentury month dayOfMonth } 3 {
- dict set date era CE
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { century yearOfCentury dayOfYear } 3 {
- dict set date era CE
- dict set date year [expr { 100 * [dict get $date century]
- + [dict get $date yearOfCentury] }]
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
- { iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 3 {
- dict set date era CE
- dict set date iso8601Year \
- [expr { 100 * [dict get $date iso8601Century]
- + [dict get $date iso8601YearOfCentury] }]
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
- { yearOfCentury month dayOfMonth } 4 {
- set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
- dict set date era CE
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { yearOfCentury dayOfYear } 4 {
- set date [InterpretTwoDigitYear $date[set date {}] $baseTime]
- dict set date era CE
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
- { iso8601YearOfCentury iso8601Week dayOfWeek } 4 {
- set date [InterpretTwoDigitYear \
- $date[set date {}] $baseTime \
- iso8601YearOfCentury iso8601Year]
- dict set date era CE
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
- { month dayOfMonth } 5 {
- set date [AssignBaseYear $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { dayOfYear } 5 {
- set date [AssignBaseYear $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearDay $date[set date {}] \
- $changeover]
- }
- { iso8601Week dayOfWeek } 5 {
- set date [AssignBaseIso8601Year $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
- { dayOfMonth } 6 {
- set date [AssignBaseMonth $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \
- $changeover]
- }
- { dayOfWeek } 7 {
- set date [AssignBaseWeek $date[set date {}] \
- $baseTime $timeZone $changeover]
- set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \
- $changeover]
- }
- {} 8 {
- set date [AssignBaseJulianDay $date[set date {}] \
- $baseTime $timeZone $changeover]
- }
- }
- # Groups of fields that specify time of day, priorities,
- # and code that processes them
- variable TimeParseActions {
- seconds 1 {}
- { hourAMPM minute second amPmIndicator } 2 {
- dict set date secondOfDay [InterpretHMSP $date]
- }
- { hour minute second } 2 {
- dict set date secondOfDay [InterpretHMS $date]
- }
- { hourAMPM minute amPmIndicator } 3 {
- dict set date second 0
- dict set date secondOfDay [InterpretHMSP $date]
- }
- { hour minute } 3 {
- dict set date second 0
- dict set date secondOfDay [InterpretHMS $date]
- }
- { hourAMPM amPmIndicator } 4 {
- dict set date minute 0
- dict set date second 0
- dict set date secondOfDay [InterpretHMSP $date]
- }
- { hour } 4 {
- dict set date minute 0
- dict set date second 0
- dict set date secondOfDay [InterpretHMS $date]
- }
- { } 5 {
- dict set date secondOfDay 0
- }
- }
- # Legacy time zones, used primarily for parsing RFC822 dates.
- variable LegacyTimeZone [dict create \
- gmt +0000 \
- ut +0000 \
- utc +0000 \
- bst +0100 \
- wet +0000 \
- wat -0100 \
- at -0200 \
- nft -0330 \
- nst -0330 \
- ndt -0230 \
- ast -0400 \
- adt -0300 \
- est -0500 \
- edt -0400 \
- cst -0600 \
- cdt -0500 \
- mst -0700 \
- mdt -0600 \
- pst -0800 \
- pdt -0700 \
- yst -0900 \
- ydt -0800 \
- hst -1000 \
- hdt -0900 \
- cat -1000 \
- ahst -1000 \
- nt -1100 \
- idlw -1200 \
- cet +0100 \
- cest +0200 \
- met +0100 \
- mewt +0100 \
- mest +0200 \
- swt +0100 \
- sst +0200 \
- fwt +0100 \
- fst +0200 \
- eet +0200 \
- eest +0300 \
- bt +0300 \
- it +0330 \
- zp4 +0400 \
- zp5 +0500 \
- ist +0530 \
- zp6 +0600 \
- wast +0700 \
- wadt +0800 \
- jt +0730 \
- cct +0800 \
- jst +0900 \
- kst +0900 \
- cast +0930 \
- jdt +1000 \
- kdt +1000 \
- cadt +1030 \
- east +1000 \
- eadt +1030 \
- gst +1000 \
- nzt +1200 \
- nzst +1200 \
- nzdt +1300 \
- idle +1200 \
- a +0100 \
- b +0200 \
- c +0300 \
- d +0400 \
- e +0500 \
- f +0600 \
- g +0700 \
- h +0800 \
- i +0900 \
- k +1000 \
- l +1100 \
- m +1200 \
- n -0100 \
- o -0200 \
- p -0300 \
- q -0400 \
- r -0500 \
- s -0600 \
- t -0700 \
- u -0800 \
- v -0900 \
- w -1000 \
- x -1100 \
- y -1200 \
- z +0000 \
- ]
- # Caches
- variable LocaleNumeralCache {}; # Dictionary whose keys are locale
- # names and whose values are pairs
- # comprising regexes matching numerals
- # in the given locales and dictionaries
- # mapping the numerals to their numeric
- # values.
- variable McLoaded {}; # Dictionary whose keys are locales
- # in which [mcload] has been executed
- # and whose values are second-level
- # dictionaries indexed by message
- # name and giving message text.
- # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists,
- # it contains the value of the
- # system time zone, as determined from
- # the environment.
- variable TimeZoneBad {}; # Dictionary whose keys are time zone
- # names and whose values are 1 if
- # the time zone is unknown and 0
- # if it is known.
- variable TZData; # Array whose keys are time zone names
- # and whose values are lists of quads
- # comprising start time, UTC offset,
- # Daylight Saving Time indicator, and
- # time zone abbreviation.
- variable FormatProc; # Array mapping format group
- # and locale to the name of a procedure
- # that renders the given format
- }
- ::tcl::clock::Initialize
- #----------------------------------------------------------------------
- #
- # clock format --
- #
- # Formats a count of seconds since the Posix Epoch as a time
- # of day.
- #
- # The 'clock format' command formats times of day for output.
- # Refer to the user documentation to see what it does.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::format { args } {
- variable FormatProc
- variable TZData
- lassign [ParseFormatArgs {*}$args] format locale timezone
- set locale [string tolower $locale]
- set clockval [lindex $args 0]
- # Get the data for time changes in the given zone
-
- if {$timezone eq ""} {
- set timezone [GetSystemTimeZone]
- }
- if {![info exists TZData($timezone)]} {
- if {[catch {SetupTimeZone $timezone} retval opts]} {
- dict unset opts -errorinfo
- return -options $opts $retval
- }
- }
-
- # Build a procedure to format the result. Cache the built procedure's
- # name in the 'FormatProc' array to avoid losing its internal
- # representation, which contains the name resolution.
-
- set procName formatproc'$format'$locale
- set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
- if {[info exists FormatProc($procName)]} {
- set procName $FormatProc($procName)
- } else {
- set FormatProc($procName) \
- [ParseClockFormatFormat $procName $format $locale]
- }
-
- return [$procName $clockval $timezone]
- }
- #----------------------------------------------------------------------
- #
- # ParseClockFormatFormat --
- #
- # Builds and caches a procedure that formats a time value.
- #
- # Parameters:
- # format -- Format string to use
- # locale -- Locale in which the format string is to be interpreted
- #
- # Results:
- # Returns the name of the newly-built procedure.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ParseClockFormatFormat {procName format locale} {
- if {[namespace which $procName] ne {}} {
- return $procName
- }
- # Map away the locale-dependent composite format groups
-
- EnterLocale $locale oldLocale
- # Change locale if a fresh locale has been given on the command line.
- set status [catch {
- ParseClockFormatFormat2 $format $locale $procName
- } result opts]
- # Restore the locale
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
- # Return either the error or the proc name
- if { $status == 1 } {
- if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
- return -code error $result
- } else {
- return -options $opts $result
- }
- } else {
- return $result
- }
- }
- proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
- set didLocaleEra 0
- set didLocaleNumerals 0
- set preFormatCode \
- [string map [list @GREGORIAN_CHANGE_DATE@ \
- [mc GREGORIAN_CHANGE_DATE]] \
- {
- variable TZData
- set date [GetDateFields $clockval \
- $TZData($timezone) \
- @GREGORIAN_CHANGE_DATE@]
- }]
- set formatString {}
- set substituents {}
- set state {}
-
- set format [LocalizeFormat $locale $format]
- foreach char [split $format {}] {
- switch -exact -- $state {
- {} {
- if { [string equal % $char] } {
- set state percent
- } else {
- append formatString $char
- }
- }
- percent { # Character following a '%' character
- set state {}
- switch -exact -- $char {
- % { # A literal character, '%'
- append formatString %%
- }
- a { # Day of week, abbreviated
- append formatString %s
- append substituents \
- [string map \
- [list @DAYS_OF_WEEK_ABBREV@ \
- [list [mc DAYS_OF_WEEK_ABBREV]]] \
- { [lindex @DAYS_OF_WEEK_ABBREV@ \
- [expr {[dict get $date dayOfWeek] \
- % 7}]]}]
- }
- A { # Day of week, spelt out.
- append formatString %s
- append substituents \
- [string map \
- [list @DAYS_OF_WEEK_FULL@ \
- [list [mc DAYS_OF_WEEK_FULL]]] \
- { [lindex @DAYS_OF_WEEK_FULL@ \
- [expr {[dict get $date dayOfWeek] \
- % 7}]]}]
- }
- b - h { # Name of month, abbreviated.
- append formatString %s
- append substituents \
- [string map \
- [list @MONTHS_ABBREV@ \
- [list [mc MONTHS_ABBREV]]] \
- { [lindex @MONTHS_ABBREV@ \
- [expr {[dict get $date month]-1}]]}]
- }
- B { # Name of month, spelt out
- append formatString %s
- append substituents \
- [string map \
- [list @MONTHS_FULL@ \
- [list [mc MONTHS_FULL]]] \
- { [lindex @MONTHS_FULL@ \
- [expr {[dict get $date month]-1}]]}]
- }
- C { # Century number
- append formatString %02d
- append substituents \
- { [expr {[dict get $date year] / 100}]}
- }
- d { # Day of month, with leading zero
- append formatString %02d
- append substituents { [dict get $date dayOfMonth]}
- }
- e { # Day of month, without leading zero
- append formatString %2d
- append substituents { [dict get $date dayOfMonth]}
- }
- E { # Format group in a locale-dependent
- # alternative era
- set state percentE
- if {!$didLocaleEra} {
- append preFormatCode \
- [string map \
- [list @LOCALE_ERAS@ \
- [list [mc LOCALE_ERAS]]] \
- {
- set date [GetLocaleEra \
- $date[set date {}] \
- @LOCALE_ERAS@]}] \n
- set didLocaleEra 1
- }
- if {!$didLocaleNumerals} {
- append preFormatCode \
- [list set localeNumerals \
- [mc LOCALE_NUMERALS]] \n
- set didLocaleNumerals 1
- }
- }
- g { # Two-digit year relative to ISO8601
- # week number
- append formatString %02d
- append substituents \
- { [expr { [dict get $date iso8601Year] % 100 }]}
- }
- G { # Four-digit year relative to ISO8601
- # week number
- append formatString %02d
- append substituents { [dict get $date iso8601Year]}
- }
- H { # Hour in the 24-hour day, leading zero
- append formatString %02d
- append substituents \
- { [expr { [dict get $date localSeconds] \
- / 3600 % 24}]}
- }
- I { # Hour AM/PM, with leading zero
- append formatString %02d
- append substituents \
- { [expr { ( ( ( [dict get $date localSeconds] \
- % 86400 ) \
- + 86400 \
- - 3600 ) \
- / 3600 ) \
- % 12 + 1 }] }
- }
- j { # Day of year (001-366)
- append formatString %03d
- append substituents { [dict get $date dayOfYear]}
- }
- J { # Julian Day Number
- append formatString %07ld
- append substituents { [dict get $date julianDay]}
- }
- k { # Hour (0-23), no leading zero
- append formatString %2d
- append substituents \
- { [expr { [dict get $date localSeconds]
- / 3600
- % 24 }]}
- }
- l { # Hour (12-11), no leading zero
- append formatString %2d
- append substituents \
- { [expr { ( ( ( [dict get $date localSeconds]
- % 86400 )
- + 86400
- - 3600 )
- / 3600 )
- % 12 + 1 }]}
- }
- m { # Month number, leading zero
- append formatString %02d
- append substituents { [dict get $date month]}
- }
- M { # Minute of the hour, leading zero
- append formatString %02d
- append substituents \
- { [expr { [dict get $date localSeconds]
- / 60
- % 60 }]}
- }
- n { # A literal newline
- append formatString \n
- }
- N { # Month number, no leading zero
- append formatString %2d
- append substituents { [dict get $date month]}
- }
- O { # A format group in the locale's
- # alternative numerals
- set state percentO
- if {!$didLocaleNumerals} {
- append preFormatCode \
- [list set localeNumerals \
- [mc LOCALE_NUMERALS]] \n
- set didLocaleNumerals 1
- }
- }
- p { # Localized 'AM' or 'PM' indicator
- # converted to uppercase
- append formatString %s
- append preFormatCode \
- [list set AM [string toupper [mc AM]]] \n \
- [list set PM [string toupper [mc PM]]] \n
- append substituents \
- { [expr {(([dict get $date localSeconds]
- % 86400) < 43200) ?
- $AM : $PM}]}
- }
- P { # Localized 'AM' or 'PM' indicator
- append formatString %s
- append preFormatCode \
- [list set am [mc AM]] \n \
- [list set pm [mc PM]] \n
- append substituents \
- { [expr {(([dict get $date localSeconds]
- % 86400) < 43200) ?
- $am : $pm}]}
-
- }
- Q { # Hi, Jeff!
- append formatString %s
- append substituents { [FormatStarDate $date]}
- }
- s { # Seconds from the Posix Epoch
- append formatString %s
- append substituents { [dict get $date seconds]}
- }
- S { # Second of the minute, with
- # leading zero
- append formatString %02d
- append substituents \
- { [expr { [dict get $date localSeconds]
- % 60 }]}
- }
- t { # A literal tab character
- append formatString \t
- }
- u { # Day of the week (1-Monday, 7-Sunday)
- append formatString %1d
- append substituents { [dict get $date dayOfWeek]}
- }
- U { # Week of the year (00-53). The
- # first Sunday of the year is the
- # first day of week 01
- append formatString %02d
- append preFormatCode {
- set dow [dict get $date dayOfWeek]
- if { $dow == 7 } {
- set dow 0
- }
- incr dow
- set UweekNumber \
- [expr { ( [dict get $date dayOfYear]
- - $dow + 7 )
- / 7 }]
- }
- append substituents { $UweekNumber}
- }
- V { # The ISO8601 week number
- append formatString %02d
- append substituents { [dict get $date iso8601Week]}
- }
- w { # Day of the week (0-Sunday,
- # 6-Saturday)
- append formatString %1d
- append substituents \
- { [expr { [dict get $date dayOfWeek] % 7 }]}
- }
- W { # Week of the year (00-53). The first
- # Monday of the year is the first day
- # of week 01.
- append preFormatCode {
- set WweekNumber \
- [expr { ( [dict get $date dayOfYear]
- - [dict get $date dayOfWeek]
- + 7 )
- / 7 }]
- }
- append formatString %02d
- append substituents { $WweekNumber}
- }
- y { # The two-digit year of the century
- append formatString %02d
- append substituents \
- { [expr { [dict get $date year] % 100 }]}
- }
- Y { # The four-digit year
- append formatString %04d
- append substituents { [dict get $date year]}
- }
- z { # The time zone as hours and minutes
- # east (+) or west (-) of Greenwich
- append formatString %s
- append substituents { [FormatNumericTimeZone \
- [dict get $date tzOffset]]}
- }
- Z { # The name of the time zone
- append formatString %s
- append substituents { [dict get $date tzName]}
- }
- % { # A literal percent character
- append formatString %%
- }
- default { # An unknown escape sequence
- append formatString %% $char
- }
- }
- }
- percentE { # Character following %E
- set state {}
- switch -exact -- $char {
- E {
- append formatString %s
- append substituents { } \
- [string map \
- [list @BCE@ [list [mc BCE]] \
- @CE@ [list [mc CE]]] \
- {[dict get {BCE @BCE@ CE @CE@} \
- [dict get $date era]]}]
- }
- C { # Locale-dependent era
- append formatString %s
- append substituents { [dict get $date localeEra]}
- }
- y { # Locale-dependent year of the era
- append preFormatCode {
- set y [dict get $date localeYear]
- if { $y >= 0 && $y < 100 } {
- set Eyear [lindex $localeNumerals $y]
- } else {
- set Eyear $y
- }
- }
- append formatString %s
- append substituents { $Eyear}
- }
- default { # Unknown %E format group
- append formatString %%E $char
- }
- }
- }
- percentO { # Character following %O
- set state {}
- switch -exact -- $char {
- d - e { # Day of the month in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [dict get $date dayOfMonth]]}
- }
- H - k { # Hour of the day in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date localSeconds]
- / 3600
- % 24 }]]}
- }
- I - l { # Hour (12-11) AM/PM in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { ( ( ( [dict get $date localSeconds]
- % 86400 )
- + 86400
- - 3600 )
- / 3600 )
- % 12 + 1 }]]}
- }
- m { # Month number in alternative numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals [dict get $date month]]}
- }
- M { # Minute of the hour in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date localSeconds]
- / 60
- % 60 }]]}
- }
- S { # Second of the minute in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date localSeconds]
- % 60 }]]}
- }
- u { # Day of the week (Monday=1,Sunday=7)
- # in alternative numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [dict get $date dayOfWeek]]}
- }
- w { # Day of the week (Sunday=0,Saturday=6)
- # in alternative numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date dayOfWeek] % 7 }]]}
- }
- y { # Year of the century in alternative
- # numerals
- append formatString %s
- append substituents \
- { [lindex $localeNumerals \
- [expr { [dict get $date year] % 100 }]]}
- }
- default { # Unknown format group
- append formatString %%O $char
- }
- }
- }
- }
- }
-
- # Clean up any improperly terminated groups
-
- switch -exact -- $state {
- percent {
- append formatString %%
- }
- percentE {
- append retval %%E
- }
- percentO {
- append retval %%O
- }
- }
- proc $procName {clockval timezone} "
- $preFormatCode
- return \[::format [list $formatString] $substituents\]
- "
- # puts [list $procName [info args $procName] [info body $procName]]
- return $procName
- }
- #----------------------------------------------------------------------
- #
- # clock scan --
- #
- # Inputs a count of seconds since the Posix Epoch as a time
- # of day.
- #
- # The 'clock format' command scans times of day on input.
- # Refer to the user documentation to see what it does.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::scan { args } {
- set format {}
- # Check the count of args
- if { [llength $args] < 1 || [llength $args] % 2 != 1 } {
- set cmdName "clock scan"
- return -code error \
- -errorcode [list CLOCK wrongNumArgs] \
- "wrong \# args: should be\
- \"$cmdName string\
- ?-base seconds?\
- ?-format string? ?-gmt boolean?\
- ?-locale LOCALE? ?-timezone ZONE?\""
- }
- # Set defaults
- set base [clock seconds]
- set string [lindex $args 0]
- set format {}
- set gmt 0
- set locale c
- set timezone [GetSystemTimeZone]
- # Pick up command line options.
- foreach { flag value } [lreplace $args 0 0] {
- set saw($flag) {}
- switch -exact -- $flag {
- -b - -ba - -bas - -base {
- set base $value
- }
- -f - -fo - -for - -form - -forma - -format {
- set format $value
- }
- -g - -gm - -gmt {
- set gmt $value
- }
- -l - -lo - -loc - -loca - -local - -locale {
- set locale [string tolower $value]
- }
- -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone {
- set timezone $value
- }
- default {
- return -code error \
- -errorcode [list CLOCK badSwitch $flag] \
- "bad switch \"$flag\",\
- must be -base, -format, -gmt, -locale or -timezone"
- }
- }
- }
- # Check options for validity
- if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
- return -code error \
- -errorcode [list CLOCK gmtWithTimezone] \
- "cannot use -gmt and -timezone in same call"
- }
- if { [catch { expr { wide($base) } } result] } {
- return -code error \
- "expected integer but got \"$base\""
- }
- if { ![string is boolean $gmt] } {
- return -code error \
- "expected boolean value but got \"$gmt\""
- } else {
- if { $gmt } {
- set timezone :GMT
- }
- }
- if { ![info exists saw(-format)] } {
- # Perhaps someday we'll localize the legacy code. Right now,
- # it's not localized.
- if { [info exists saw(-locale)] } {
- return -code error \
- -errorcode [list CLOCK flagWithLegacyFormat] \
- "legacy \[clock scan\] does not support -locale"
- }
- return [FreeScan $string $base $timezone $locale]
- }
- # Change locale if a fresh locale has been given on the command line.
- EnterLocale $locale oldLocale
- set status [catch {
- # Map away the locale-dependent composite format groups
- set scanner [ParseClockScanFormat $format $locale]
- $scanner $string $base $timezone
- } result opts]
- # Restore the locale
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
- if { $status == 1 } {
- if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
- return -code error $result
- } else {
- return -options $opts $result
- }
- } else {
- return $result
- }
- }
- #----------------------------------------------------------------------
- #
- # FreeScan --
- #
- # Scans a time in free format
- #
- # Parameters:
- # string - String containing the time to scan
- # base - Base time, expressed in seconds from the Epoch
- # timezone - Default time zone in which the time will be expressed
- # locale - (Unused) Name of the locale where the time will be scanned.
- #
- # Results:
- # Returns the date and time extracted from the string in seconds
- # from the epoch
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::FreeScan { string base timezone locale } {
- variable TZData
- # Get the data for time changes in the given zone
-
- if {[catch {SetupTimeZone $timezone} retval opts]} {
- dict unset opts -errorinfo
- return -options $opts $retval
- }
- # Extract year, month and day from the base time for the
- # parser to use as defaults
- set date [GetDateFields \
- $base \
- $TZData($timezone) \
- 2361222]
- dict set date secondOfDay [expr { [dict get $date localSeconds]
- % 86400 }]
- # Parse the date. The parser will return a list comprising
- # date, time, time zone, relative month/day/seconds, relative
- # weekday, ordinal month.
- set status [catch {
- Oldscan $string \
- [dict get $date year] \
- [dict get $date month] \
- [dict get $date dayOfMonth]
- } result]
- if { $status != 0 } {
- return -code error "unable to convert date-time string \"$string\": $result"
- }
- lassign $result parseDate parseTime parseZone parseRel \
- parseWeekday parseOrdinalMonth
- # If the caller supplied a date in the string, update the 'date' dict
- # with the value. If the caller didn't specify a time with the date,
- # default to midnight.
- if { [llength $parseDate] > 0 } {
- lassign $parseDate y m d
- if { $y < 100 } {
- if { $y >= 39 } {
- incr y 1900
- } else {
- incr y 2000
- }
- }
- dict set date era CE
- dict set date year $y
- dict set date month $m
- dict set date dayOfMonth $d
- if { $parseTime eq {} } {
- set parseTime 0
- }
- }
- # If the caller supplied a time zone in the string, it comes back
- # as a two-element list; the first element is the number of minutes
- # east of Greenwich, and the second is a Daylight Saving Time
- # indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into
- # a time zone indicator of +-hhmm.
-
- if { [llength $parseZone] > 0 } {
- lassign $parseZone minEast dstFlag
- set timezone [FormatNumericTimeZone \
- [expr { 60 * $minEast + 3600 * $dstFlag }]]
- SetupTimeZone $timezone
- }
- dict set date tzName $timezone
- # Assemble date, time, zone into seconds-from-epoch
- set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222]
- if { $parseTime ne {} } {
- dict set date secondOfDay $parseTime
- } elseif { [llength $parseWeekday] != 0
- || [llength $parseOrdinalMonth] != 0
- || ( [llength $parseRel] != 0
- && ( [lindex $parseRel 0] != 0
- || [lindex $parseRel 1] != 0 ) ) } {
- dict set date secondOfDay 0
- }
- dict set date localSeconds \
- [expr { -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay] }]
- dict set date tzName $timezone
- set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222]
- set seconds [dict get $date seconds]
- # Do relative times
- if { [llength $parseRel] > 0 } {
- lassign $parseRel relMonth relDay relSecond
- set seconds [add $seconds \
- $relMonth months $relDay days $relSecond seconds \
- -timezone $timezone -locale $locale]
- }
- # Do relative weekday
-
- if { [llength $parseWeekday] > 0 } {
- lassign $parseWeekday dayOrdinal dayOfWeek
- set date2 [GetDateFields $seconds $TZData($timezone) 2361222]
- dict set date2 era CE
- set jdwkday [WeekdayOnOrBefore $dayOfWeek \
- [expr { [dict get $date2 julianDay]
- + 6 }]]
- incr jdwkday [expr { 7 * $dayOrdinal }]
- if { $dayOrdinal > 0 } {
- incr jdwkday -7
- }
- dict set date2 secondOfDay \
- [expr { [dict get $date2 localSeconds] % 86400 }]
- dict set date2 julianDay $jdwkday
- dict set date2 localSeconds \
- [expr { -210866803200
- + ( 86400 * wide([dict get $date2 julianDay]) )
- + [dict get $date secondOfDay] }]
- dict set date2 tzName $timezone
- set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \
- 2361222]
- set seconds [dict get $date2 seconds]
- }
- # Do relative month
- if { [llength $parseOrdinalMonth] > 0 } {
- lassign $parseOrdinalMonth monthOrdinal monthNumber
- if { $monthOrdinal > 0 } {
- set monthDiff [expr { $monthNumber - [dict get $date month] }]
- if { $monthDiff <= 0 } {
- incr monthDiff 12
- }
- incr monthOrdinal -1
- } else {
- set monthDiff [expr { [dict get $date month] - $monthNumber }]
- if { $monthDiff >= 0 } {
- incr monthDiff -12
- }
- incr monthOrdinal
- }
- set seconds [add $seconds $monthOrdinal years $monthDiff months \
- -timezone $timezone -locale $locale]
- }
- return $seconds
- }
- #----------------------------------------------------------------------
- #
- # ParseClockScanFormat --
- #
- # Parses a format string given to [clock scan -format]
- #
- # Parameters:
- # formatString - The format being parsed
- # locale - The current locale
- #
- # Results:
- # Constructs and returns a procedure that accepts the
- # string being scanned, the base time, and the time zone.
- # The procedure will either return the scanned time or
- # else throw an error that should be rethrown to the caller
- # of [clock scan]
- #
- # Side effects:
- # The given procedure is defined in the ::tcl::clock
- # namespace. Scan procedures are not deleted once installed.
- #
- # Why do we parse dates by defining a procedure to parse them?
- # The reason is that by doing so, we have one convenient place to
- # cache all the information: the regular expressions that match the
- # patterns (which will be compiled), the code that assembles the
- # date information, everything lands in one place. In this way,
- # when a given format is reused at run time, all the information
- # of how to apply it is available in a single place.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
- # Check whether the format has been parsed previously, and return
- # the existing recognizer if it has.
- set procName scanproc'$formatString'$locale
- set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
- if { [namespace which $procName] != {} } {
- return $procName
- }
- variable DateParseActions
- variable TimeParseActions
- # Localize the %x, %X, etc. groups
- set formatString [LocalizeFormat $locale $formatString]
- # Condense whitespace
- regsub -all {[[:space:]]+} $formatString { } formatString
- # Walk through the groups of the format string. In this loop, we
- # accumulate:
- # - a regular expression that matches the string,
- # - the count of capturing brackets in the regexp
- # - a set of code that post-processes the fields captured by the regexp,
- # - a dictionary whose keys are the names of fields that are present
- # in the format string.
- set re {^[[:space:]]*}
- set captureCount 0
- set postcode {}
- set fieldSet [dict create]
- set fieldCount 0
- set postSep {}
- set state {}
- foreach c [split $formatString {}] {
- switch -exact -- $state {
- {} {
- if { $c eq "%" } {
- set state %
- } elseif { $c eq " " } {
- append re {[[:space:]]+}
- } else {
- if { ! [string is alnum $c] } {
- append re \\
- }
- append re $c
- }
- }
- % {
- set state {}
- switch -exact -- $c {
- % {
- append re %
- }
- { } {
- append re "\[\[:space:\]\]*"
- }
- a - A { # Day of week, in words
- set l {}
- foreach \
- i {7 1 2 3 4 5 6} \
- abr [mc DAYS_OF_WEEK_ABBREV] \
- full [mc DAYS_OF_WEEK_FULL] {
- dict set l [string tolower $abr] $i
- dict set l [string tolower $full] $i
- incr i
- }
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet dayOfWeek [incr fieldCount]
- append postcode "dict set date dayOfWeek \[" \
- "dict get " [list $lookup] " " \
- \[ {string tolower $field} [incr captureCount] \] \
- "\]\n"
- }
- b - B - h { # Name of month
- set i 0
- set l {}
- foreach \
- abr [mc MONTHS_ABBREV] \
- full [mc MONTHS_FULL] {
- incr i
- dict set l [string tolower $abr] $i
- dict set l [string tolower $full] $i
- }
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet month [incr fieldCount]
- append postcode "dict set date month \[" \
- "dict get " [list $lookup] \
- " " \[ {string tolower $field} \
- [incr captureCount] \] \
- "\]\n"
- }
- C { # Gregorian century
- append re \\s*(\\d\\d?)
- dict set fieldSet century [incr fieldCount]
- append postcode "dict set date century \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- d - e { # Day of month
- append re \\s*(\\d\\d?)
- dict set fieldSet dayOfMonth [incr fieldCount]
- append postcode "dict set date dayOfMonth \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- E { # Prefix for locale-specific codes
- set state %E
- }
- g { # ISO8601 2-digit year
- append re \\s*(\\d\\d)
- dict set fieldSet iso8601YearOfCentury \
- [incr fieldCount]
- append postcode \
- "dict set date iso8601YearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- G { # ISO8601 4-digit year
- append re \\s*(\\d\\d)(\\d\\d)
- dict set fieldSet iso8601Century [incr fieldCount]
- dict set fieldSet iso8601YearOfCentury \
- [incr fieldCount]
- append postcode \
- "dict set date iso8601Century \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n" \
- "dict set date iso8601YearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- H - k { # Hour of day
- append re \\s*(\\d\\d?)
- dict set fieldSet hour [incr fieldCount]
- append postcode "dict set date hour \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- I - l { # Hour, AM/PM
- append re \\s*(\\d\\d?)
- dict set fieldSet hourAMPM [incr fieldCount]
- append postcode "dict set date hourAMPM \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- j { # Day of year
- append re \\s*(\\d\\d?\\d?)
- dict set fieldSet dayOfYear [incr fieldCount]
- append postcode "dict set date dayOfYear \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- J { # Julian Day Number
- append re \\s*(\\d+)
- dict set fieldSet julianDay [incr fieldCount]
- append postcode "dict set date julianDay \[" \
- "::scan \$field" [incr captureCount] " %ld" \
- "\]\n"
- }
- m - N { # Month number
- append re \\s*(\\d\\d?)
- dict set fieldSet month [incr fieldCount]
- append postcode "dict set date month \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- M { # Minute
- append re \\s*(\\d\\d?)
- dict set fieldSet minute [incr fieldCount]
- append postcode "dict set date minute \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- n { # Literal newline
- append re \\n
- }
- O { # Prefix for locale numerics
- set state %O
- }
- p - P { # AM/PM indicator
- set l [list [string tolower [mc AM]] 0 \
- [string tolower [mc PM]] 1]
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet amPmIndicator [incr fieldCount]
- append postcode "dict set date amPmIndicator \[" \
- "dict get " [list $lookup] " \[string tolower " \
- "\$field" \
- [incr captureCount] \
- "\]\]\n"
- }
- Q { # Hi, Jeff!
- append re {Stardate\s+([-+]?\d+)(\d\d\d)[.](\d)}
- incr captureCount
- dict set fieldSet seconds [incr fieldCount]
- append postcode {dict set date seconds } \[ \
- {ParseStarDate $field} [incr captureCount] \
- { $field} [incr captureCount] \
- { $field} [incr captureCount] \
- \] \n
- }
- s { # Seconds from Posix Epoch
- # This next case is insanely difficult,
- # because it's problematic to determine
- # whether the field is actually within
- # the range of a wide integer.
- append re {\s*([-+]?\d+)}
- dict set fieldSet seconds [incr fieldCount]
- append postcode {dict set date seconds } \[ \
- {ScanWide $field} [incr captureCount] \] \n
- }
- S { # Second
- append re \\s*(\\d\\d?)
- dict set fieldSet second [incr fieldCount]
- append postcode "dict set date second \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- t { # Literal tab character
- append re \\t
- }
- u - w { # Day number within week, 0 or 7 == Sun
- # 1=Mon, 6=Sat
- append re \\s*(\\d)
- dict set fieldSet dayOfWeek [incr fieldCount]
- append postcode {::scan $field} [incr captureCount] \
- { %d dow} \n \
- {
- if { $dow == 0 } {
- set dow 7
- } elseif { $dow > 7 } {
- return -code error \
- -errorcode [list CLOCK badDayOfWeek] \
- "day of week is greater than 7"
- }
- dict set date dayOfWeek $dow
- }
- }
- U { # Week of year. The
- # first Sunday of the year is the
- # first day of week 01. No scan rule
- # uses this group.
- append re \\s*\\d\\d?
- }
- V { # Week of ISO8601 year
-
- append re \\s*(\\d\\d?)
- dict set fieldSet iso8601Week [incr fieldCount]
- append postcode "dict set date iso8601Week \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- W { # Week of the year (00-53). The first
- # Monday of the year is the first day
- # of week 01. No scan rule uses this
- # group.
- append re \\s*\\d\\d?
- }
- y { # Two-digit Gregorian year
- append re \\s*(\\d\\d?)
- dict set fieldSet yearOfCentury [incr fieldCount]
- append postcode "dict set date yearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- Y { # 4-digit Gregorian year
- append re \\s*(\\d\\d)(\\d\\d)
- dict set fieldSet century [incr fieldCount]
- dict set fieldSet yearOfCentury [incr fieldCount]
- append postcode \
- "dict set date century \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n" \
- "dict set date yearOfCentury \[" \
- "::scan \$field" [incr captureCount] " %d" \
- "\]\n"
- }
- z - Z { # Time zone name
- append re {(?:([-+]\d\d(?::?\d\d(?::?\d\d)?)?)|([[:alnum:]]{1,4}))}
- dict set fieldSet tzName [incr fieldCount]
- append postcode \
- {if } \{ { $field} [incr captureCount] \
- { ne "" } \} { } \{ \n \
- {dict set date tzName $field} \
- $captureCount \n \
- \} { else } \{ \n \
- {dict set date tzName } \[ \
- {ConvertLegacyTimeZone $field} \
- [incr captureCount] \] \n \
- \} \n \
- }
- % { # Literal percent character
- append re %
- }
- default {
- append re %
- if { ! [string is alnum $c] } {
- append re \\
- }
- append re $c
- }
- }
- }
- %E {
- switch -exact -- $c {
- C { # Locale-dependent era
- set d {}
- foreach triple [mc LOCALE_ERAS] {
- lassign $triple t symbol year
- dict set d [string tolower $symbol] $year
- }
- lassign [UniquePrefixRegexp $d] regex lookup
- append re (?: $regex )
- }
- E {
- set l {}
- dict set l [string tolower [mc BCE]] BCE
- dict set l [string tolower [mc CE]] CE
- dict set l b.c.e. BCE
- dict set l c.e. CE
- dict set l b.c. BCE
- dict set l a.d. CE
- lassign [UniquePrefixRegexp $l] regex lookup
- append re ( $regex )
- dict set fieldSet era [incr fieldCount]
- append postcode "dict set date era \["\
- "dict get " [list $lookup] \
- { } \[ {string tolower $field} \
- [incr captureCount] \] \
- "\]\n"
- }
- y { # Locale-dependent year of the era
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- incr captureCount
- }
- default {
- append re %E
- if { ! [string is alnum $c] } {
- append re \\
- }
- append re $c
- }
- }
- set state {}
- }
- %O {
- switch -exact -- $c {
- d - e {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet dayOfMonth [incr fieldCount]
- append postcode "dict set date dayOfMonth \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- H - k {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet hour [incr fieldCount]
- append postcode "dict set date hour \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- I - l {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet hourAMPM [incr fieldCount]
- append postcode "dict set date hourAMPM \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- m {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet month [incr fieldCount]
- append postcode "dict set date month \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- M {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet minute [incr fieldCount]
- append postcode "dict set date minute \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- S {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet second [incr fieldCount]
- append postcode "dict set date second \[" \
- "dict get " [list $lookup] " \$field" \
- [incr captureCount] \
- "\]\n"
- }
- u - w {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet dayOfWeek [incr fieldCount]
- append postcode "set dow \[dict get " [list $lookup] \
- { $field} [incr captureCount] \] \n \
- {
- if { $dow == 0 } {
- set dow 7
- } elseif { $dow > 7 } {
- return -code error \
- -errorcode [list CLOCK badDayOfWeek] \
- "day of week is greater than 7"
- }
- dict set date dayOfWeek $dow
- }
- }
- y {
- lassign [LocaleNumeralMatcher $locale] regex lookup
- append re $regex
- dict set fieldSet yearOfCentury [incr fieldCount]
- append postcode {dict set date yearOfCentury } \[ \
- {dict get } [list $lookup] { $field} \
- [incr captureCount] \] \n
- }
- default {
- append re %O
- if { ! [string is alnum $c] } {
- append re \\
- }
- append re $c
- }
- }
- set state {}
- }
- }
- }
- # Clean up any unfinished format groups
- append re $state \\s*\$
- # Build the procedure
- set procBody {}
- append procBody "variable ::tcl::clock::TZData" \n
- append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->"
- for { set i 1 } { $i <= $captureCount } { incr i } {
- append procBody " " field $i
- }
- append procBody "\] \} \{" \n
- append procBody {
- return -code error -errorcode [list CLOCK badInputString] \
- {input string does not match supplied format}
- }
- append procBody \}\n
- append procBody "set date \[dict create\]" \n
- append procBody {dict set date tzName $timeZone} \n
- append procBody $postcode
- append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n
- # Get time zone if needed
- if { ![dict exists $fieldSet seconds]
- && ![dict exists $fieldSet starDate] } {
- if { [dict exists $fieldSet tzName] } {
- append procBody {
- set timeZone [dict get $date tzName]
- }
- }
- append procBody {
- ::tcl::clock::SetupTimeZone $timeZone
- }
- }
- # Add code that gets Julian Day Number from the fields.
- append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions]
- # Get time of day
- append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions]
- # Assemble seconds, and convert local nominal time to UTC.
- if { ![dict exists $fieldSet seconds]
- && ![dict exists $fieldSet starDate] } {
- append procBody {
- if { [dict get $date julianDay] > 5373484 } {
- return -code error -errorcode [list CLOCK dateTooLarge] \
- "requested date too large to represent"
- }
- dict set date localSeconds \
- [expr { -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay] }]
- }
- append procBody {
- set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \
- $TZData($timeZone) \
- $changeover]
- }
- }
- # Return result
- append procBody {return [dict get $date seconds]} \n
- proc $procName { string baseTime timeZone } $procBody
- # puts [list proc $procName [list string baseTime timeZone] $procBody]
- return $procName
- }
-
- #----------------------------------------------------------------------
- #
- # LocaleNumeralMatcher --
- #
- # Composes a regexp that captures the numerals in the given
- # locale, and a dictionary to map them to conventional numerals.
- #
- # Parameters:
- # locale - Name of the current locale
- #
- # Results:
- # Returns a two-element list comprising the regexp and the
- # dictionary.
- #
- # Side effects:
- # Caches the result.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::LocaleNumeralMatcher {l} {
- variable LocaleNumeralCache
- if { ![dict exists $LocaleNumeralCache $l] } {
- set d {}
- set i 0
- set sep \(
- foreach n [mc LOCALE_NUMERALS] {
- dict set d $n $i
- regsub -all {[^[:alnum:]]} $n \\\\& subex
- append re $sep $subex
- set sep |
- incr i
- }
- append re \)
- dict set LocaleNumeralCache $l [list $re $d]
- }
- return [dict get $LocaleNumeralCache $l]
- }
-
- #----------------------------------------------------------------------
- #
- # UniquePrefixRegexp --
- #
- # Composes a regexp that performs unique-prefix matching. The
- # RE matches one of a supplied set of strings, or any unique
- # prefix thereof.
- #
- # Parameters:
- # data - List of alternating match-strings and values.
- # Match-strings with distinct values are considered
- # distinct.
- #
- # Results:
- # Returns a two-element list. The first is a regexp that
- # matches any unique prefix of any of the strings. The second
- # is a dictionary whose keys are match values from the regexp
- # and whose values are the corresponding values from 'data'.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::UniquePrefixRegexp { data } {
- # The 'successors' dictionary will contain, for each string that
- # is a prefix of any key, all characters that may follow that
- # prefix. The 'prefixMapping' dictionary will have keys that
- # are prefixes of keys and values that correspond to the keys.
- set prefixMapping [dict create]
- set successors [dict create {} {}]
- # Walk the key-value pairs
- foreach { key value } $data {
- # Construct all prefixes of the key;
- set prefix {}
- foreach char [split $key {}] {
- set oldPrefix $prefix
- dict set successors $oldPrefix $char {}
- append prefix $char
- # Put the prefixes in the 'prefixMapping' and 'successors'
- # dictionaries
- dict lappend prefixMapping $prefix $value
- if { ![dict exists $successors $prefix] } {
- dict set successors $prefix {}
- }
- }
- }
- # Identify those prefixes that designate unique values, and
- # those that are the full keys
- set uniquePrefixMapping {}
- dict for { key valueList } $prefixMapping {
- if { [llength $valueList] == 1 } {
- dict set uniquePrefixMapping $key [lindex $valueList 0]
- }
- }
- foreach { key value } $data {
- dict set uniquePrefixMapping $key $value
- }
- # Construct the re.
- return [list \
- [MakeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \
- $uniquePrefixMapping]
- }
- #----------------------------------------------------------------------
- #
- # MakeUniquePrefixRegexp --
- #
- # Service procedure for 'UniquePrefixRegexp' that constructs
- # a regular expresison that matches the unique prefixes.
- #
- # Parameters:
- # successors - Dictionary whose keys are all prefixes
- # of keys passed to 'UniquePrefixRegexp' and whose
- # values are dictionaries whose keys are the characters
- # that may follow those prefixes.
- # uniquePrefixMapping - Dictionary whose keys are the unique
- # prefixes and whose values are not examined.
- # prefixString - Current prefix being processed.
- #
- # Results:
- # Returns a constructed regular expression that matches the set
- # of unique prefixes beginning with the 'prefixString'.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::MakeUniquePrefixRegexp { successors
- uniquePrefixMapping
- prefixString } {
- # Get the characters that may follow the current prefix string
- set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]]
- if { [llength $schars] == 0 } {
- return {}
- }
- # If there is more than one successor character, or if the current
- # prefix is a unique prefix, surround the generated re with non-capturing
- # parentheses.
- set re {}
- if { [dict exists $uniquePrefixMapping $prefixString]
- || [llength $schars] > 1 } {
- append re "(?:"
- }
- # Generate a regexp that matches the successors.
- set sep ""
- foreach { c } $schars {
- set nextPrefix $prefixString$c
- regsub -all {[^[:alnum:]]} $c \\\\& rechar
- append re $sep $rechar \
- [MakeUniquePrefixRegexp \
- $successors $uniquePrefixMapping $nextPrefix]
- set sep |
- }
- # If the current prefix is a unique prefix, make all following text
- # optional. Otherwise, if there is more than one successor character,
- # close the non-capturing parentheses.
- if { [dict exists $uniquePrefixMapping $prefixString] } {
- append re ")?"
- } elseif { [llength $schars] > 1 } {
- append re ")"
- }
- return $re
- }
- #----------------------------------------------------------------------
- #
- # MakeParseCodeFromFields --
- #
- # Composes Tcl code to extract the Julian Day Number from a
- # dictionary containing date fields.
- #
- # Parameters:
- # dateFields -- Dictionary whose keys are fields of the date,
- # and whose values are the rightmost positions
- # at which those fields appear.
- # parseActions -- List of triples: field set, priority, and
- # code to emit. Smaller priorities are better, and
- # the list must be in ascending order by priority
- #
- # Results:
- # Returns a burst of code that extracts the day number from the
- # given date.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
- set currPrio 999
- set currFieldPos [list]
- set currCodeBurst {
- error "in ::tcl::clock::MakeParseCodeFromFields: can't happen"
- }
- foreach { fieldSet prio parseAction } $parseActions {
- # If we've found an answer that's better than any that follow,
- # quit now.
- if { $prio > $currPrio } {
- break
- }
- # Accumulate the field positions that are used in the current
- # field grouping.
- set fieldPos [list]
- set ok true
- foreach field $fieldSet {
- if { ! [dict exists $dateFields $field] } {
- set ok 0
- break
- }
- lappend fieldPos [dict get $dateFields $field]
- }
- # Quit if we don't have a complete set of fields
- if { !$ok } {
- continue
- }
- # Determine whether the current answer is better than the last.
- set fPos [lsort -integer -decreasing $fieldPos]
- if { $prio == $currPrio } {
- foreach currPos $currFieldPos newPos $fPos {
- if { ![string is integer $newPos]
- || ![string is integer $currPos]
- || $newPos > $currPos } {
- break
- }
- if { $newPos < $currPos } {
- set ok 0
- break
- }
- }
- }
- if { !$ok } {
- continue
- }
- # Remember the best possibility for extracting date information
- set currPrio $prio
- set currFieldPos $fPos
- set currCodeBurst $parseAction
-
- }
- return $currCodeBurst
- }
- #----------------------------------------------------------------------
- #
- # EnterLocale --
- #
- # Switch [mclocale] to a given locale if necessary
- #
- # Parameters:
- # locale -- Desired locale
- # oldLocaleVar -- Name of a variable in caller's scope that
- # tracks the previous locale name.
- #
- # Results:
- # Returns the locale that was previously current.
- #
- # Side effects:
- # Does [mclocale]. If necessary, uses [mcload] to load the
- # designated locale's files, and tracks that it has done so
- # in the 'McLoaded' variable.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::EnterLocale { locale oldLocaleVar } {
- upvar 1 $oldLocaleVar oldLocale
- variable MsgDir
- variable McLoaded
- set oldLocale [mclocale]
- if { $locale eq {system} } {
- if { $::tcl_platform(platform) ne {windows} } {
- # On a non-windows platform, the 'system' locale is
- # the same as the 'current' locale
- set locale current
- } else {
- # On a windows platform, the 'system' locale is
- # adapted from the 'current' locale by applying the
- # date and time formats from the Control Panel.
- # First, load the 'current' locale if it's not yet loaded
- if {![dict exists $McLoaded $oldLocale] } {
- mcload $MsgDir
- dict set McLoaded $oldLocale {}
- }
- # Make a new locale string for the system locale, and
- # get the Control Panel information
- set locale ${oldLocale}_windows
- if { ![dict exists $McLoaded $locale] } {
- LoadWindowsDateTimeFormats $locale
- dict set McLoaded $locale {}
- }
- }
- }
- if { $locale eq {current}} {
- set locale $oldLocale
- unset oldLocale
- } elseif { $locale eq $oldLocale } {
- unset oldLocale
- } else {
- mclocale $locale
- }
- if { ![dict exists $McLoaded $locale] } {
- mcload $MsgDir
- dict set McLoaded $locale {}
- }
- }
- #----------------------------------------------------------------------
- #
- # LoadWindowsDateTimeFormats --
- #
- # Load the date/time formats from the Control Panel in Windows
- # and convert them so that they're usable by Tcl.
- #
- # Parameters:
- # locale - Name of the locale in whose message catalog
- # the converted formats are to be stored.
- #
- # Results:
- # None.
- #
- # Side effects:
- # Updates the given message catalog with the locale strings.
- #
- # Presumes that on entry, [mclocale] is set to the current locale,
- # so that default strings can be obtained if the Registry query
- # fails.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
- # Bail out if we can't find the Registry
- variable NoRegistry
- if { [info exists NoRegistry] } return
- if { ![catch {
- registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
- sShortDate
- } string] } {
- set quote {}
- set datefmt {}
- foreach { unquoted quoted } [split $string '] {
- append datefmt $quote [string map {
- dddd %A
- ddd %a
- dd %d
- d %e
- MMMM %B
- MMM %b
- MM %m
- M %N
- yyyy %Y
- yy %y
- y %y
- gg {}
- } $unquoted]
- if { $quoted eq {} } {
- set quote '
- } else {
- set quote $quoted
- }
- }
- ::msgcat::mcset $locale DATE_FORMAT $datefmt
- }
- if { ![catch {
- registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
- sLongDate
- } string] } {
- set quote {}
- set ldatefmt {}
- foreach { unquoted quoted } [split $string '] {
- append ldatefmt $quote [string map {
- dddd %A
- ddd %a
- dd %d
- d %e
- MMMM %B
- MMM %b
- MM %m
- M %N
- yyyy %Y
- yy %y
- y %y
- gg {}
- } $unquoted]
- if { $quoted eq {} } {
- set quote '
- } else {
- set quote $quoted
- }
- }
- ::msgcat::mcset $locale LOCALE_DATE_FORMAT $ldatefmt
- }
- if { ![catch {
- registry get "HKEY_CURRENT_USER\\Control Panel\\International" \
- sTimeFormat
- } string] } {
- set quote {}
- set timefmt {}
- foreach { unquoted quoted } [split $string '] {
- append timefmt $quote [string map {
- HH %H
- H %k
- hh %I
- h %l
- mm %M
- m %M
- ss %S
- s %S
- tt %p
- t %p
- } $unquoted]
- if { $quoted eq {} } {
- set quote '
- } else {
- set quote $quoted
- }
- }
- ::msgcat::mcset $locale TIME_FORMAT $timefmt
- }
- catch {
- ::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt"
- }
- catch {
- ::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt"
- }
- return
- }
- #----------------------------------------------------------------------
- #
- # LocalizeFormat --
- #
- # Map away locale-dependent format groups in a clock format.
- #
- # Parameters:
- # locale -- Current [mclocale] locale, supplied to avoid
- # an extra call
- # format -- Format supplied to [clock scan] or [clock format]
- #
- # Results:
- # Returns the string with locale-dependent composite format
- # groups substituted out.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::LocalizeFormat { locale format } {
- variable McLoaded
- if { [dict exists $McLoaded $locale FORMAT $format] } {
- return [dict get $McLoaded $locale FORMAT $format]
- }
- set inFormat $format
- # Handle locale-dependent format groups by mapping them out of the format
- # string. Note that the order of the [string map] operations is
- # significant because later formats can refer to later ones; for example
- # %c can refer to %X, which in turn can refer to %T.
-
- set list {
- %% %%
- %D %m/%d/%Y
- %+ {%a %b %e %H:%M:%S %Z %Y}
- }
- lappend list %EY [string map $list [mc LOCALE_YEAR_FORMAT]]
- lappend list %T [string map $list [mc TIME_FORMAT_24_SECS]]
- lappend list %R [string map $list [mc TIME_FORMAT_24]]
- lappend list %r [string map $list [mc TIME_FORMAT_12]]
- lappend list %X [string map $list [mc TIME_FORMAT]]
- lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]]
- lappend list %x [string map $list [mc DATE_FORMAT]]
- lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]]
- lappend list %c [string map $list [mc DATE_TIME_FORMAT]]
- lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]]
- set format [string map $list $format]
-
- dict set McLoaded $locale FORMAT $inFormat $format
- return $format
- }
- #----------------------------------------------------------------------
- #
- # FormatNumericTimeZone --
- #
- # Formats a time zone as +hhmmss
- #
- # Parameters:
- # z - Time zone in seconds east of Greenwich
- #
- # Results:
- # Returns the time zone formatted in a numeric form
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::FormatNumericTimeZone { z } {
- if { $z < 0 } {
- set z [expr { - $z }]
- set retval -
- } else {
- set retval +
- }
- append retval [::format %02d [expr { $z / 3600 }]]
- set z [expr { $z % 3600 }]
- append retval [::format %02d [expr { $z / 60 }]]
- set z [expr { $z % 60 }]
- if { $z != 0 } {
- append retval [::format %02d $z]
- }
- return $retval
- }
- #----------------------------------------------------------------------
- #
- # FormatStarDate --
- #
- # Formats a date as a StarDate.
- #
- # Parameters:
- # date - Dictionary containing 'year', 'dayOfYear', and
- # 'localSeconds' fields.
- #
- # Results:
- # Returns the given date formatted as a StarDate.
- #
- # Side effects:
- # None.
- #
- # Jeff Hobbs put this in to support an atrocious pun about Tcl being
- # "Enterprise ready." Now we're stuck with it.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::FormatStarDate { date } {
- variable Roddenberry
- # Get day of year, zero based
- set doy [expr { [dict get $date dayOfYear] - 1 }]
- # Determine whether the year is a leap year
- set lp [IsGregorianLeapYear $date]
- # Convert day of year to a fractional year
- if { $lp } {
- set fractYear [expr { 1000 * $doy / 366 }]
- } else {
- set fractYear [expr { 1000 * $doy / 365 }]
- }
- # Put together the StarDate
- return [::format "Stardate %02d%03d.%1d" \
- [expr { [dict get $date year] - $Roddenberry }] \
- $fractYear \
- [expr { [dict get $date localSeconds] % 86400
- / ( 86400 / 10 ) }]]
- }
- #----------------------------------------------------------------------
- #
- # ParseStarDate --
- #
- # Parses a StarDate
- #
- # Parameters:
- # year - Year from the Roddenberry epoch
- # fractYear - Fraction of a year specifiying the day of year.
- # fractDay - Fraction of a day
- #
- # Results:
- # Returns a count of seconds from the Posix epoch.
- #
- # Side effects:
- # None.
- #
- # Jeff Hobbs put this in to support an atrocious pun about Tcl being
- # "Enterprise ready." Now we're stuck with it.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
- variable Roddenberry
- # Build a tentative date from year and fraction.
- set date [dict create \
- gregorian 1 \
- era CE \
- year [expr { $year + $Roddenberry }] \
- dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]]
- set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
- # Determine whether the given year is a leap year
- set lp [IsGregorianLeapYear $date]
- # Reconvert the fractional year according to whether the given
- # year is a leap year
- if { $lp } {
- dict set date dayOfYear \
- [expr { $fractYear * 366 / 1000 + 1 }]
- } else {
- dict set date dayOfYear \
- [expr { $fractYear * 365 / 1000 + 1 }]
- }
- dict unset date julianDay
- dict unset date gregorian
- set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
- return [expr { 86400 * [dict get $date julianDay]
- - 210866803200
- + ( 86400 / 10 ) * $fractDay }]
- }
- #----------------------------------------------------------------------
- #
- # ScanWide --
- #
- # Scans a wide integer from an input
- #
- # Parameters:
- # str - String containing a decimal wide integer
- #
- # Results:
- # Returns the string as a pure wide integer. Throws an error if
- # the string is misformatted or out of range.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ScanWide { str } {
- set count [::scan $str {%ld %c} result junk]
- if { $count != 1 } {
- return -code error -errorcode [list CLOCK notAnInteger $str] \
- "\"$str\" is not an integer"
- }
- if { [incr result 0] != $str } {
- return -code error -errorcode [list CLOCK integervalueTooLarge] \
- "integer value too large to represent"
- }
- return $result
- }
- #----------------------------------------------------------------------
- #
- # InterpretTwoDigitYear --
- #
- # Given a date that contains only the year of the century,
- # determines the target value of a two-digit year.
- #
- # Parameters:
- # date - Dictionary containing fields of the date.
- # baseTime - Base time relative to which the date is expressed.
- # twoDigitField - Name of the field that stores the two-digit year.
- # Default is 'yearOfCentury'
- # fourDigitField - Name of the field that will receive the four-digit
- # year. Default is 'year'
- #
- # Results:
- # Returns the dictionary augmented with the four-digit year, stored in
- # the given key.
- #
- # Side effects:
- # None.
- #
- # The current rule for interpreting a two-digit year is that the year
- # shall be between 1937 and 2037, thus staying within the range of a
- # 32-bit signed value for time. This rule may change to a sliding
- # window in future versions, so the 'baseTime' parameter (which is
- # currently ignored) is provided in the procedure signature.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
- { twoDigitField yearOfCentury }
- { fourDigitField year } } {
- set yr [dict get $date $twoDigitField]
- if { $yr <= 37 } {
- dict set date $fourDigitField [expr { $yr + 2000 }]
- } else {
- dict set date $fourDigitField [expr { $yr + 1900 }]
- }
- return $date
- }
- #----------------------------------------------------------------------
- #
- # AssignBaseYear --
- #
- # Places the number of the current year into a dictionary.
- #
- # Parameters:
- # date - Dictionary value to update
- # baseTime - Base time from which to extract the year, expressed
- # in seconds from the Posix epoch
- # timezone - the time zone in which the date is being scanned
- # changeover - the Julian Day on which the Gregorian calendar
- # was adopted in the target locale.
- #
- # Results:
- # Returns the dictionary with the current year assigned.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
- variable TZData
- # Find the Julian Day Number corresponding to the base time, and
- # find the Gregorian year corresponding to that Julian Day.
- set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
- # Store the converted year
- dict set date era [dict get $date2 era]
- dict set date year [dict get $date2 year]
- return $date
- }
- #----------------------------------------------------------------------
- #
- # AssignBaseIso8601Year --
- #
- # Determines the base year in the ISO8601 fiscal calendar.
- #
- # Parameters:
- # date - Dictionary containing the fields of the date that
- # is to be augmented with the base year.
- # baseTime - Base time expressed in seconds from the Posix epoch.
- # timeZone - Target time zone
- # changeover - Julian Day of adoption of the Gregorian calendar in
- # the target locale.
- #
- # Results:
- # Returns the given date with "iso8601Year" set to the
- # base year.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} {
- variable TZData
- # Find the Julian Day Number corresponding to the base time
- set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
- # Calculate the ISO8601 date and transfer the year
- dict set date era CE
- dict set date iso8601Year [dict get $date2 iso8601Year]
- return $date
- }
- #----------------------------------------------------------------------
- #
- # AssignBaseMonth --
- #
- # Places the number of the current year and month into a
- # dictionary.
- #
- # Parameters:
- # date - Dictionary value to update
- # baseTime - Time from which the year and month are to be
- # obtained, expressed in seconds from the Posix epoch.
- # timezone - Name of the desired time zone
- # changeover - Julian Day on which the Gregorian calendar was adopted.
- #
- # Results:
- # Returns the dictionary with the base year and month assigned.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
- variable TZData
- # Find the year and month corresponding to the base time
- set date2 [GetDateFields $baseTime $TZData($timezone) $changeover]
- dict set date era [dict get $date2 era]
- dict set date year [dict get $date2 year]
- dict set date month [dict get $date2 month]
- return $date
- }
- #----------------------------------------------------------------------
- #
- # AssignBaseWeek --
- #
- # Determines the base year and week in the ISO8601 fiscal calendar.
- #
- # Parameters:
- # date - Dictionary containing the fields of the date that
- # is to be augmented with the base year and week.
- # baseTime - Base time expressed in seconds from the Posix epoch.
- # changeover - Julian Day on which the Gregorian calendar was adopted
- # in the target locale.
- #
- # Results:
- # Returns the given date with "iso8601Year" set to the
- # base year and "iso8601Week" to the week number.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} {
- variable TZData
- # Find the Julian Day Number corresponding to the base time
- set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
- # Calculate the ISO8601 date and transfer the year
- dict set date era CE
- dict set date iso8601Year [dict get $date2 iso8601Year]
- dict set date iso8601Week [dict get $date2 iso8601Week]
- return $date
- }
- #----------------------------------------------------------------------
- #
- # AssignBaseJulianDay --
- #
- # Determines the base day for a time-of-day conversion.
- #
- # Parameters:
- # date - Dictionary that is to get the base day
- # baseTime - Base time expressed in seconds from the Posix epoch
- # changeover - Julian day on which the Gregorian calendar was
- # adpoted in the target locale.
- #
- # Results:
- # Returns the given dictionary augmented with a 'julianDay' field
- # that contains the base day.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } {
- variable TZData
- # Find the Julian Day Number corresponding to the base time
- set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover]
- dict set date julianDay [dict get $date2 julianDay]
- return $date
- }
- #----------------------------------------------------------------------
- #
- # InterpretHMSP --
- #
- # Interprets a time in the form "hh:mm:ss am".
- #
- # Parameters:
- # date -- Dictionary containing "hourAMPM", "minute", "second"
- # and "amPmIndicator" fields.
- #
- # Results:
- # Returns the number of seconds from local midnight.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::InterpretHMSP { date } {
- set hr [dict get $date hourAMPM]
- if { $hr == 12 } {
- set hr 0
- }
- if { [dict get $date amPmIndicator] } {
- incr hr 12
- }
- dict set date hour $hr
- return [InterpretHMS $date[set date {}]]
- }
- #----------------------------------------------------------------------
- #
- # InterpretHMS --
- #
- # Interprets a 24-hour time "hh:mm:ss"
- #
- # Parameters:
- # date -- Dictionary containing the "hour", "minute" and "second"
- # fields.
- #
- # Results:
- # Returns the given dictionary augmented with a "secondOfDay"
- # field containing the number of seconds from local midnight.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::InterpretHMS { date } {
- return [expr { ( [dict get $date hour] * 60
- + [dict get $date minute] ) * 60
- + [dict get $date second] }]
- }
- #----------------------------------------------------------------------
- #
- # GetSystemTimeZone --
- #
- # Determines the system time zone, which is the default for the
- # 'clock' command if no other zone is supplied.
- #
- # Parameters:
- # None.
- #
- # Results:
- # Returns the system time zone.
- #
- # Side effects:
- # Stores the sustem time zone in the 'CachedSystemTimeZone'
- # variable, since determining it may be an expensive process.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::GetSystemTimeZone {} {
- variable CachedSystemTimeZone
- variable TimeZoneBad
- if {[set result [getenv TCL_TZ]] ne {}} {
- set timezone $result
- } elseif {[set result [getenv TZ]] ne {}} {
- set timezone $result
- }
- if {![info exists timezone]} {
- # Cache the time zone only if it was detected by one of the
- # expensive methods.
- if { [info exists CachedSystemTimeZone] } {
- set timezone $CachedSystemTimeZone
- } elseif { $::tcl_platform(platform) eq {windows} } {
- set timezone [GuessWindowsTimeZone]
- } elseif { [file exists /etc/localtime]
- && ![catch {ReadZoneinfoFile \
- Tcl/Localtime /etc/localtime}] } {
- set timezone :Tcl/Localtime
- } else {
- set timezone :localtime
- }
- set CachedSystemTimeZone $timezone
- }
- if { ![dict exists $TimeZoneBad $timezone] } {
- dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
- }
- if { [dict get $TimeZoneBad $timezone] } {
- return :localtime
- } else {
- return $timezone
- }
- }
- #----------------------------------------------------------------------
- #
- # ConvertLegacyTimeZone --
- #
- # Given an alphanumeric time zone identifier and the system
- # time zone, convert the alphanumeric identifier to an
- # unambiguous time zone.
- #
- # Parameters:
- # tzname - Name of the time zone to convert
- #
- # Results:
- # Returns a time zone name corresponding to tzname, but
- # in an unambiguous form, generally +hhmm.
- #
- # This procedure is implemented primarily to allow the parsing of
- # RFC822 date/time strings. Processing a time zone name on input
- # is not recommended practice, because there is considerable room
- # for ambiguity; for instance, is BST Brazilian Standard Time, or
- # British Summer Time?
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ConvertLegacyTimeZone { tzname } {
- variable LegacyTimeZone
- set tzname [string tolower $tzname]
- if { ![dict exists $LegacyTimeZone $tzname] } {
- return -code error -errorcode [list CLOCK badTZName $tzname] \
- "time zone \"$tzname\" not found"
- } else {
- return [dict get $LegacyTimeZone $tzname]
- }
- }
- #----------------------------------------------------------------------
- #
- # SetupTimeZone --
- #
- # Given the name or specification of a time zone, sets up
- # its in-memory data.
- #
- # Parameters:
- # tzname - Name of a time zone
- #
- # Results:
- # Unless the time zone is ':localtime', sets the TZData array
- # to contain the lookup table for local<->UTC conversion.
- # Returns an error if the time zone cannot be parsed.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::SetupTimeZone { timezone } {
- variable TZData
- if {! [info exists TZData($timezone)] } {
- variable MINWIDE
- if { $timezone eq {:localtime} } {
- # Nothing to do, we'll convert using the localtime function
- } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
- -> s hh mm ss] } {
- # Make a fixed offset
- ::scan $hh %d hh
- if { $mm eq {} } {
- set mm 0
- } else {
- ::scan $mm %d mm
- }
- if { $ss eq {} } {
- set ss 0
- } else {
- ::scan $ss %d ss
- }
- set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }]
- if { $s eq {-} } {
- set offset [expr { - $offset }]
- }
- set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]]
- } elseif { [string index $timezone 0] eq {:} } {
-
- # Convert using a time zone file
- if {
- [catch {
- LoadTimeZoneFile [string range $timezone 1 end]
- }]
- && [catch {
- LoadZoneinfoFile [string range $timezone 1 end]
- }]
- } {
- return -code error \
- -errorcode [list CLOCK badTimeZone $timezone] \
- "time zone \"$timezone\" not found"
- }
-
- } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
-
- # This looks like a POSIX time zone - try to process it
- if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
- if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
- dict unset opts -errorinfo
- }
- return -options $opts $data
- } else {
- set TZData($timezone) $data
- }
- } else {
- # We couldn't parse this as a POSIX time zone. Try
- # again with a time zone file - this time without a colon
- if { [catch { LoadTimeZoneFile $timezone }]
- && [catch { LoadZoneinfoFile $timezone } - opts] } {
- dict unset opts -errorinfo
- return -options $opts "time zone $timezone not found"
- }
- set TZData($timezone) $TZData(:$timezone)
- }
- }
- return
- }
- #----------------------------------------------------------------------
- #
- # GuessWindowsTimeZone --
- #
- # Determines the system time zone on windows.
- #
- # Parameters:
- # None.
- #
- # Results:
- # Returns a time zone specifier that corresponds to the system
- # time zone information found in the Registry.
- #
- # Bugs:
- # Fixed dates for DST change are unimplemented at present, because
- # no time zone information supplied with Windows actually uses
- # them!
- #
- # On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is
- # specified, GuessWindowsTimeZone looks in the Registry for the
- # system time zone information. It then attempts to find an entry
- # in WinZoneInfo for a time zone that uses the same rules. If
- # it finds one, it returns it; otherwise, it constructs a Posix-style
- # time zone string and returns that.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::GuessWindowsTimeZone {} {
- variable WinZoneInfo
- variable NoRegistry
- variable TimeZoneBad
- if { [info exists NoRegistry] } {
- return :localtime
- }
- # Dredge time zone information out of the registry
- if { [catch {
- set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation
- set data [list \
- [expr { -60
- * [registry get $rpath Bias] }] \
- [expr { -60
- * [registry get $rpath StandardBias] }] \
- [expr { -60 \
- * [registry get $rpath DaylightBias] }]]
- set stdtzi [registry get $rpath StandardStart]
- foreach ind {0 2 14 4 6 8 10 12} {
- binary scan $stdtzi @${ind}s val
- lappend data $val
- }
- set daytzi [registry get $rpath DaylightStart]
- foreach ind {0 2 14 4 6 8 10 12} {
- binary scan $daytzi @${ind}s val
- lappend data $val
- }
- }] } {
- # Missing values in the Registry - bail out
- return :localtime
- }
- # Make up a Posix time zone specifier if we can't find one.
- # Check here that the tzdata file exists, in case we're running
- # in an environment (e.g. starpack) where tzdata is incomplete.
- # (Bug 1237907)
- if { [dict exists $WinZoneInfo $data] } {
- set tzname [dict get $WinZoneInfo $data]
- if { ! [dict exists $TimeZoneBad $tzname] } {
- dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}]
- }
- } else {
- set tzname {}
- }
- if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } {
- lassign $data \
- bias stdBias dstBias \
- stdYear stdMonth stdDayOfWeek stdDayOfMonth \
- stdHour stdMinute stdSecond stdMillisec \
- dstYear dstMonth dstDayOfWeek dstDayOfMonth \
- dstHour dstMinute dstSecond dstMillisec
- set stdDelta [expr { $bias + $stdBias }]
- set dstDelta [expr { $bias + $dstBias }]
- if { $stdDelta <= 0 } {
- set stdSignum +
- set stdDelta [expr { - $stdDelta }]
- set dispStdSignum -
- } else {
- set stdSignum -
- set dispStdSignum +
- }
- set hh [::format %02d [expr { $stdDelta / 3600 }]]
- set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]]
- set ss [::format %02d [expr { $stdDelta % 60 }]]
- set tzname {}
- append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss
- if { $stdMonth >= 0 } {
- if { $dstDelta <= 0 } {
- set dstSignum +
- set dstDelta [expr { - $dstDelta }]
- set dispDstSignum -
- } else {
- set dstSignum -
- set dispDstSignum +
- }
- set hh [::format %02d [expr { $dstDelta / 3600 }]]
- set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]]
- set ss [::format %02d [expr { $dstDelta % 60 }]]
- append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss
- if { $dstYear == 0 } {
- append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
- } else {
- # I have not been able to find any locale on which
- # Windows converts time zone on a fixed day of the year,
- # hence don't know how to interpret the fields.
- # If someone can inform me, I'd be glad to code it up.
- # For right now, we bail out in such a case.
- return :localtime
- }
- append tzname / [::format %02d $dstHour] \
- : [::format %02d $dstMinute] \
- : [::format %02d $dstSecond]
- if { $stdYear == 0 } {
- append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek
- } else {
- # I have not been able to find any locale on which
- # Windows converts time zone on a fixed day of the year,
- # hence don't know how to interpret the fields.
- # If someone can inform me, I'd be glad to code it up.
- # For right now, we bail out in such a case.
- return :localtime
- }
- append tzname / [::format %02d $stdHour] \
- : [::format %02d $stdMinute] \
- : [::format %02d $stdSecond]
- }
- dict set WinZoneInfo $data $tzname
- }
- return [dict get $WinZoneInfo $data]
- }
- #----------------------------------------------------------------------
- #
- # LoadTimeZoneFile --
- #
- # Load the data file that specifies the conversion between a
- # given time zone and Greenwich.
- #
- # Parameters:
- # fileName -- Name of the file to load
- #
- # Results:
- # None.
- #
- # Side effects:
- # TZData(:fileName) contains the time zone data
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::LoadTimeZoneFile { fileName } {
- variable DataDir
- variable TZData
- if { [info exists TZData($fileName)] } {
- return
- }
- # Since an unsafe interp uses the [clock] command in the master,
- # this code is security sensitive. Make sure that the path name
- # cannot escape the given directory.
- if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
- return -code error \
- -errorcode [list CLOCK badTimeZone $:fileName] \
- "time zone \":$fileName\" not valid"
- }
- if { [catch {
- source -encoding utf-8 [file join $DataDir $fileName]
- }] } {
- return -code error \
- -errorcode [list CLOCK badTimeZone :$fileName] \
- "time zone \":$fileName\" not found"
- }
- return
- }
- #----------------------------------------------------------------------
- #
- # LoadZoneinfoFile --
- #
- # Loads a binary time zone information file in Olson format.
- #
- # Parameters:
- # fileName - Relative path name of the file to load.
- #
- # Results:
- # Returns an empty result normally; returns an error if no
- # Olson file was found or the file was malformed in some way.
- #
- # Side effects:
- # TZData(:fileName) contains the time zone data
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::LoadZoneinfoFile { fileName } {
- variable ZoneinfoPaths
- # Since an unsafe interp uses the [clock] command in the master,
- # this code is security sensitive. Make sure that the path name
- # cannot escape the given directory.
- if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
- return -code error \
- -errorcode [list CLOCK badTimeZone $:fileName] \
- "time zone \":$fileName\" not valid"
- }
- foreach d $ZoneinfoPaths {
- set fname [file join $d $fileName]
- if { [file readable $fname] && [file isfile $fname] } {
- break
- }
- unset fname
- }
- ReadZoneinfoFile $fileName $fname
- }
- #----------------------------------------------------------------------
- #
- # ReadZoneinfoFile --
- #
- # Loads a binary time zone information file in Olson format.
- #
- # Parameters:
- # fileName - Name of the time zone (relative path name of the
- # file).
- # fname - Absolute path name of the file.
- #
- # Results:
- # Returns an empty result normally; returns an error if no
- # Olson file was found or the file was malformed in some way.
- #
- # Side effects:
- # TZData(:fileName) contains the time zone data
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
- variable MINWIDE
- variable TZData
- if { ![file exists $fname] } {
- return -code error "$fileName not found"
- }
- if { [file size $fname] > 262144 } {
- return -code error "$fileName too big"
- }
- # Suck in all the data from the file
- set f [open $fname r]
- fconfigure $f -translation binary
- set d [read $f]
- close $f
- # The file begins with a magic number, sixteen reserved bytes,
- # and then six 4-byte integers giving counts of fileds in the file.
- binary scan $d a4a1x15IIIIII \
- magic version nIsGMT nIsStd nLeap nTime nType nChar
- set seek 44
- set ilen 4
- set iformat I
- if { $magic != {TZif} } {
- return -code error "$fileName not a time zone information file"
- }
- if { $nType > 255 } {
- return -code error "$fileName contains too many time types"
- }
- # Accept only Posix-style zoneinfo. Sorry, 'leaps' bigots.
- if { $nLeap != 0 } {
- return -code error "$fileName contains leap seconds"
- }
- # In a version 2 file, we use the second part of the file, which
- # contains 64-bit transition times.
- if {$version eq "2"} {
- set seek [expr {44
- + 5 * $nTime
- + 6 * $nType
- + 4 * $nLeap
- + $nIsStd
- + $nIsGMT
- + $nChar
- }]
- binary scan $d @${seek}a4a1x15IIIIII \
- magic version nIsGMT nIsStd nLeap nTime nType nChar
- if {$magic ne {TZif}} {
- return -code error "seek address $seek miscomputed, magic = $magic"
- }
- set iformat W
- set ilen 8
- incr seek 44
- }
- # Next come ${nTime} transition times, followed by ${nTime} time type
- # codes. The type codes are unsigned 1-byte quantities. We insert an
- # arbitrary start time in front of the transitions.
- binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
- incr seek [expr { ($ilen + 1) * $nTime }]
- set times [linsert $times 0 $MINWIDE]
- set codes {}
- foreach c $tempCodes {
- lappend codes [expr { $c & 0xff }]
- }
- set codes [linsert $codes 0 0]
- # Next come ${nType} time type descriptions, each of which has an
- # offset (seconds east of GMT), a DST indicator, and an index into
- # the abbreviation text.
- for { set i 0 } { $i < $nType } { incr i } {
- binary scan $d @${seek}Icc gmtOff isDst abbrInd
- lappend types [list $gmtOff $isDst $abbrInd]
- incr seek 6
- }
- # Next come $nChar characters of time zone name abbreviations,
- # which are null-terminated.
- # We build them up into a dictionary indexed by character index,
- # because that's what's in the indices above.
- binary scan $d @${seek}a${nChar} abbrs
- incr seek ${nChar}
- set abbrList [split $abbrs \0]
- set i 0
- set abbrevs {}
- foreach a $abbrList {
- for {set j 0} {$j <= [string length $a]} {incr j} {
- dict set abbrevs $i [string range $a $j end]
- incr i
- }
- }
- # Package up a list of tuples, each of which contains transition time,
- # seconds east of Greenwich, DST flag and time zone abbreviation.
- set r {}
- set lastTime $MINWIDE
- foreach t $times c $codes {
- if { $t < $lastTime } {
- return -code error "$fileName has times out of order"
- }
- set lastTime $t
- lassign [lindex $types $c] gmtoff isDst abbrInd
- set abbrev [dict get $abbrevs $abbrInd]
- lappend r [list $t $gmtoff $isDst $abbrev]
- }
- # In a version 2 file, there is also a POSIX-style time zone description
- # at the very end of the file. To get to it, skip over
- # nLeap leap second values (8 bytes each),
- # nIsStd standard/DST indicators and nIsGMT UTC/local indicators.
- if {$version eq {2}} {
- set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}]
- set last [string first \n $d $seek]
- set posix [string range $d $seek [expr {$last-1}]]
- if {[llength $posix] > 0} {
- set posixFields [ParsePosixTimeZone $posix]
- foreach tuple [ProcessPosixTimeZone $posixFields] {
- lassign $tuple t gmtoff isDst abbrev
- if {$t > $lastTime} {
- lappend r $tuple
- }
- }
- }
- }
- set TZData(:$fileName) $r
- return
- }
- #----------------------------------------------------------------------
- #
- # ParsePosixTimeZone --
- #
- # Parses the TZ environment variable in Posix form
- #
- # Parameters:
- # tz Time zone specifier to be interpreted
- #
- # Results:
- # Returns a dictionary whose values contain the various pieces of
- # the time zone specification.
- #
- # Side effects:
- # None.
- #
- # Errors:
- # Throws an error if the syntax of the time zone is incorrect.
- #
- # The following keys are present in the dictionary:
- # stdName - Name of the time zone when Daylight Saving Time
- # is not in effect.
- # stdSignum - Sign (+, -, or empty) of the offset from Greenwich
- # to the given (non-DST) time zone. + and the empty
- # string denote zones west of Greenwich, - denotes east
- # of Greenwich; this is contrary to the ISO convention
- # but follows Posix.
- # stdHours - Hours part of the offset from Greenwich to the given
- # (non-DST) time zone.
- # stdMinutes - Minutes part of the offset from Greenwich to the
- # given (non-DST) time zone. Empty denotes zero.
- # stdSeconds - Seconds part of the offset from Greenwich to the
- # given (non-DST) time zone. Empty denotes zero.
- # dstName - Name of the time zone when DST is in effect, or the
- # empty string if the time zone does not observe Daylight
- # Saving Time.
- # dstSignum, dstHours, dstMinutes, dstSeconds -
- # Fields corresponding to stdSignum, stdHours, stdMinutes,
- # stdSeconds for the Daylight Saving Time version of the
- # time zone. If dstHours is empty, it is presumed to be 1.
- # startDayOfYear - The ordinal number of the day of the year on which
- # Daylight Saving Time begins. If this field is
- # empty, then DST begins on a given month-week-day,
- # as below.
- # startJ - The letter J, or an empty string. If a J is present in
- # this field, then startDayOfYear does not count February 29
- # even in leap years.
- # startMonth - The number of the month in which Daylight Saving Time
- # begins, supplied if startDayOfYear is empty. If both
- # startDayOfYear and startMonth are empty, then US rules
- # are presumed.
- # startWeekOfMonth - The number of the week in the month in which
- # Daylight Saving Time begins, in the range 1-5.
- # 5 denotes the last week of the month even in a
- # 4-week month.
- # startDayOfWeek - The number of the day of the week (Sunday=0,
- # Saturday=6) on which Daylight Saving Time begins.
- # startHours - The hours part of the time of day at which Daylight
- # Saving Time begins. An empty string is presumed to be 2.
- # startMinutes - The minutes part of the time of day at which DST begins.
- # An empty string is presumed zero.
- # startSeconds - The seconds part of the time of day at which DST begins.
- # An empty string is presumed zero.
- # endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek,
- # endHours, endMinutes, endSeconds -
- # Specify the end of DST in the same way that the start* fields
- # specify the beginning of DST.
- #
- # This procedure serves only to break the time specifier into fields.
- # No attempt is made to canonicalize the fields or supply default values.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ParsePosixTimeZone { tz } {
- if {[regexp -expanded -nocase -- {
- ^
- # 1 - Standard time zone name
- ([[:alpha:]]+ | <[-+[:alnum:]]+>)
- # 2 - Standard time zone offset, signum
- ([-+]?)
- # 3 - Standard time zone offset, hours
- ([[:digit:]]{1,2})
- (?:
- # 4 - Standard time zone offset, minutes
- : ([[:digit:]]{1,2})
- (?:
- # 5 - Standard time zone offset, seconds
- : ([[:digit:]]{1,2} )
- )?
- )?
- (?:
- # 6 - DST time zone name
- ([[:alpha:]]+ | <[-+[:alnum:]]+>)
- (?:
- (?:
- # 7 - DST time zone offset, signum
- ([-+]?)
- # 8 - DST time zone offset, hours
- ([[:digit:]]{1,2})
- (?:
- # 9 - DST time zone offset, minutes
- : ([[:digit:]]{1,2})
- (?:
- # 10 - DST time zone offset, seconds
- : ([[:digit:]]{1,2})
- )?
- )?
- )?
- (?:
- ,
- (?:
- # 11 - Optional J in n and Jn form 12 - Day of year
- ( J ? ) ( [[:digit:]]+ )
- | M
- # 13 - Month number 14 - Week of month 15 - Day of week
- ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- )
- (?:
- # 16 - Start time of DST - hours
- / ( [[:digit:]]{1,2} )
- (?:
- # 17 - Start time of DST - minutes
- : ( [[:digit:]]{1,2} )
- (?:
- # 18 - Start time of DST - seconds
- : ( [[:digit:]]{1,2} )
- )?
- )?
- )?
- ,
- (?:
- # 19 - Optional J in n and Jn form 20 - Day of year
- ( J ? ) ( [[:digit:]]+ )
- | M
- # 21 - Month number 22 - Week of month 23 - Day of week
- ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- [.] ( [[:digit:]] + )
- )
- (?:
- # 24 - End time of DST - hours
- / ( [[:digit:]]{1,2} )
- (?:
- # 25 - End time of DST - minutes
- : ( [[:digit:]]{1,2} )
- (?:
- # 26 - End time of DST - seconds
- : ( [[:digit:]]{1,2} )
- )?
- )?
- )?
- )?
- )?
- )?
- $
- } $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \
- x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \
- x(startJ) x(startDayOfYear) \
- x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \
- x(startHours) x(startMinutes) x(startSeconds) \
- x(endJ) x(endDayOfYear) \
- x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \
- x(endHours) x(endMinutes) x(endSeconds)] } {
- # it's a good timezone
- return [array get x]
- } else {
- return -code error\
- -errorcode [list CLOCK badTimeZone $tz] \
- "unable to parse time zone specification \"$tz\""
- }
- }
- #----------------------------------------------------------------------
- #
- # ProcessPosixTimeZone --
- #
- # Handle a Posix time zone after it's been broken out into
- # fields.
- #
- # Parameters:
- # z - Dictionary returned from 'ParsePosixTimeZone'
- #
- # Results:
- # Returns time zone information for the 'TZData' array.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ProcessPosixTimeZone { z } {
- variable MINWIDE
- variable TZData
- # Determine the standard time zone name and seconds east of Greenwich
- set stdName [dict get $z stdName]
- if { [string index $stdName 0] eq {<} } {
- set stdName [string range $stdName 1 end-1]
- }
- if { [dict get $z stdSignum] eq {-} } {
- set stdSignum +1
- } else {
- set stdSignum -1
- }
- set stdHours [lindex [::scan [dict get $z stdHours] %d] 0]
- if { [dict get $z stdMinutes] ne {} } {
- set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0]
- } else {
- set stdMinutes 0
- }
- if { [dict get $z stdSeconds] ne {} } {
- set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0]
- } else {
- set stdSeconds 0
- }
- set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes )
- * 60 + $stdSeconds )
- * $stdSignum }]
- set data [list [list $MINWIDE $stdOffset 0 $stdName]]
- # If there's no daylight zone, we're done
- set dstName [dict get $z dstName]
- if { $dstName eq {} } {
- return $data
- }
- if { [string index $dstName 0] eq {<} } {
- set dstName [string range $dstName 1 end-1]
- }
- # Determine the daylight name
- if { [dict get $z dstSignum] eq {-} } {
- set dstSignum +1
- } else {
- set dstSignum -1
- }
- if { [dict get $z dstHours] eq {} } {
- set dstOffset [expr { 3600 + $stdOffset }]
- } else {
- set dstHours [lindex [::scan [dict get $z dstHours] %d] 0]
- if { [dict get $z dstMinutes] ne {} } {
- set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0]
- } else {
- set dstMinutes 0
- }
- if { [dict get $z dstSeconds] ne {} } {
- set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0]
- } else {
- set dstSeconds 0
- }
- set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes )
- * 60 + $dstSeconds )
- * $dstSignum }]
- }
- # Fill in defaults for European or US DST rules
- # US start time is the second Sunday in March
- # EU start time is the last Sunday in March
- # US end time is the first Sunday in November.
- # EU end time is the last Sunday in October
- if { [dict get $z startDayOfYear] eq {}
- && [dict get $z startMonth] eq {} } {
- if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
- # EU
- dict set z startWeekOfMonth 5
- if {$stdHours>2} {
- dict set z startHours 2
- } else {
- dict set z startHours [expr {$stdHours+1}]
- }
- } else {
- # US
- dict set z startWeekOfMonth 2
- dict set z startHours 2
- }
- dict set z startMonth 3
- dict set z startDayOfWeek 0
- dict set z startMinutes 0
- dict set z startSeconds 0
- }
- if { [dict get $z endDayOfYear] eq {}
- && [dict get $z endMonth] eq {} } {
- if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
- # EU
- dict set z endMonth 10
- dict set z endWeekOfMonth 5
- if {$stdHours>2} {
- dict set z endHours 3
- } else {
- dict set z endHours [expr {$stdHours+2}]
- }
- } else {
- # US
- dict set z endMonth 11
- dict set z endWeekOfMonth 1
- dict set z endHours 2
- }
- dict set z endDayOfWeek 0
- dict set z endMinutes 0
- dict set z endSeconds 0
- }
- # Put DST in effect in all years from 1916 to 2099.
- for { set y 1916 } { $y < 2100 } { incr y } {
- set startTime [DeterminePosixDSTTime $z start $y]
- incr startTime [expr { - wide($stdOffset) }]
- set endTime [DeterminePosixDSTTime $z end $y]
- incr endTime [expr { - wide($dstOffset) }]
- if { $startTime < $endTime } {
- lappend data \
- [list $startTime $dstOffset 1 $dstName] \
- [list $endTime $stdOffset 0 $stdName]
- } else {
- lappend data \
- [list $endTime $stdOffset 0 $stdName] \
- [list $startTime $dstOffset 1 $dstName]
- }
- }
- return $data
-
- }
- #----------------------------------------------------------------------
- #
- # DeterminePosixDSTTime --
- #
- # Determines the time that Daylight Saving Time starts or ends
- # from a Posix time zone specification.
- #
- # Parameters:
- # z - Time zone data returned from ParsePosixTimeZone.
- # Missing fields are expected to be filled in with
- # default values.
- # bound - The word 'start' or 'end'
- # y - The year for which the transition time is to be determined.
- #
- # Results:
- # Returns the transition time as a count of seconds from
- # the epoch. The time is relative to the wall clock, not UTC.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
- variable FEB_28
- # Determine the start or end day of DST
- set date [dict create era CE year $y]
- set doy [dict get $z ${bound}DayOfYear]
- if { $doy ne {} } {
- # Time was specified as a day of the year
- if { [dict get $z ${bound}J] ne {}
- && [IsGregorianLeapYear $y]
- && ( $doy > $FEB_28 ) } {
- incr doy
- }
- dict set date dayOfYear $doy
- set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222]
- } else {
- # Time was specified as a day of the week within a month
- dict set date month [dict get $z ${bound}Month]
- dict set date dayOfWeek [dict get $z ${bound}DayOfWeek]
- set dowim [dict get $z ${bound}WeekOfMonth]
- if { $dowim >= 5 } {
- set dowim -1
- }
- dict set date dayOfWeekInMonth $dowim
- set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222]
- }
- set jd [dict get $date julianDay]
- set seconds [expr { wide($jd) * wide(86400)
- - wide(210866803200) }]
- set h [dict get $z ${bound}Hours]
- if { $h eq {} } {
- set h 2
- } else {
- set h [lindex [::scan $h %d] 0]
- }
- set m [dict get $z ${bound}Minutes]
- if { $m eq {} } {
- set m 0
- } else {
- set m [lindex [::scan $m %d] 0]
- }
- set s [dict get $z ${bound}Seconds]
- if { $s eq {} } {
- set s 0
- } else {
- set s [lindex [::scan $s %d] 0]
- }
- set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
- return [expr { $seconds + $tod }]
- }
- #----------------------------------------------------------------------
- #
- # GetLocaleEra --
- #
- # Given local time expressed in seconds from the Posix epoch,
- # determine localized era and year within the era.
- #
- # Parameters:
- # date - Dictionary that must contain the keys, 'localSeconds',
- # whose value is expressed as the appropriate local time;
- # and 'year', whose value is the Gregorian year.
- # etable - Value of the LOCALE_ERAS key in the message catalogue
- # for the target locale.
- #
- # Results:
- # Returns the dictionary, augmented with the keys, 'localeEra'
- # and 'localeYear'.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::GetLocaleEra { date etable } {
- set index [BSearch $etable [dict get $date localSeconds]]
- if { $index < 0} {
- dict set date localeEra \
- [::format %02d [expr { [dict get $date year] / 100 }]]
- dict set date localeYear \
- [expr { [dict get $date year] % 100 }]
- } else {
- dict set date localeEra [lindex $etable $index 1]
- dict set date localeYear [expr { [dict get $date year]
- - [lindex $etable $index 2] }]
- }
- return $date
- }
- #----------------------------------------------------------------------
- #
- # GetJulianDayFromEraYearDay --
- #
- # Given a year, month and day on the Gregorian calendar, determines
- # the Julian Day Number beginning at noon on that date.
- #
- # Parameters:
- # date -- A dictionary in which the 'era', 'year', and
- # 'dayOfYear' slots are populated. The calendar in use
- # is determined by the date itself relative to:
- # changeover -- Julian day on which the Gregorian calendar was
- # adopted in the current locale.
- #
- # Results:
- # Returns the given dictionary augmented with a 'julianDay' key
- # whose value is the desired Julian Day Number, and a 'gregorian'
- # key that specifies whether the calendar is Gregorian (1) or
- # Julian (0).
- #
- # Side effects:
- # None.
- #
- # Bugs:
- # This code needs to be moved to the C layer.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
- # Get absolute year number from the civil year
- switch -exact -- [dict get $date era] {
- BCE {
- set year [expr { 1 - [dict get $date year] }]
- }
- CE {
- set year [dict get $date year]
- }
- }
- set ym1 [expr { $year - 1 }]
- # Try the Gregorian calendar first.
- dict set date gregorian 1
- set jd [expr { 1721425
- + [dict get $date dayOfYear]
- + ( 365 * $ym1 )
- + ( $ym1 / 4 )
- - ( $ym1 / 100 )
- + ( $ym1 / 400 ) }]
-
- # If the date is before the Gregorian change, use the Julian calendar.
- if { $jd < $changeover } {
- dict set date gregorian 0
- set jd [expr { 1721423
- + [dict get $date dayOfYear]
- + ( 365 * $ym1 )
- + ( $ym1 / 4 ) }]
- }
- dict set date julianDay $jd
- return $date
- }
- #----------------------------------------------------------------------
- #
- # GetJulianDayFromEraYearMonthWeekDay --
- #
- # Determines the Julian Day number corresponding to the nth
- # given day-of-the-week in a given month.
- #
- # Parameters:
- # date - Dictionary containing the keys, 'era', 'year', 'month'
- # 'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'.
- # changeover - Julian Day of adoption of the Gregorian calendar
- #
- # Results:
- # Returns the given dictionary, augmented with a 'julianDay' key.
- #
- # Side effects:
- # None.
- #
- # Bugs:
- # This code needs to be moved to the C layer.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} {
- # Come up with a reference day; either the zeroeth day of the
- # given month (dayOfWeekInMonth >= 0) or the seventh day of the
- # following month (dayOfWeekInMonth < 0)
- set date2 $date
- set week [dict get $date dayOfWeekInMonth]
- if { $week >= 0 } {
- dict set date2 dayOfMonth 0
- } else {
- dict incr date2 month
- dict set date2 dayOfMonth 7
- }
- set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}] \
- $changeover]
- set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \
- [dict get $date2 julianDay]]
- dict set date julianDay [expr { $wd0 + 7 * $week }]
- return $date
- }
- #----------------------------------------------------------------------
- #
- # IsGregorianLeapYear --
- #
- # Determines whether a given date represents a leap year in the
- # Gregorian calendar.
- #
- # Parameters:
- # date -- The date to test. The fields, 'era', 'year' and 'gregorian'
- # must be set.
- #
- # Results:
- # Returns 1 if the year is a leap year, 0 otherwise.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::IsGregorianLeapYear { date } {
- switch -exact -- [dict get $date era] {
- BCE {
- set year [expr { 1 - [dict get $date year]}]
- }
- CE {
- set year [dict get $date year]
- }
- }
- if { $year % 4 != 0 } {
- return 0
- } elseif { ![dict get $date gregorian] } {
- return 1
- } elseif { $year % 400 == 0 } {
- return 1
- } elseif { $year % 100 == 0 } {
- return 0
- } else {
- return 1
- }
- }
- #----------------------------------------------------------------------
- #
- # WeekdayOnOrBefore --
- #
- # Determine the nearest day of week (given by the 'weekday'
- # parameter, Sunday==0) on or before a given Julian Day.
- #
- # Parameters:
- # weekday -- Day of the week
- # j -- Julian Day number
- #
- # Results:
- # Returns the Julian Day Number of the desired date.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
- set k [expr { ( $weekday + 6 ) % 7 }]
- return [expr { $j - ( $j - $k ) % 7 }]
- }
- #----------------------------------------------------------------------
- #
- # BSearch --
- #
- # Service procedure that does binary search in several places
- # inside the 'clock' command.
- #
- # Parameters:
- # list - List of lists, sorted in ascending order by the
- # first elements
- # key - Value to search for
- #
- # Results:
- # Returns the index of the greatest element in $list that is less
- # than or equal to $key.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::BSearch { list key } {
- if {[llength $list] == 0} {
- return -1
- }
- if { $key < [lindex $list 0 0] } {
- return -1
- }
- set l 0
- set u [expr { [llength $list] - 1 }]
- while { $l < $u } {
- # At this point, we know that
- # $k >= [lindex $list $l 0]
- # Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
- # We find the midpoint of the interval {l,u} rounded UP, compare
- # against it, and set l or u to maintain the invariant. Note
- # that the interval shrinks at each step, guaranteeing convergence.
- set m [expr { ( $l + $u + 1 ) / 2 }]
- if { $key >= [lindex $list $m 0] } {
- set l $m
- } else {
- set u [expr { $m - 1 }]
- }
- }
- return $l
- }
- #----------------------------------------------------------------------
- #
- # clock add --
- #
- # Adds an offset to a given time.
- #
- # Syntax:
- # clock add clockval ?count unit?... ?-option value?
- #
- # Parameters:
- # clockval -- Starting time value
- # count -- Amount of a unit of time to add
- # unit -- Unit of time to add, must be one of:
- # years year months month weeks week
- # days day hours hour minutes minute
- # seconds second
- #
- # Options:
- # -gmt BOOLEAN
- # (Deprecated) Flag synonymous with '-timezone :GMT'
- # -timezone ZONE
- # Name of the time zone in which calculations are to be done.
- # -locale NAME
- # Name of the locale in which calculations are to be done.
- # Used to determine the Gregorian change date.
- #
- # Results:
- # Returns the given time adjusted by the given offset(s) in
- # order.
- #
- # Notes:
- # It is possible that adding a number of months or years will adjust
- # the day of the month as well. For instance, the time at
- # one month after 31 January is either 28 or 29 February, because
- # February has fewer than 31 days.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::add { clockval args } {
- if { [llength $args] % 2 != 0 } {
- set cmdName "clock add"
- return -code error \
- -errorcode [list CLOCK wrongNumArgs] \
- "wrong \# args: should be\
- \"$cmdName clockval ?number units?...\
- ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\""
- }
- if { [catch { expr {wide($clockval)} } result] } {
- return -code error $result
- }
- set offsets {}
- set gmt 0
- set locale c
- set timezone [GetSystemTimeZone]
- foreach { a b } $args {
- if { [string is integer -strict $a] } {
- lappend offsets $a $b
- } else {
- switch -exact -- $a {
- -g - -gm - -gmt {
- set gmt $b
- }
- -l - -lo - -loc - -loca - -local - -locale {
- set locale [string tolower $b]
- }
- -t - -ti - -tim - -time - -timez - -timezo - -timezon -
- -timezone {
- set timezone $b
- }
- default {
- return -code error \
- -errorcode [list CLOCK badSwitch $a] \
- "bad switch \"$a\",\
- must be -gmt, -locale or -timezone"
- }
- }
- }
- }
- # Check options for validity
- if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } {
- return -code error \
- -errorcode [list CLOCK gmtWithTimezone] \
- "cannot use -gmt and -timezone in same call"
- }
- if { [catch { expr { wide($clockval) } } result] } {
- return -code error \
- "expected integer but got \"$clockval\""
- }
- if { ![string is boolean $gmt] } {
- return -code error \
- "expected boolean value but got \"$gmt\""
- } else {
- if { $gmt } {
- set timezone :GMT
- }
- }
- EnterLocale $locale oldLocale
-
- set changeover [mc GREGORIAN_CHANGE_DATE]
- if {[catch {SetupTimeZone $timezone} retval opts]} {
- dict unset opts -errorinfo
- return -options $opts $retval
- }
- set status [catch {
- foreach { quantity unit } $offsets {
- switch -exact -- $unit {
- years - year {
- set clockval \
- [AddMonths [expr { 12 * $quantity }] \
- $clockval $timezone $changeover]
- }
- months - month {
- set clockval [AddMonths $quantity $clockval $timezone \
- $changeover]
- }
- weeks - week {
- set clockval [AddDays [expr { 7 * $quantity }] \
- $clockval $timezone $changeover]
- }
- days - day {
- set clockval [AddDays $quantity $clockval $timezone \
- $changeover]
- }
- hours - hour {
- set clockval [expr { 3600 * $quantity + $clockval }]
- }
- minutes - minute {
- set clockval [expr { 60 * $quantity + $clockval }]
- }
- seconds - second {
- set clockval [expr { $quantity + $clockval }]
- }
- default {
- error "unknown unit \"$unit\", must be \
- years, months, weeks, days, hours, minutes or seconds" \
- "unknown unit \"$unit\", must be \
- years, months, weeks, days, hours, minutes or seconds" \
- [list CLOCK badUnit $unit]
- }
- }
- }
- } result opts]
- # Restore the locale
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
- if { $status == 1 } {
- if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
- dict unset opts -errorinfo
- }
- return -options $opts $result
- } else {
- return $clockval
- }
- }
- #----------------------------------------------------------------------
- #
- # AddMonths --
- #
- # Add a given number of months to a given clock value in a given
- # time zone.
- #
- # Parameters:
- # months - Number of months to add (may be negative)
- # clockval - Seconds since the epoch before the operation
- # timezone - Time zone in which the operation is to be performed
- #
- # Results:
- # Returns the new clock value as a number of seconds since
- # the epoch.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
- variable DaysInRomanMonthInCommonYear
- variable DaysInRomanMonthInLeapYear
- variable TZData
- # Convert the time to year, month, day, and fraction of day.
- set date [GetDateFields $clockval $TZData($timezone) $changeover]
- dict set date secondOfDay [expr { [dict get $date localSeconds]
- % 86400 }]
- dict set date tzName $timezone
- # Add the requisite number of months
- set m [dict get $date month]
- incr m $months
- incr m -1
- set delta [expr { $m / 12 }]
- set mm [expr { $m % 12 }]
- dict set date month [expr { $mm + 1 }]
- dict incr date year $delta
- # If the date doesn't exist in the current month, repair it
- if { [IsGregorianLeapYear $date] } {
- set hath [lindex $DaysInRomanMonthInLeapYear $mm]
- } else {
- set hath [lindex $DaysInRomanMonthInCommonYear $mm]
- }
- if { [dict get $date dayOfMonth] > $hath } {
- dict set date dayOfMonth $hath
- }
- # Reconvert to a number of seconds
- set date [GetJulianDayFromEraYearMonthDay \
- $date[set date {}]\
- $changeover]
- dict set date localSeconds \
- [expr { -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay] }]
- set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
- $changeover]
- return [dict get $date seconds]
- }
- #----------------------------------------------------------------------
- #
- # AddDays --
- #
- # Add a given number of days to a given clock value in a given
- # time zone.
- #
- # Parameters:
- # days - Number of days to add (may be negative)
- # clockval - Seconds since the epoch before the operation
- # timezone - Time zone in which the operation is to be performed
- # changeover - Julian Day on which the Gregorian calendar was adopted
- # in the target locale.
- #
- # Results:
- # Returns the new clock value as a number of seconds since
- # the epoch.
- #
- # Side effects:
- # None.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::AddDays { days clockval timezone changeover } {
- variable TZData
- # Convert the time to Julian Day
- set date [GetDateFields $clockval $TZData($timezone) $changeover]
- dict set date secondOfDay [expr { [dict get $date localSeconds]
- % 86400 }]
- dict set date tzName $timezone
- # Add the requisite number of days
- dict incr date julianDay $days
- # Reconvert to a number of seconds
- dict set date localSeconds \
- [expr { -210866803200
- + ( 86400 * wide([dict get $date julianDay]) )
- + [dict get $date secondOfDay] }]
- set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \
- $changeover]
- return [dict get $date seconds]
- }
- #----------------------------------------------------------------------
- #
- # mc --
- #
- # Wrapper around ::msgcat::mc that caches the result according
- # to the locale.
- #
- # Parameters:
- # Accepts the name of the message to retrieve.
- #
- # Results:
- # Returns the message text.
- #
- # Side effects:
- # Caches the message text.
- #
- # Notes:
- # Only the single-argument version of [mc] is supported.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::mc { name } {
- variable McLoaded
- set Locale [mclocale]
- if { [dict exists $McLoaded $Locale $name] } {
- return [dict get $McLoaded $Locale $name]
- } else {
- set val [::msgcat::mc $name]
- dict set McLoaded $Locale $name $val
- return $val
- }
- }
- #----------------------------------------------------------------------
- #
- # ClearCaches --
- #
- # Clears all caches to reclaim the memory used in [clock]
- #
- # Parameters:
- # None.
- #
- # Results:
- # None.
- #
- # Side effects:
- # Caches are cleared.
- #
- #----------------------------------------------------------------------
- proc ::tcl::clock::ClearCaches {} {
- variable FormatProc
- variable LocaleNumeralCache
- variable McLoaded
- variable CachedSystemTimeZone
- variable TimeZoneBad
- foreach p [info procs [namespace current]::scanproc'*] {
- rename $p {}
- }
- foreach p [info procs [namespace current]::formatproc'*] {
- rename $p {}
- }
- catch {unset FormatProc}
- set LocaleNumeralCache {}
- set McLoaded {}
- catch {unset CachedSystemTimeZone}
- set TimeZoneBad {}
- InitTZData
- }
|