Posted to tcl by kbk at Sat Aug 01 21:04:07 GMT 2009view raw

  1. if {![package vsatisfies [info tclversion] 8.5]} {
  2. package require newclock
  3. }
  4.  
  5. namespace eval rfc2822 {
  6.  
  7. variable datepats {}
  8.  
  9. }
  10.  
  11. # AddDatePat --
  12. #
  13. # Internal procedure that adds a date pattern to the pattern list
  14. #
  15. # Parameters:
  16. # wpat - Regexp pattern that matches the weekday
  17. # wgrp - Format group that matches the weekday
  18. # ypat - Regexp pattern that matches the year
  19. # ygrp - Format group that matches the year
  20. # spat - Regexp pattern that matches the seconds of the minute
  21. # sgrp - Format group that matches the seconds of the minute
  22. # zpat - Regexp pattern that matches the time zone
  23. # zgrp - Format group that matches the time zone
  24. #
  25. # Results:
  26. # None
  27. #
  28. # Side effects:
  29. # Adds a complete regexp and a complete [clock scan] pattern to
  30. # 'datepats'
  31.  
  32. proc rfc2822::AddDatePat { wpat wgrp ypat ygrp spat sgrp zpat zgrp } {
  33.  
  34. variable datepats
  35. set regexp {^[[:space:]]*}
  36. set pat {}
  37. append regexp $wpat {\d\d?[[:space:]]+[[:alpha:]]+[[:space:]]+} $ypat
  38. append pat $wgrp {%d %b } $ygrp
  39. append regexp {[[:space:]]+\d\d?:\d\d} $spat
  40. append pat { %H:%M} $sgrp
  41. append regexp $zpat
  42. append pat $zgrp
  43. append regexp {[[:space:]]*$}
  44. lappend datepats $regexp $pat
  45. return
  46. }
  47.  
  48. # InitDatePats --
  49. #
  50. # Internal rocedure that initializes the set of date patterns allowed in
  51. # an RFC2822 date
  52. #
  53. # Parameters:
  54. # permissible - 1 if erroneous (but common) time zones are to be
  55. # allowed, 0 if they are to be rejected
  56. #
  57. # Results:
  58. # None.
  59. #
  60. # Side effects:
  61.  
  62. proc rfc2822::InitDatePats { permissible } {
  63.  
  64. # Produce formats for the observed variants of ISO2822 dates. Permissible
  65. # variants come first in the list; impermissible ones come later.
  66.  
  67. # The year may be two digits, or four. Four digit year is done first.
  68.  
  69. foreach ypat {{\d\d\d\d} {\d\d}} ygrp {%Y %y} {
  70.  
  71. # The seconds of the minute may be provided, or omitted.
  72.  
  73. foreach spat {{:\d\d} {}} sgrp {:%S {}} {
  74.  
  75. # The weekday may be provided or omitted. It is common but
  76. # impermissible to omit the comma after the weekday name.
  77.  
  78. foreach wpat {
  79. {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un)),[[:space:]]+}
  80. {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un))[[:space:]]+}
  81. {}
  82. } wgrp {
  83. {%a, }
  84. {%a }
  85. {}
  86. } wperm {
  87. 1
  88. 0
  89. 1
  90. } {
  91.  
  92. # Time zone is defined as +/- hhmm, or as a named time zone.
  93. # Other common but buggy formats are GMT+-hh:mm, a time
  94. # zone name in quotation marks, and complete omission of
  95. # the time zone.
  96.  
  97. foreach zpat {
  98. {[[:space:]]+(?:[-+]\d\d\d\d|[[:alpha:]]+)}
  99. {[[:space:]]+GMT[-+]\d\d:\d\d}
  100. {[[:space:]]+"[[:alpha:]]+"}
  101. {}
  102. } zgrp {
  103. { %Z}
  104. { GMT%Z}
  105. { "%Z"}
  106. {}
  107. } zperm {
  108. 1
  109. 0
  110. 0
  111. 0
  112. } {
  113. if { ($zperm && $wperm) == $permissible } {
  114. AddDatePat $wpat $wgrp $ypat $ygrp \
  115. $spat $sgrp $zpat $zgrp
  116. }
  117. }
  118. }
  119. }
  120. }
  121. return
  122. }
  123.  
  124. # Initialize the date patterns
  125.  
  126. namespace eval rfc2822 {
  127. InitDatePats 1
  128. InitDatePats 0
  129. rename AddDatePat {}
  130. rename InitDatePats {}
  131. }
  132.  
  133. # rfc2822::parseDate --
  134. #
  135. # Parses a date expressed in RFC2822 format
  136. #
  137. # Parameters:
  138. # date - The date to parse
  139. #
  140. # Results:
  141. # Returns the date expressed in seconds from the Epoch, or throws
  142. # an error if the date could not be parsed.
  143.  
  144. proc rfc2822::parseDate { date } {
  145. variable datepats
  146.  
  147. # Strip comments and excess whitespace from the date field
  148.  
  149. regsub -all -expanded {
  150. \( # open parenthesis
  151. (:?
  152. [^()[.\.]] # character other than ()\
  153. |\\. # or backslash escape
  154. )* # any number of times
  155. \) # close paren
  156. } $date {} date
  157. set date [string trim $date]
  158.  
  159. # Match the patterns in order of preference, returning the first success
  160.  
  161. foreach {regexp pat} $datepats {
  162. if { [regexp -nocase $regexp $date] } {
  163. return [clock scan $date -format $pat]
  164. }
  165. }
  166.  
  167. return -code error -errorcode {RFC2822 BADDATE} \
  168. "expected an RFC2822 date, got \"$date\""
  169.  
  170. }
  171.  
  172. # Usage example
  173.  
  174. if {![info exists ::argv0] || [info script] ne $::argv0} return
  175. puts [clock format \
  176. [rfc2822::parseDate {Mon(day), 23 Aug(ust) 2004 01:23:45 UT}]]