Changeset 9695 in project


Ignore:
Timestamp:
03/15/08 02:02:26 (12 years ago)
Author:
Kon Lovett
Message:

Rel 1.7.0

Location:
release/3/srfi-29
Files:
12 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/3/srfi-29/tags/1.7.0/srfi-29-eggdoc.scm

    r8942 r9695  
    33(use eggdoc)
    44
    5 (define license #<<EOF
    6 "Copyright (c) 2005, Kon Lovett.  All rights reserved.
     5(define license
     6#<<EOS
     7"Copyright (c) 2005-2008, Kon Lovett.  All rights reserved.
    78
    89Permission is hereby granted, free of charge, to any person obtaining a
     
    2324ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
    2425OTHER DEALINGS IN THE SOFTWARE.
    25 EOF
     26EOS
    2627)
    2728
    28 (define examples '((pre #<<EOF
    29 EOF
     29#;
     30(define examples
     31'((pre #<<EOS
     32EOS
    3033)))
    3134
     
    3437    (name "srfi-29")
    3538    (description (p "Localization"))
    36     (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
     39    (author
     40      (url "mailto:klovett@pacbell.net" "Kon Lovett"))
     41
     42    (requires
     43      lookup-table
     44      miscmacros
     45      locale )
     46
     47    (usage)
     48    (download "srfi-29.egg")
     49
     50    (documentation
     51
     52      (p "A Chicken implementation of "
     53        (url "http://srfi.schemers.org/srfi-29/srfi-29.html" "SRFI 29") ".")
     54
     55      (p "Bundles are assumed stored in the system bundle directory, "
     56      (code "(repository-path) \"srfi-29-bundles\"") ".")
     57
     58      (p "Within a bundle directory the structure is "
     59      (code "[LANGUAGE [COUNTRY [SCRIPT [CODESET [MODIFIER]]]]] PACKAGE-NAME") ".")
     60
     61      (p "The default language is " (code "en") ". The default country is " (code "us") ". "
     62      "The locale package will override these if a locale is set. Otherwise "
     63      "the user must set the corresponding parameters.")
     64
     65      (p "Any object which can be returned by " (code "(read)") " and tested for equality "
     66      "with " (code "equal?") " is acceptable as a " (tt "TEMPLATE-NAME") ". "
     67      "So strings are a valid " (tt "TEMPLATE-NAME") ". Further, "
     68      (code "(localized-template ...)") " will return any object which can be returned by "
     69      (code "(read)") ", not just a string.")
     70
     71      (p "Aborts with the composite condition " (code "(exn srfi-29)") " and properties "
     72      (code "location") ", " (code "message") ", and " (code "arguments") " for errors.")
     73
     74      (subsection "Parameters"
     75
     76        (parameter "(current-language [LANGUAGE])"
     77          (p "Gets or sets the " (tt "LANGUAGE") ".") )
     78
     79        (parameter "(current-country [COUNTRY])"
     80          (p "Gets or sets the " (tt "COUNTRY") ".") )
     81
     82        (parameter "(current-locale-details [LOCALE-DETAILS])"
     83          (p "Gets or sets the " (tt "LOCALE-DETAILS") ".") )
     84
     85        (parameter "(current-locale-format-function [FORMAT-PROCEDURE])"
     86          (p "Gets or sets the " (tt "FORMAT-PROCEDURE") ".") )
     87      )
     88
     89      (subsection "Procedures"
     90
     91        (procedure "(reset-locale-parameters)"
     92          (p "If you change the " (code "current-locale") " "
     93          "(see the " (url "eggs/locale.html" "locale") " egg), "
     94          "you don't have to set all the " (code "current-foo") " "
     95          "parameters. You can simply call this "
     96          "procedure, and it will update those parameters to the values "
     97          "in the new locale. (Reset as in set anew.)") )
     98
     99        (procedure "(most-specific-bundle-specifier PACKAGE-NAME)"
     100          (p "Returns the most specific bundle specifier for the "
     101          "current language, country, and locale details.") )
     102
     103        (procedure "(declare-bundle! BUNDLE-SPECIFIER BUNDLE-ALIST)"
     104          (p "Creates a bundle.") )
     105
     106        (procedure "(undeclare-bundle! BUNDLE-SPECIFIER)"
     107          (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
     108          "from the active bundles.") )
     109
     110        (procedure "(store-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     111          (p "Writes the bundle.")
     112
     113          (p "Uses the " (tt "ALTERNATE-DIRECTORY") " if specified.") )
     114
     115        (procedure "(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     116          (p "Reads the bundle.")
     117
     118          (p "Uses the " (tt "ALTERNATE-DIRECTORY") " if specified.") )
     119
     120        (procedure "(load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     121          (p "Attempts " (code "(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])") ", "
     122          "from most to least specific.") )
     123
     124        (procedure "(remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     125          (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
     126          "from the active bundles, and from the filesystem. The bundle "
     127          "directory is " (tt "ALTERNATE-DIRECTORY") ", unless missing. "
     128          "Then the system bundle directory is used.")
     129
     130          (p "Will not remove the locale directory hierarchy created by "
     131          (code "(store-bundle! ...)") ".") )
     132
     133        (procedure "(remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     134          (p "Removes the bundle directory hierarchy created by " (code "(store-bundle! ...)") ". "
     135          "Will only remove empty directories. Returns " (code "#t") " if operation "
     136          "succeeded, " (code "#f") " when a non-empty directory encountered.")
     137
     138          (p "Does not remove the bundle, if any, from the active bundles. "
     139          "A filesystem only operation.")
     140
     141          (p "This procedure should be used with caution.") )
     142
     143        (procedure "(localized-template PACKAGE-NAME TEMPLATE-NAME [DEFAULT #f])"
     144          (p "Returns the object for the " (tt "TEMPLATE-NAME") " in " (tt "PACKAGE-NAME") ", "
     145          "when found, otherwise the " (tt "DEFAULT") ".") )
     146
     147        (procedure "(localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])"
     148          (p "Returns " (code "(localized-template PACKAGE-NAME TEMPLATE-NAME DEFAULT)") ".")
     149
     150          (p "Somewhat like the Posix 'gettext' routine.") )
     151
     152        (procedure "(localized-format PACKAGE-NAME TEMPLATE-NAME PORT ARG0 ...)"
     153          (p "Formats the arguments " (tt "ARG0 ...") " to the " (tt "PORT") " "
     154          "using the " (code "(current-locale-format-function)") " and the "
     155          "format string " (code "(localized-template PACKAGE-NAME TEMPLATE-NAME)") ".")
     156
     157          (p "A representation is always displayed, even when no template is found. "
     158          "Just not a localized one.") )
     159       )
     160     )
     161
     162    (section "Issues"
     163
     164      (p "Possible race condition creating a bundle file or directory.")
     165
     166      (p "The locale symbols must have a lowercase printname! As such "
     167      "they do not truly reflect ISO 639-1/2 & ISO 3166-1 standard "
     168      "names. This is a SRFI 29 restriction.")
     169
     170      (p (code "(current-locale-details)") " is ill-defined by SRFI 29. "
     171      "Which symbol means what? This implementation defines locale details as a "
     172      "3 element list " (code "(SCRIPT CODESET MODIFIER)") " where the "
     173      "elements are symbols or " (code "#f") ".")
     174    )
     175
     176    #;
     177    (examples ,examples)
     178
    37179    (history
     180     (version "1.7.0" "Cached template lookup. 'localized-template' takes default parameter. Added 'localized-format', 'current-locale-format-function'.")
     181     (version "1.6.0" "Support for missing locale component stated as " (code "#f") ".")
    38182     (version "1.501" "Dropped :optional")
    39183     (version "1.5" "Fixed nasty locale-details handling bug")
     
    44188     (version "1.0" "Initial release"))
    45189
    46     (requires
    47       lookup-table miscmacros locale "chicken > 2.223")
    48 
    49     (usage)
    50     (download "srfi-29.egg")
    51 
    52     (documentation
    53 
    54       (p "A Chicken implementation of SRFI-29. This document only describes "
    55       "the extensions. For the SRFI-29 API see "
    56       (url "http://srfi.schemers.org/srfi-29/srfi-29.html" "SRFI-29") ".")
    57 
    58       (p "Bundles are assumed stored in the system bundle directory, "
    59       (code "(repository-path) srfi-29-bundles") ". Within a bundle directory "
    60       "the structure is " (code "[(language) [(country)]] (module)") ".")
    61 
    62       (p "The default language is " (code "en") ". The default country is " (code "us") ". "
    63       "The locale package will override these if a locale is set. Otherwise "
    64       "the user must set the corresponding parameters.")
    65 
    66       (subsection "Extensions to SRFI-29"
    67 
    68         (p "The " (code "store-bundle") " and " (code "load-bundle!") " "
    69         "procedures accept an optional directory as the "
    70         "second argument, overriding the system bundle directory.")
    71 
    72         (p "Any object which can be returned by " (code "read") " and tested for equality "
    73         "with " (code "equal?") " is acceptable as a " (i "message-template-name") ". "
    74         "So strings are a valid " (i "message-template-name") ". Further, "
    75         (code "localized-template") " can return any object which can be returned by "
    76         (code "read") ", not just strings.")
    77 
    78         (procedure "(reset-locale-parameters)"
    79           (p "If you change current-locale (see the locale egg "
    80           "documentation), you don't have to set the current-language and "
    81           "current-country parameters, you can simply call this "
    82           "procedure, and it will update those parameters to the values "
    83           "in the new locale. (Reset as in set anew.)") )
    84 
    85         (procedure "(most-specific-bundle-specifier PACKAGE-NAME)"
    86           (p "Returns the most specific bundle specifier for the "
    87           "current language, country, and locale details.") )
    88 
    89         (procedure "(load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])"
    90           (p "Attempts " (code "(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])") ", "
    91           "from most to least specific.") )
    92 
    93         (procedure "(localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])"
    94           (p "Returns " (code "(localized-template PACKAGE-NAME TEMPLATE-NAME)") ", "
    95           "when found, otherwise the " (tt "DEFAULT") ". Somewhat like the Posix 'gettext' "
    96           "routine.") )
    97 
    98         (procedure "(undeclare-bundle! BUNDLE-SPECIFIER)"
    99           (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
    100           "from the active bundles.") )
    101 
    102         (procedure "(remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])"
    103           (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
    104           "from the active bundles, and from the filesystem. The bundle "
    105           "directory is " (tt "ALTERNATE-DIR") ", unless missing. "
    106           "Then the system bundle directory is used.")
    107 
    108           (p "Will not remove the language [country] directory hierarchy "
    109           "created by " (tt "store-bundle!") ".") )
    110 
    111         (procedure "(remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIR])"
    112           (p "Removes the bundle directory hierarchy created by " (tt "store-bundle!") ". "
    113           "Will only remove empty directories. Returns " (code "#t") " if operation "
    114           "succeeded, " (code "#f") " when a non-empty directory encountered.")
    115 
    116           (p "Does not remove the bundle, if any, from the active bundles. "
    117           "A filesystem only operation.")
    118 
    119           (p "This procedure should not be used lightly!") )
    120       )
    121      )
    122 
    123     (section "Issues"
    124 
    125       (p "Signals the composite condition " (code "(exn srfi-29)") " with properties "
    126       (code "location") ", " (code "message") ", and " (code "arguments") ".")
    127 
    128       (p "Possible race condition creating a bundle file or directory.")
    129 
    130       (p "Any locale details are ignored, for now, if part of a bundle specifier.") )
    131 
    132       (p (code "current-locale-details") " is ill-defined, which symbol means "
    133       "what? This implementation defines details as an upto 3 element list, "
    134       "([script] [codeset] [modifier]), where the elements are symbols.")
    135 
    136       (p "The locale symbols must have a lowercase printname! As such "
    137       "they do not truly reflect ISO 639-1/2 & ISO 3166-1 standard "
    138       "names. This is a SRFI-29 restriction.")
    139 
    140     #;(examples ,examples)
    141 
    142190    (section "License" (pre ,license))
    143191  )
    144 ))
     192) )
    145193
    146194(eggdoc->html doc)
  • release/3/srfi-29/tags/1.7.0/srfi-29.html

    r8942 r9695  
    156156<h3>Author</h3><a href="mailto:klovett@pacbell.net">Kon Lovett</a></div>
    157157<div class="section">
     158<h3>Requires</h3>
     159<ul>
     160<li>lookup-table</li>
     161<li>miscmacros</li>
     162<li>locale</li></ul></div>
     163<div class="section">
     164<h3>Usage</h3><tt>(require-extension srfi-29)</tt></div>
     165<div class="section">
     166<h3>Download</h3><a href="srfi-29.egg">srfi-29.egg</a></div>
     167<div class="section">
     168<h3>Documentation</h3>
     169<p>A Chicken implementation of <a href="http://srfi.schemers.org/srfi-29/srfi-29.html">SRFI 29</a>.</p>
     170<p>Bundles are assumed stored in the system bundle directory, <code>(repository-path) &quot;srfi-29-bundles&quot;</code>.</p>
     171<p>Within a bundle directory the structure is <code>[LANGUAGE [COUNTRY [SCRIPT [CODESET [MODIFIER]]]]] PACKAGE-NAME</code>.</p>
     172<p>The default language is <code>en</code>. The default country is <code>us</code>. The locale package will override these if a locale is set. Otherwise the user must set the corresponding parameters.</p>
     173<p>Any object which can be returned by <code>(read)</code> and tested for equality with <code>equal?</code> is acceptable as a <tt>TEMPLATE-NAME</tt>. So strings are a valid <tt>TEMPLATE-NAME</tt>. Further, <code>(localized-template ...)</code> will return any object which can be returned by <code>(read)</code>, not just a string.</p>
     174<p>Aborts with the composite condition <code>(exn srfi-29)</code> and properties <code>location</code>, <code>message</code>, and <code>arguments</code> for errors.</p>
     175<div class="subsection">
     176<h4>Parameters</h4>
     177<dt class="definition"><strong>parameter:</strong> (current-language [LANGUAGE])</dt>
     178<dd>
     179<p>Gets or sets the <tt>LANGUAGE</tt>.</p></dd>
     180<dt class="definition"><strong>parameter:</strong> (current-country [COUNTRY])</dt>
     181<dd>
     182<p>Gets or sets the <tt>COUNTRY</tt>.</p></dd>
     183<dt class="definition"><strong>parameter:</strong> (current-locale-details [LOCALE-DETAILS])</dt>
     184<dd>
     185<p>Gets or sets the <tt>LOCALE-DETAILS</tt>.</p></dd>
     186<dt class="definition"><strong>parameter:</strong> (current-locale-format-function [FORMAT-PROCEDURE])</dt>
     187<dd>
     188<p>Gets or sets the <tt>FORMAT-PROCEDURE</tt>.</p></dd></div>
     189<div class="subsection">
     190<h4>Procedures</h4>
     191<dt class="definition"><strong>procedure:</strong> (reset-locale-parameters)</dt>
     192<dd>
     193<p>If you change the <code>current-locale</code> (see the <a href="eggs/locale.html">locale</a> egg), you don't have to set all the <code>current-foo</code> parameters. You can simply call this procedure, and it will update those parameters to the values in the new locale. (Reset as in set anew.)</p></dd>
     194<dt class="definition"><strong>procedure:</strong> (most-specific-bundle-specifier PACKAGE-NAME)</dt>
     195<dd>
     196<p>Returns the most specific bundle specifier for the current language, country, and locale details.</p></dd>
     197<dt class="definition"><strong>procedure:</strong> (declare-bundle! BUNDLE-SPECIFIER BUNDLE-ALIST)</dt>
     198<dd>
     199<p>Creates a bundle.</p></dd>
     200<dt class="definition"><strong>procedure:</strong> (undeclare-bundle! BUNDLE-SPECIFIER)</dt>
     201<dd>
     202<p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles.</p></dd>
     203<dt class="definition"><strong>procedure:</strong> (store-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     204<dd>
     205<p>Writes the bundle.</p>
     206<p>Uses the <tt>ALTERNATE-DIRECTORY</tt> if specified.</p></dd>
     207<dt class="definition"><strong>procedure:</strong> (load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     208<dd>
     209<p>Reads the bundle.</p>
     210<p>Uses the <tt>ALTERNATE-DIRECTORY</tt> if specified.</p></dd>
     211<dt class="definition"><strong>procedure:</strong> (load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     212<dd>
     213<p>Attempts <code>(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</code>, from most to least specific.</p></dd>
     214<dt class="definition"><strong>procedure:</strong> (remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     215<dd>
     216<p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles, and from the filesystem. The bundle directory is <tt>ALTERNATE-DIRECTORY</tt>, unless missing. Then the system bundle directory is used.</p>
     217<p>Will not remove the locale directory hierarchy created by <code>(store-bundle! ...)</code>.</p></dd>
     218<dt class="definition"><strong>procedure:</strong> (remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     219<dd>
     220<p>Removes the bundle directory hierarchy created by <code>(store-bundle! ...)</code>. Will only remove empty directories. Returns <code>#t</code> if operation succeeded, <code>#f</code> when a non-empty directory encountered.</p>
     221<p>Does not remove the bundle, if any, from the active bundles. A filesystem only operation.</p>
     222<p>This procedure should be used with caution.</p></dd>
     223<dt class="definition"><strong>procedure:</strong> (localized-template PACKAGE-NAME TEMPLATE-NAME [DEFAULT #f])</dt>
     224<dd>
     225<p>Returns the object for the <tt>TEMPLATE-NAME</tt> in <tt>PACKAGE-NAME</tt>, when found, otherwise the <tt>DEFAULT</tt>.</p></dd>
     226<dt class="definition"><strong>procedure:</strong> (localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])</dt>
     227<dd>
     228<p>Returns <code>(localized-template PACKAGE-NAME TEMPLATE-NAME DEFAULT)</code>.</p>
     229<p>Somewhat like the Posix 'gettext' routine.</p></dd>
     230<dt class="definition"><strong>procedure:</strong> (localized-format PACKAGE-NAME TEMPLATE-NAME PORT ARG0 ...)</dt>
     231<dd>
     232<p>Formats the arguments <tt>ARG0 ...</tt> to the <tt>PORT</tt> using the <code>(current-locale-format-function)</code> and the format string <code>(localized-template PACKAGE-NAME TEMPLATE-NAME)</code>.</p>
     233<p>A representation is always displayed, even when no template is found. Just not a localized one.</p></dd></div></div>
     234<div class="section">
     235<h3>Issues</h3>
     236<p>Possible race condition creating a bundle file or directory.</p>
     237<p>The locale symbols must have a lowercase printname! As such they do not truly reflect ISO 639-1/2 &amp; ISO 3166-1 standard names. This is a SRFI 29 restriction.</p>
     238<p><code>(current-locale-details)</code> is ill-defined by SRFI 29. Which symbol means what? This implementation defines locale details as a 3 element list <code>(SCRIPT CODESET MODIFIER)</code> where the elements are symbols or <code>#f</code>.</p></div>
     239<div class="section">
    158240<h3>Version</h3>
    159241<ul>
     242<li>1.7.0 Cached template lookup. 'localized-template' takes default parameter. Added 'localized-format', 'current-locale-format-function'.</li>
     243<li>1.6.0 Support for missing locale component stated as <code>#f</code>.</li>
    160244<li>1.501 Dropped :optional</li>
    161245<li>1.5 Fixed nasty locale-details handling bug</li>
     
    166250<li>1.0 Initial release</li></ul></div>
    167251<div class="section">
    168 <h3>Requires</h3>
    169 <ul>
    170 <li>lookup-table</li>
    171 <li>miscmacros</li>
    172 <li>locale</li>
    173 <li>chicken &gt; 2.223</li></ul></div>
    174 <div class="section">
    175 <h3>Usage</h3><tt>(require-extension srfi-29)</tt></div>
    176 <div class="section">
    177 <h3>Download</h3><a href="srfi-29.egg">srfi-29.egg</a></div>
    178 <div class="section">
    179 <h3>Documentation</h3>
    180 <p>A Chicken implementation of SRFI-29. This document only describes the extensions. For the SRFI-29 API see <a href="http://srfi.schemers.org/srfi-29/srfi-29.html">SRFI-29</a>.</p>
    181 <p>Bundles are assumed stored in the system bundle directory, <code>(repository-path) srfi-29-bundles</code>. Within a bundle directory the structure is <code>[(language) [(country)]] (module)</code>.</p>
    182 <p>The default language is <code>en</code>. The default country is <code>us</code>. The locale package will override these if a locale is set. Otherwise the user must set the corresponding parameters.</p>
    183 <div class="subsection">
    184 <h4>Extensions to SRFI-29</h4>
    185 <p>The <code>store-bundle</code> and <code>load-bundle!</code> procedures accept an optional directory as the second argument, overriding the system bundle directory.</p>
    186 <p>Any object which can be returned by <code>read</code> and tested for equality with <code>equal?</code> is acceptable as a <i>message-template-name</i>. So strings are a valid <i>message-template-name</i>. Further, <code>localized-template</code> can return any object which can be returned by <code>read</code>, not just strings.</p>
    187 <dt class="definition"><strong>procedure:</strong> (reset-locale-parameters)</dt>
    188 <dd>
    189 <p>If you change current-locale (see the locale egg documentation), you don't have to set the current-language and current-country parameters, you can simply call this procedure, and it will update those parameters to the values in the new locale. (Reset as in set anew.)</p></dd>
    190 <dt class="definition"><strong>procedure:</strong> (most-specific-bundle-specifier PACKAGE-NAME)</dt>
    191 <dd>
    192 <p>Returns the most specific bundle specifier for the current language, country, and locale details.</p></dd>
    193 <dt class="definition"><strong>procedure:</strong> (load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])</dt>
    194 <dd>
    195 <p>Attempts <code>(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])</code>, from most to least specific.</p></dd>
    196 <dt class="definition"><strong>procedure:</strong> (localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])</dt>
    197 <dd>
    198 <p>Returns <code>(localized-template PACKAGE-NAME TEMPLATE-NAME)</code>, when found, otherwise the <tt>DEFAULT</tt>. Somewhat like the Posix 'gettext' routine.</p></dd>
    199 <dt class="definition"><strong>procedure:</strong> (undeclare-bundle! BUNDLE-SPECIFIER)</dt>
    200 <dd>
    201 <p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles.</p></dd>
    202 <dt class="definition"><strong>procedure:</strong> (remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])</dt>
    203 <dd>
    204 <p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles, and from the filesystem. The bundle directory is <tt>ALTERNATE-DIR</tt>, unless missing. Then the system bundle directory is used.</p>
    205 <p>Will not remove the language [country] directory hierarchy created by <tt>store-bundle!</tt>.</p></dd>
    206 <dt class="definition"><strong>procedure:</strong> (remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIR])</dt>
    207 <dd>
    208 <p>Removes the bundle directory hierarchy created by <tt>store-bundle!</tt>. Will only remove empty directories. Returns <code>#t</code> if operation succeeded, <code>#f</code> when a non-empty directory encountered.</p>
    209 <p>Does not remove the bundle, if any, from the active bundles. A filesystem only operation.</p>
    210 <p>This procedure should not be used lightly!</p></dd></div></div>
    211 <div class="section">
    212 <h3>Issues</h3>
    213 <p>Signals the composite condition <code>(exn srfi-29)</code> with properties <code>location</code>, <code>message</code>, and <code>arguments</code>.</p>
    214 <p>Possible race condition creating a bundle file or directory.</p>
    215 <p>Any locale details are ignored, for now, if part of a bundle specifier.</p></div>
    216 <p><code>current-locale-details</code> is ill-defined, which symbol means what? This implementation defines details as an upto 3 element list, ([script] [codeset] [modifier]), where the elements are symbols.</p>
    217 <p>The locale symbols must have a lowercase printname! As such they do not truly reflect ISO 639-1/2 &amp; ISO 3166-1 standard names. This is a SRFI-29 restriction.</p>
    218 <div class="section">
    219252<h3>License</h3>
    220 <pre>&quot;Copyright (c) 2005, Kon Lovett.  All rights reserved.
     253<pre>&quot;Copyright (c) 2005-2008, Kon Lovett.  All rights reserved.
    221254
    222255Permission is hereby granted, free of charge, to any person obtaining a
  • release/3/srfi-29/tags/1.7.0/srfi-29.meta

    r8942 r9695  
    77 (egg "srfi-29.egg")
    88 (license "BSD")
    9  (needs miscmacros misc-extn lookup-table locale)
     9 (needs miscmacros misc-extn lookup-table locale misc-extn)
    1010 (files
    1111  "tests"
  • release/3/srfi-29/tags/1.7.0/srfi-29.scm

    r8942 r9695  
    1818;; Within the bundle directory the structure
    1919;; is [(language) [(country) [(details)]]] (module).
    20 
    21 (use srfi-1 srfi-13 posix extras utils srfi-69)
    22 (use miscmacros lookup-table locale)
    2320
    2421(eval-when (compile)
     
    3128    (no-bound-checks)
    3229    (export
    33 
    3430      ;; Extensions
    3531      most-specific-bundle-specifier
     
    4036      remove-bundle-directory!
    4137      load-best-available-bundle!
    42 
    43       ;; SRFI-29
    44       current-language current-country current-locale-details
    45       load-bundle! store-bundle! declare-bundle!
    46       localized-template) ) )
     38      current-locale-format-function
     39      localized-format
     40      ;; SRFI 29
     41      current-language
     42      current-country
     43      current-locale-details
     44      load-bundle!
     45      store-bundle!
     46      declare-bundle!
     47      localized-template ) ) )
     48
     49(use srfi-1 srfi-12 srfi-13 posix extras utils)
     50(use miscmacros lookup-table locale misc-extn-directory)
    4751
    4852;;;
     
    5559
    5660(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
    57 
    58 ;; The bundles dictionary
    59 
    60 (define *localization-bundles* (make-dict 1 equal?))
    6161
    6262;; Um, the user really should set a locale
     
    6767;;;
    6868
     69;;
     70
    6971(define-inline (->symbol obj)
    7072  (string->symbol (->string obj)) )
    7173
    72 (define-inline (->boolean obj)
    73   (not (not obj)) )
     74;;
    7475
    7576(define-inline (make-srfi-29-exception loc msg . args)
     
    7879    (make-property-condition 'srfi-29)) )
    7980
    80 ;; Ensure the directory for the specified path exists.
    81 
    82 (define-inline (create-pathname-directory pathname)
    83   (let loop ([dir (pathname-directory pathname)])
    84     (when dir
    85       (unless (directory? dir)
    86         (loop (pathname-directory dir))
    87         (create-directory dir))) ) )
     81(define-inline (signal-srfi-29-exception loc msg . args)
     82  (abort (apply make-srfi-29-exception loc msg args)) )
     83
     84;;
     85
     86(define-inline (locale-item? x)
     87  (or (not x) (symbol? x)) )
     88
     89(define-inline (locale-details? obj)
     90  (and (list? obj)
     91       (every locale-item? obj)) )
    8892
    8993;; bundle-specifier: (list-of symbol)
    9094;; i.e. package + locale, (package-name [language] [country] [details ...])
    9195
    92 (define-inline (bundle-specification->pathname bundle-specifier)
     96(define (bundle-specification->pathname bundle-specifier)
    9397  (if (null? bundle-specifier)
    94     (signal
    95       (make-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier))
    96     (let ([pn (symbol->string (first bundle-specifier))]
    97           [len (length bundle-specifier)])
    98       (if (eqv? 1 len)
    99         pn
    100         (let ([ln (symbol->string (second bundle-specifier))])
    101           (if (eqv? 2 len)
    102             (make-pathname ln pn)
    103             (make-pathname `(,ln ,(symbol->string (third bundle-specifier))) pn)) ) ))) )
    104 
    105 (define (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
    106   (make-pathname
    107     (optional alternate-dir SYSTEM-BUNDLES)
    108     (bundle-specification->pathname bundle-specifier)) )
    109 
    110 ;;
     98      (signal-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier)
     99      (make-pathname (reverse! (fold (lambda (x l)
     100                                       (if x
     101                                           (cons (symbol->string x) l)
     102                                           l ) )
     103                                     '()
     104                                     (cdr bundle-specifier)))
     105                     (symbol->string (car bundle-specifier))) ) )
     106
     107(define-inline (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
     108  (make-pathname (optional alternate-dir SYSTEM-BUNDLES)
     109                 (bundle-specification->pathname bundle-specifier)) )
     110
     111;; Package Bundle Cache
     112
     113(define *package-bundle-cache* (make-dict 1 eq?))
     114
     115(define (invalidate-package-bundle-cache . bundle-specifier)
     116  (if (not (null? bundle-specifier))
     117      (dict-delete! *package-bundle-cache* (caar bundle-specifier))
     118      (set! *package-bundle-cache* (make-dict 1 eq?)) ) )
     119
     120;; Bundles Dictionary
     121
     122(define *localization-bundles* (make-dict 1 equal?))
    111123
    112124(define-inline (find-bundle bundle-specifier)
    113125  (dict-ref *localization-bundles* bundle-specifier) )
    114126
    115 (define-inline (add-bundle bundle-specifier bundle-alist)
     127(define-inline (set-bundle! bundle-specifier bundle-alist)
    116128  (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) )
    117129
    118 (define-inline (remove-bundle bundle-specifier)
     130(define-inline (reset-bundle! bundle-specifier)
     131  (invalidate-package-bundle-cache bundle-specifier)
    119132  (dict-delete! *localization-bundles* bundle-specifier) )
    120133
     134;;
     135
     136(define-inline (cached-package-bundle package-name thunk)
     137  (or (dict-ref *package-bundle-cache* package-name)
     138      (let loop ([specifier (thunk)])
     139        (and (not (null? specifier))
     140             (if* (find-bundle specifier)
     141                  (begin
     142                    (dict-set! *package-bundle-cache* package-name it)
     143                    it )
     144                  (loop (drop-right! specifier 1)) ) ) ) ) )
     145
    121146;; Canonical current locale
    122147
    123148(define (locale-ref what)
    124   (let* ([locale
    125            (current-locale-components)]
    126          [as-sym
    127            (lambda (v)
    128              (cond
    129                [(symbol? v) v]
    130                [(string? v) (string->symbol (string-downcase v))]
    131                [(not v) v]
    132                [else (->symbol v)]) )]
    133            [opt-locale-component
    134              (lambda (c)
    135                (let ([v (locale-component-ref locale c)])
    136                  (if v
    137                    `(,(as-sym v))
    138                    '()) ) )])
     149  (let ([locale
     150          (current-locale-components)]
     151        [as-sym
     152          (lambda (v)
     153            (cond [(locale-item? v)  v]
     154                  [(string? v)       (string->symbol (string-downcase v))]
     155                  [else              (->symbol v)]) ) ] )
    139156    (switch what
    140       ['language (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
    141       ['country (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
    142       [else `(,@(opt-locale-component 'script) ,@(opt-locale-component 'codeset) ,@(opt-locale-component 'modifier))]) ) )
     157      ['language
     158        (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
     159      ['country
     160        (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
     161      [else
     162        `(,(as-sym (locale-component-ref locale  'script))
     163          ,(as-sym (locale-component-ref locale  'codeset))
     164          ,(as-sym (locale-component-ref locale  'modifier))) ] ) ) )
    143165
    144166;;; Locale Parameters
    145167
    146 (define-parameter current-language (locale-ref 'language)
    147   (lambda (l)
    148     (if (symbol? l) l (current-language)) ) )
    149 
    150 (define-parameter current-country (locale-ref 'country)
    151   (lambda (l)
    152     (if (symbol? l) l (current-country)) ) )
    153 
    154 (define-parameter current-locale-details (locale-ref 'details)
    155   (lambda (lst)
    156     (cond
    157       [(null? lst) lst]
    158       [(and (pair? lst) (every symbol? lst)) lst]
    159       [else (current-locale-details)]) ) )
     168(define-parameter current-locale-format-function
     169  format
     170  (lambda (x)
     171    (if (procedure? x)
     172        x
     173        (begin
     174          (warning 'current-locale-format-function "invalid procedure" x)
     175          (current-locale-format-function) ) ) ) )
     176
     177(define-parameter current-language
     178  (locale-ref 'language)
     179  (lambda (x)
     180    (cond [(locale-item? x)
     181           (invalidate-package-bundle-cache)
     182           x ]
     183          [else
     184           (warning 'current-language "invalid locale item" x)
     185           (current-language) ] ) ) )
     186
     187(define-parameter current-country
     188  (locale-ref 'country)
     189  (lambda (x)
     190    (cond [(locale-item? x)
     191           (invalidate-package-bundle-cache)
     192           x ]
     193          [else
     194           (warning 'current-country "invalid locale item" x)
     195           (current-country) ] ) ) )
     196
     197(define-parameter current-locale-details
     198  (locale-ref 'details)
     199  (lambda (x)
     200    (cond [(locale-details? x)
     201           (invalidate-package-bundle-cache)
     202           x ]
     203          [else
     204            (warning 'current-locale-details "invalid locale item" x)
     205            (current-locale-details) ] ) ) )
    160206
    161207;; If you change (current-locale), you don't have to set current-*
     
    171217;;; Bundle Operations
    172218
     219;;
     220
    173221(define (most-specific-bundle-specifier package-name)
    174222  `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
     
    177225;; its' package name and a template name
    178226
    179 (define-inline (find-any-bundle specifier)
    180   (let loop ([specifier specifier])
    181     (cond
    182       [(null? specifier)        #f]
    183       [(find-bundle specifier)  => identity]
    184       [else
    185         (loop (drop-right specifier 1))]) ) )
    186 
    187 (define (localized-template package-name template-name)
    188   (let loop ([specifier (most-specific-bundle-specifier package-name)])
    189     (and (not (null? specifier))
    190          (and-let* ([bundle (find-any-bundle specifier)])
    191            (cond
    192              [(dict-ref bundle template-name)     => identity]
    193              [(null? (cdr specifier))             #f]
    194              [else
    195                (loop (drop-right specifier 1))]) ) ) ) )
     227(define (localized-template package-name template-name #!optional default)
     228  (let ([bundle (cached-package-bundle package-name
     229                                       (lambda ()
     230                                         (remove!
     231                                          not
     232                                          (most-specific-bundle-specifier package-name))))])
     233    (if bundle
     234        (dict-ref bundle template-name)
     235        default ) ) )
    196236
    197237;;
    198238
    199239(define (localized-template/default package-name template-name #!optional (default template-name))
    200   (or (localized-template package-name template-name) default) )
     240  (localized-template package-name template-name default) )
     241
     242;;
     243
     244(define (localized-format package-name template-name port . fmtargs)
     245  (let ([fmtstr (localized-template package-name template-name)])
     246    (if fmtstr
     247        (apply (current-locale-format-function) port fmtstr fmtargs)
     248        (let ([str (apply conc template-name #\space (intersperse fmtargs #\space))])
     249          (cond [(port? port)                     (display str port)]
     250                [(or (string? port) (not port))   str]
     251                [else                             (display str) ] ) ) ) ) )
    201252
    202253;; Declare a bundle of templates with a given bundle specifier
    203254
    204255(define (declare-bundle! bundle-specifier bundle-alist)
    205   (add-bundle bundle-specifier bundle-alist)
     256  (set-bundle! bundle-specifier bundle-alist)
    206257  #t )
    207258
     
    209260
    210261(define (undeclare-bundle! bundle-specifier)
    211   (remove-bundle bundle-specifier)
     262  (reset-bundle! bundle-specifier)
    212263  #t )
    213264
     
    217268  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    218269    (and (file-exists? path)
    219          (declare-bundle! bundle-specifier (with-input-from-file path read))) ) )
     270         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )
    220271
    221272;; Write bundle to file
     
    223274(define (store-bundle! bundle-specifier . alternate-dir)
    224275  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)]
    225         [can-write?
    226           (lambda (file)
    227             (or (file-write-access? file)
    228                 (signal
    229                   (make-srfi-29-exception 'store-bundle! "no write access" file))) )]
    230         [bundle (find-bundle bundle-specifier)])
     276        [bundle (find-bundle bundle-specifier)] )
    231277    (unless bundle
    232       (signal
    233         (make-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier)))
     278      (signal-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier) )
    234279    (create-pathname-directory path)
    235     (when (and (file-exists? path) (can-write? path))
    236       (delete-file path))
    237     (when (can-write? (pathname-directory path))
    238       (->boolean
    239         (with-output-to-file path
    240           (lambda () (write (dict->alist bundle)))))) ) )
     280    (delete-file* path)
     281    (with-output-to-file path (lambda () (write (dict->alist bundle))))
     282    #t ) )
    241283
    242284;; Remove declared bundle and file, if any
     
    244286(define (remove-bundle! bundle-specifier . alternate-dir)
    245287  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    246     (undeclare-bundle! bundle-specifier)
    247     (when (file-exists? path) (delete-file path) )
     288    (reset-bundle! bundle-specifier)
     289    (delete-file* path)
    248290    #t ) )
    249291
     
    251293
    252294(define (remove-bundle-directory! bundle-specifier . alternate-dir)
    253   (let* ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
     295  (let ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    254296    (delete-file* pathname)
    255297    (let ([topdir (optional alternate-dir SYSTEM-BUNDLES)])
     
    257299        (let* ([dir (pathname-directory path)]
    258300               [fillst (directory dir)])
    259           (cond
    260             [(equal? dir topdir)          #t]
    261             [(positive? (length fillst))  #f]
    262             [else
    263               (delete-directory dir)
    264               (loop dir)]) ) ) ) ) )
     301          (cond [(string=? dir topdir)        #t]
     302                [(positive? (length fillst))  #f]
     303                [else
     304                  (delete-directory dir)
     305                  (loop dir)]) ) ) ) ) )
    265306
    266307;; Try loading from most to least specific, returns #f when failure.
    267308
    268309(define (load-best-available-bundle! bundle-specifier . alternate-dir)
    269   (let loop ([specifier bundle-specifier])
    270     (if (null? specifier)
    271       #f
    272       (or
    273         (apply load-bundle! specifier alternate-dir)
    274         (loop (drop-right specifier 1)))) ) )
     310  (let loop ([specifier (remove not bundle-specifier)])
     311    (and (not (null? specifier))
     312         (or (apply load-bundle! specifier alternate-dir)
     313             (loop (drop-right! specifier 1)))) ) )
  • release/3/srfi-29/tags/1.7.0/srfi-29.setup

    r8942 r9695  
    22
    33(required-extension-version
     4  'misc-extn              "3.1"
    45  'locale                 "0.3.1"
    56  'lookup-table           "1.5"
  • release/3/srfi-29/tags/1.7.0/tests/srfi-29-test.scm

    r8942 r9695  
    3333  )
    3434
    35   (test/case "Bundles Alternate Directory" ([altdir "."])
     35  (test/case "Bundles Alternate Directory"
     36      ([altdir "."])
    3637
    3738    (expect-not-false "B1" (declare-bundle! '(srfi-29-test) bal1))
     
    5455  )
    5556
    56   (test/case "Bundles System Directory" (
    57       [sysdir (make-pathname (repository-path) "srfi-29-bundles")]
    58     )
     57  (test/case "Bundles System Directory"
    5958
    6059    (expect-not-false "B16" (declare-bundle! '(srfi-29-test) bal1))
     
    7776    (expect-not-false "B23.1" (load-bundle! '(srfi-29-test foo)))
    7877    (expect-not-false "B24.1" (load-bundle! '(srfi-29-test foo bar)))
    79 
    80     (expect-not-false "B22.2" (load-best-available-bundle! `(srfi-19 ,(current-language) ,(current-country) ,@(current-locale-details))))
    8178
    8279    (expect-eq "B25" 1 (localized-template 'srfi-29-test 'foo1))
     
    10198
    10299    (expect-true "SysDir RmDir" (remove-bundle-directory! '(srfi-29-test foo bar)))
     100
     101    (expect-success (reset-locale-parameters))
    103102  )
     103
     104  (expect-not-false "B22.2"
     105    (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19)))
     106    (expect-equal (warn "May fail when not English")
     107     "August" (localized-template 'srfi-19 'august))
     108    (expect-equal (warn "May fail when not English")
     109     "December" (localized-template 'srfi-19 'december))
    104110)
    105111
     112(test::for-each (cut test::styler-set! <> test::output-style-human))
    106113(run-test "SRFI-29 Tests")
     114
     115(test::forget!)
  • release/3/srfi-29/trunk/srfi-29-eggdoc.scm

    r8942 r9695  
    33(use eggdoc)
    44
    5 (define license #<<EOF
    6 "Copyright (c) 2005, Kon Lovett.  All rights reserved.
     5(define license
     6#<<EOS
     7"Copyright (c) 2005-2008, Kon Lovett.  All rights reserved.
    78
    89Permission is hereby granted, free of charge, to any person obtaining a
     
    2324ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
    2425OTHER DEALINGS IN THE SOFTWARE.
    25 EOF
     26EOS
    2627)
    2728
    28 (define examples '((pre #<<EOF
    29 EOF
     29#;
     30(define examples
     31'((pre #<<EOS
     32EOS
    3033)))
    3134
     
    3437    (name "srfi-29")
    3538    (description (p "Localization"))
    36     (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
     39    (author
     40      (url "mailto:klovett@pacbell.net" "Kon Lovett"))
     41
     42    (requires
     43      lookup-table
     44      miscmacros
     45      locale )
     46
     47    (usage)
     48    (download "srfi-29.egg")
     49
     50    (documentation
     51
     52      (p "A Chicken implementation of "
     53        (url "http://srfi.schemers.org/srfi-29/srfi-29.html" "SRFI 29") ".")
     54
     55      (p "Bundles are assumed stored in the system bundle directory, "
     56      (code "(repository-path) \"srfi-29-bundles\"") ".")
     57
     58      (p "Within a bundle directory the structure is "
     59      (code "[LANGUAGE [COUNTRY [SCRIPT [CODESET [MODIFIER]]]]] PACKAGE-NAME") ".")
     60
     61      (p "The default language is " (code "en") ". The default country is " (code "us") ". "
     62      "The locale package will override these if a locale is set. Otherwise "
     63      "the user must set the corresponding parameters.")
     64
     65      (p "Any object which can be returned by " (code "(read)") " and tested for equality "
     66      "with " (code "equal?") " is acceptable as a " (tt "TEMPLATE-NAME") ". "
     67      "So strings are a valid " (tt "TEMPLATE-NAME") ". Further, "
     68      (code "(localized-template ...)") " will return any object which can be returned by "
     69      (code "(read)") ", not just a string.")
     70
     71      (p "Aborts with the composite condition " (code "(exn srfi-29)") " and properties "
     72      (code "location") ", " (code "message") ", and " (code "arguments") " for errors.")
     73
     74      (subsection "Parameters"
     75
     76        (parameter "(current-language [LANGUAGE])"
     77          (p "Gets or sets the " (tt "LANGUAGE") ".") )
     78
     79        (parameter "(current-country [COUNTRY])"
     80          (p "Gets or sets the " (tt "COUNTRY") ".") )
     81
     82        (parameter "(current-locale-details [LOCALE-DETAILS])"
     83          (p "Gets or sets the " (tt "LOCALE-DETAILS") ".") )
     84
     85        (parameter "(current-locale-format-function [FORMAT-PROCEDURE])"
     86          (p "Gets or sets the " (tt "FORMAT-PROCEDURE") ".") )
     87      )
     88
     89      (subsection "Procedures"
     90
     91        (procedure "(reset-locale-parameters)"
     92          (p "If you change the " (code "current-locale") " "
     93          "(see the " (url "eggs/locale.html" "locale") " egg), "
     94          "you don't have to set all the " (code "current-foo") " "
     95          "parameters. You can simply call this "
     96          "procedure, and it will update those parameters to the values "
     97          "in the new locale. (Reset as in set anew.)") )
     98
     99        (procedure "(most-specific-bundle-specifier PACKAGE-NAME)"
     100          (p "Returns the most specific bundle specifier for the "
     101          "current language, country, and locale details.") )
     102
     103        (procedure "(declare-bundle! BUNDLE-SPECIFIER BUNDLE-ALIST)"
     104          (p "Creates a bundle.") )
     105
     106        (procedure "(undeclare-bundle! BUNDLE-SPECIFIER)"
     107          (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
     108          "from the active bundles.") )
     109
     110        (procedure "(store-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     111          (p "Writes the bundle.")
     112
     113          (p "Uses the " (tt "ALTERNATE-DIRECTORY") " if specified.") )
     114
     115        (procedure "(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     116          (p "Reads the bundle.")
     117
     118          (p "Uses the " (tt "ALTERNATE-DIRECTORY") " if specified.") )
     119
     120        (procedure "(load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     121          (p "Attempts " (code "(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])") ", "
     122          "from most to least specific.") )
     123
     124        (procedure "(remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     125          (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
     126          "from the active bundles, and from the filesystem. The bundle "
     127          "directory is " (tt "ALTERNATE-DIRECTORY") ", unless missing. "
     128          "Then the system bundle directory is used.")
     129
     130          (p "Will not remove the locale directory hierarchy created by "
     131          (code "(store-bundle! ...)") ".") )
     132
     133        (procedure "(remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])"
     134          (p "Removes the bundle directory hierarchy created by " (code "(store-bundle! ...)") ". "
     135          "Will only remove empty directories. Returns " (code "#t") " if operation "
     136          "succeeded, " (code "#f") " when a non-empty directory encountered.")
     137
     138          (p "Does not remove the bundle, if any, from the active bundles. "
     139          "A filesystem only operation.")
     140
     141          (p "This procedure should be used with caution.") )
     142
     143        (procedure "(localized-template PACKAGE-NAME TEMPLATE-NAME [DEFAULT #f])"
     144          (p "Returns the object for the " (tt "TEMPLATE-NAME") " in " (tt "PACKAGE-NAME") ", "
     145          "when found, otherwise the " (tt "DEFAULT") ".") )
     146
     147        (procedure "(localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])"
     148          (p "Returns " (code "(localized-template PACKAGE-NAME TEMPLATE-NAME DEFAULT)") ".")
     149
     150          (p "Somewhat like the Posix 'gettext' routine.") )
     151
     152        (procedure "(localized-format PACKAGE-NAME TEMPLATE-NAME PORT ARG0 ...)"
     153          (p "Formats the arguments " (tt "ARG0 ...") " to the " (tt "PORT") " "
     154          "using the " (code "(current-locale-format-function)") " and the "
     155          "format string " (code "(localized-template PACKAGE-NAME TEMPLATE-NAME)") ".")
     156
     157          (p "A representation is always displayed, even when no template is found. "
     158          "Just not a localized one.") )
     159       )
     160     )
     161
     162    (section "Issues"
     163
     164      (p "Possible race condition creating a bundle file or directory.")
     165
     166      (p "The locale symbols must have a lowercase printname! As such "
     167      "they do not truly reflect ISO 639-1/2 & ISO 3166-1 standard "
     168      "names. This is a SRFI 29 restriction.")
     169
     170      (p (code "(current-locale-details)") " is ill-defined by SRFI 29. "
     171      "Which symbol means what? This implementation defines locale details as a "
     172      "3 element list " (code "(SCRIPT CODESET MODIFIER)") " where the "
     173      "elements are symbols or " (code "#f") ".")
     174    )
     175
     176    #;
     177    (examples ,examples)
     178
    37179    (history
     180     (version "1.7.0" "Cached template lookup. 'localized-template' takes default parameter. Added 'localized-format', 'current-locale-format-function'.")
     181     (version "1.6.0" "Support for missing locale component stated as " (code "#f") ".")
    38182     (version "1.501" "Dropped :optional")
    39183     (version "1.5" "Fixed nasty locale-details handling bug")
     
    44188     (version "1.0" "Initial release"))
    45189
    46     (requires
    47       lookup-table miscmacros locale "chicken > 2.223")
    48 
    49     (usage)
    50     (download "srfi-29.egg")
    51 
    52     (documentation
    53 
    54       (p "A Chicken implementation of SRFI-29. This document only describes "
    55       "the extensions. For the SRFI-29 API see "
    56       (url "http://srfi.schemers.org/srfi-29/srfi-29.html" "SRFI-29") ".")
    57 
    58       (p "Bundles are assumed stored in the system bundle directory, "
    59       (code "(repository-path) srfi-29-bundles") ". Within a bundle directory "
    60       "the structure is " (code "[(language) [(country)]] (module)") ".")
    61 
    62       (p "The default language is " (code "en") ". The default country is " (code "us") ". "
    63       "The locale package will override these if a locale is set. Otherwise "
    64       "the user must set the corresponding parameters.")
    65 
    66       (subsection "Extensions to SRFI-29"
    67 
    68         (p "The " (code "store-bundle") " and " (code "load-bundle!") " "
    69         "procedures accept an optional directory as the "
    70         "second argument, overriding the system bundle directory.")
    71 
    72         (p "Any object which can be returned by " (code "read") " and tested for equality "
    73         "with " (code "equal?") " is acceptable as a " (i "message-template-name") ". "
    74         "So strings are a valid " (i "message-template-name") ". Further, "
    75         (code "localized-template") " can return any object which can be returned by "
    76         (code "read") ", not just strings.")
    77 
    78         (procedure "(reset-locale-parameters)"
    79           (p "If you change current-locale (see the locale egg "
    80           "documentation), you don't have to set the current-language and "
    81           "current-country parameters, you can simply call this "
    82           "procedure, and it will update those parameters to the values "
    83           "in the new locale. (Reset as in set anew.)") )
    84 
    85         (procedure "(most-specific-bundle-specifier PACKAGE-NAME)"
    86           (p "Returns the most specific bundle specifier for the "
    87           "current language, country, and locale details.") )
    88 
    89         (procedure "(load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])"
    90           (p "Attempts " (code "(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])") ", "
    91           "from most to least specific.") )
    92 
    93         (procedure "(localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])"
    94           (p "Returns " (code "(localized-template PACKAGE-NAME TEMPLATE-NAME)") ", "
    95           "when found, otherwise the " (tt "DEFAULT") ". Somewhat like the Posix 'gettext' "
    96           "routine.") )
    97 
    98         (procedure "(undeclare-bundle! BUNDLE-SPECIFIER)"
    99           (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
    100           "from the active bundles.") )
    101 
    102         (procedure "(remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])"
    103           (p "Removes the bundle specified by " (tt "BUNDLE-SPECIFIER") " "
    104           "from the active bundles, and from the filesystem. The bundle "
    105           "directory is " (tt "ALTERNATE-DIR") ", unless missing. "
    106           "Then the system bundle directory is used.")
    107 
    108           (p "Will not remove the language [country] directory hierarchy "
    109           "created by " (tt "store-bundle!") ".") )
    110 
    111         (procedure "(remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIR])"
    112           (p "Removes the bundle directory hierarchy created by " (tt "store-bundle!") ". "
    113           "Will only remove empty directories. Returns " (code "#t") " if operation "
    114           "succeeded, " (code "#f") " when a non-empty directory encountered.")
    115 
    116           (p "Does not remove the bundle, if any, from the active bundles. "
    117           "A filesystem only operation.")
    118 
    119           (p "This procedure should not be used lightly!") )
    120       )
    121      )
    122 
    123     (section "Issues"
    124 
    125       (p "Signals the composite condition " (code "(exn srfi-29)") " with properties "
    126       (code "location") ", " (code "message") ", and " (code "arguments") ".")
    127 
    128       (p "Possible race condition creating a bundle file or directory.")
    129 
    130       (p "Any locale details are ignored, for now, if part of a bundle specifier.") )
    131 
    132       (p (code "current-locale-details") " is ill-defined, which symbol means "
    133       "what? This implementation defines details as an upto 3 element list, "
    134       "([script] [codeset] [modifier]), where the elements are symbols.")
    135 
    136       (p "The locale symbols must have a lowercase printname! As such "
    137       "they do not truly reflect ISO 639-1/2 & ISO 3166-1 standard "
    138       "names. This is a SRFI-29 restriction.")
    139 
    140     #;(examples ,examples)
    141 
    142190    (section "License" (pre ,license))
    143191  )
    144 ))
     192) )
    145193
    146194(eggdoc->html doc)
  • release/3/srfi-29/trunk/srfi-29.html

    r8942 r9695  
    156156<h3>Author</h3><a href="mailto:klovett@pacbell.net">Kon Lovett</a></div>
    157157<div class="section">
     158<h3>Requires</h3>
     159<ul>
     160<li>lookup-table</li>
     161<li>miscmacros</li>
     162<li>locale</li></ul></div>
     163<div class="section">
     164<h3>Usage</h3><tt>(require-extension srfi-29)</tt></div>
     165<div class="section">
     166<h3>Download</h3><a href="srfi-29.egg">srfi-29.egg</a></div>
     167<div class="section">
     168<h3>Documentation</h3>
     169<p>A Chicken implementation of <a href="http://srfi.schemers.org/srfi-29/srfi-29.html">SRFI 29</a>.</p>
     170<p>Bundles are assumed stored in the system bundle directory, <code>(repository-path) &quot;srfi-29-bundles&quot;</code>.</p>
     171<p>Within a bundle directory the structure is <code>[LANGUAGE [COUNTRY [SCRIPT [CODESET [MODIFIER]]]]] PACKAGE-NAME</code>.</p>
     172<p>The default language is <code>en</code>. The default country is <code>us</code>. The locale package will override these if a locale is set. Otherwise the user must set the corresponding parameters.</p>
     173<p>Any object which can be returned by <code>(read)</code> and tested for equality with <code>equal?</code> is acceptable as a <tt>TEMPLATE-NAME</tt>. So strings are a valid <tt>TEMPLATE-NAME</tt>. Further, <code>(localized-template ...)</code> will return any object which can be returned by <code>(read)</code>, not just a string.</p>
     174<p>Aborts with the composite condition <code>(exn srfi-29)</code> and properties <code>location</code>, <code>message</code>, and <code>arguments</code> for errors.</p>
     175<div class="subsection">
     176<h4>Parameters</h4>
     177<dt class="definition"><strong>parameter:</strong> (current-language [LANGUAGE])</dt>
     178<dd>
     179<p>Gets or sets the <tt>LANGUAGE</tt>.</p></dd>
     180<dt class="definition"><strong>parameter:</strong> (current-country [COUNTRY])</dt>
     181<dd>
     182<p>Gets or sets the <tt>COUNTRY</tt>.</p></dd>
     183<dt class="definition"><strong>parameter:</strong> (current-locale-details [LOCALE-DETAILS])</dt>
     184<dd>
     185<p>Gets or sets the <tt>LOCALE-DETAILS</tt>.</p></dd>
     186<dt class="definition"><strong>parameter:</strong> (current-locale-format-function [FORMAT-PROCEDURE])</dt>
     187<dd>
     188<p>Gets or sets the <tt>FORMAT-PROCEDURE</tt>.</p></dd></div>
     189<div class="subsection">
     190<h4>Procedures</h4>
     191<dt class="definition"><strong>procedure:</strong> (reset-locale-parameters)</dt>
     192<dd>
     193<p>If you change the <code>current-locale</code> (see the <a href="eggs/locale.html">locale</a> egg), you don't have to set all the <code>current-foo</code> parameters. You can simply call this procedure, and it will update those parameters to the values in the new locale. (Reset as in set anew.)</p></dd>
     194<dt class="definition"><strong>procedure:</strong> (most-specific-bundle-specifier PACKAGE-NAME)</dt>
     195<dd>
     196<p>Returns the most specific bundle specifier for the current language, country, and locale details.</p></dd>
     197<dt class="definition"><strong>procedure:</strong> (declare-bundle! BUNDLE-SPECIFIER BUNDLE-ALIST)</dt>
     198<dd>
     199<p>Creates a bundle.</p></dd>
     200<dt class="definition"><strong>procedure:</strong> (undeclare-bundle! BUNDLE-SPECIFIER)</dt>
     201<dd>
     202<p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles.</p></dd>
     203<dt class="definition"><strong>procedure:</strong> (store-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     204<dd>
     205<p>Writes the bundle.</p>
     206<p>Uses the <tt>ALTERNATE-DIRECTORY</tt> if specified.</p></dd>
     207<dt class="definition"><strong>procedure:</strong> (load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     208<dd>
     209<p>Reads the bundle.</p>
     210<p>Uses the <tt>ALTERNATE-DIRECTORY</tt> if specified.</p></dd>
     211<dt class="definition"><strong>procedure:</strong> (load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     212<dd>
     213<p>Attempts <code>(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</code>, from most to least specific.</p></dd>
     214<dt class="definition"><strong>procedure:</strong> (remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     215<dd>
     216<p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles, and from the filesystem. The bundle directory is <tt>ALTERNATE-DIRECTORY</tt>, unless missing. Then the system bundle directory is used.</p>
     217<p>Will not remove the locale directory hierarchy created by <code>(store-bundle! ...)</code>.</p></dd>
     218<dt class="definition"><strong>procedure:</strong> (remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIRECTORY])</dt>
     219<dd>
     220<p>Removes the bundle directory hierarchy created by <code>(store-bundle! ...)</code>. Will only remove empty directories. Returns <code>#t</code> if operation succeeded, <code>#f</code> when a non-empty directory encountered.</p>
     221<p>Does not remove the bundle, if any, from the active bundles. A filesystem only operation.</p>
     222<p>This procedure should be used with caution.</p></dd>
     223<dt class="definition"><strong>procedure:</strong> (localized-template PACKAGE-NAME TEMPLATE-NAME [DEFAULT #f])</dt>
     224<dd>
     225<p>Returns the object for the <tt>TEMPLATE-NAME</tt> in <tt>PACKAGE-NAME</tt>, when found, otherwise the <tt>DEFAULT</tt>.</p></dd>
     226<dt class="definition"><strong>procedure:</strong> (localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])</dt>
     227<dd>
     228<p>Returns <code>(localized-template PACKAGE-NAME TEMPLATE-NAME DEFAULT)</code>.</p>
     229<p>Somewhat like the Posix 'gettext' routine.</p></dd>
     230<dt class="definition"><strong>procedure:</strong> (localized-format PACKAGE-NAME TEMPLATE-NAME PORT ARG0 ...)</dt>
     231<dd>
     232<p>Formats the arguments <tt>ARG0 ...</tt> to the <tt>PORT</tt> using the <code>(current-locale-format-function)</code> and the format string <code>(localized-template PACKAGE-NAME TEMPLATE-NAME)</code>.</p>
     233<p>A representation is always displayed, even when no template is found. Just not a localized one.</p></dd></div></div>
     234<div class="section">
     235<h3>Issues</h3>
     236<p>Possible race condition creating a bundle file or directory.</p>
     237<p>The locale symbols must have a lowercase printname! As such they do not truly reflect ISO 639-1/2 &amp; ISO 3166-1 standard names. This is a SRFI 29 restriction.</p>
     238<p><code>(current-locale-details)</code> is ill-defined by SRFI 29. Which symbol means what? This implementation defines locale details as a 3 element list <code>(SCRIPT CODESET MODIFIER)</code> where the elements are symbols or <code>#f</code>.</p></div>
     239<div class="section">
    158240<h3>Version</h3>
    159241<ul>
     242<li>1.7.0 Cached template lookup. 'localized-template' takes default parameter. Added 'localized-format', 'current-locale-format-function'.</li>
     243<li>1.6.0 Support for missing locale component stated as <code>#f</code>.</li>
    160244<li>1.501 Dropped :optional</li>
    161245<li>1.5 Fixed nasty locale-details handling bug</li>
     
    166250<li>1.0 Initial release</li></ul></div>
    167251<div class="section">
    168 <h3>Requires</h3>
    169 <ul>
    170 <li>lookup-table</li>
    171 <li>miscmacros</li>
    172 <li>locale</li>
    173 <li>chicken &gt; 2.223</li></ul></div>
    174 <div class="section">
    175 <h3>Usage</h3><tt>(require-extension srfi-29)</tt></div>
    176 <div class="section">
    177 <h3>Download</h3><a href="srfi-29.egg">srfi-29.egg</a></div>
    178 <div class="section">
    179 <h3>Documentation</h3>
    180 <p>A Chicken implementation of SRFI-29. This document only describes the extensions. For the SRFI-29 API see <a href="http://srfi.schemers.org/srfi-29/srfi-29.html">SRFI-29</a>.</p>
    181 <p>Bundles are assumed stored in the system bundle directory, <code>(repository-path) srfi-29-bundles</code>. Within a bundle directory the structure is <code>[(language) [(country)]] (module)</code>.</p>
    182 <p>The default language is <code>en</code>. The default country is <code>us</code>. The locale package will override these if a locale is set. Otherwise the user must set the corresponding parameters.</p>
    183 <div class="subsection">
    184 <h4>Extensions to SRFI-29</h4>
    185 <p>The <code>store-bundle</code> and <code>load-bundle!</code> procedures accept an optional directory as the second argument, overriding the system bundle directory.</p>
    186 <p>Any object which can be returned by <code>read</code> and tested for equality with <code>equal?</code> is acceptable as a <i>message-template-name</i>. So strings are a valid <i>message-template-name</i>. Further, <code>localized-template</code> can return any object which can be returned by <code>read</code>, not just strings.</p>
    187 <dt class="definition"><strong>procedure:</strong> (reset-locale-parameters)</dt>
    188 <dd>
    189 <p>If you change current-locale (see the locale egg documentation), you don't have to set the current-language and current-country parameters, you can simply call this procedure, and it will update those parameters to the values in the new locale. (Reset as in set anew.)</p></dd>
    190 <dt class="definition"><strong>procedure:</strong> (most-specific-bundle-specifier PACKAGE-NAME)</dt>
    191 <dd>
    192 <p>Returns the most specific bundle specifier for the current language, country, and locale details.</p></dd>
    193 <dt class="definition"><strong>procedure:</strong> (load-best-available-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])</dt>
    194 <dd>
    195 <p>Attempts <code>(load-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])</code>, from most to least specific.</p></dd>
    196 <dt class="definition"><strong>procedure:</strong> (localized-template/default PACKAGE-NAME TEMPLATE-NAME [DEFAULT TEMPLATE-NAME])</dt>
    197 <dd>
    198 <p>Returns <code>(localized-template PACKAGE-NAME TEMPLATE-NAME)</code>, when found, otherwise the <tt>DEFAULT</tt>. Somewhat like the Posix 'gettext' routine.</p></dd>
    199 <dt class="definition"><strong>procedure:</strong> (undeclare-bundle! BUNDLE-SPECIFIER)</dt>
    200 <dd>
    201 <p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles.</p></dd>
    202 <dt class="definition"><strong>procedure:</strong> (remove-bundle! BUNDLE-SPECIFIER [ALTERNATE-DIR])</dt>
    203 <dd>
    204 <p>Removes the bundle specified by <tt>BUNDLE-SPECIFIER</tt> from the active bundles, and from the filesystem. The bundle directory is <tt>ALTERNATE-DIR</tt>, unless missing. Then the system bundle directory is used.</p>
    205 <p>Will not remove the language [country] directory hierarchy created by <tt>store-bundle!</tt>.</p></dd>
    206 <dt class="definition"><strong>procedure:</strong> (remove-bundle-directory! BUNDLE-SPECIFIER [ALTERNATE-DIR])</dt>
    207 <dd>
    208 <p>Removes the bundle directory hierarchy created by <tt>store-bundle!</tt>. Will only remove empty directories. Returns <code>#t</code> if operation succeeded, <code>#f</code> when a non-empty directory encountered.</p>
    209 <p>Does not remove the bundle, if any, from the active bundles. A filesystem only operation.</p>
    210 <p>This procedure should not be used lightly!</p></dd></div></div>
    211 <div class="section">
    212 <h3>Issues</h3>
    213 <p>Signals the composite condition <code>(exn srfi-29)</code> with properties <code>location</code>, <code>message</code>, and <code>arguments</code>.</p>
    214 <p>Possible race condition creating a bundle file or directory.</p>
    215 <p>Any locale details are ignored, for now, if part of a bundle specifier.</p></div>
    216 <p><code>current-locale-details</code> is ill-defined, which symbol means what? This implementation defines details as an upto 3 element list, ([script] [codeset] [modifier]), where the elements are symbols.</p>
    217 <p>The locale symbols must have a lowercase printname! As such they do not truly reflect ISO 639-1/2 &amp; ISO 3166-1 standard names. This is a SRFI-29 restriction.</p>
    218 <div class="section">
    219252<h3>License</h3>
    220 <pre>&quot;Copyright (c) 2005, Kon Lovett.  All rights reserved.
     253<pre>&quot;Copyright (c) 2005-2008, Kon Lovett.  All rights reserved.
    221254
    222255Permission is hereby granted, free of charge, to any person obtaining a
  • release/3/srfi-29/trunk/srfi-29.meta

    r8942 r9695  
    77 (egg "srfi-29.egg")
    88 (license "BSD")
    9  (needs miscmacros misc-extn lookup-table locale)
     9 (needs miscmacros misc-extn lookup-table locale misc-extn)
    1010 (files
    1111  "tests"
  • release/3/srfi-29/trunk/srfi-29.scm

    r8942 r9695  
    1818;; Within the bundle directory the structure
    1919;; is [(language) [(country) [(details)]]] (module).
    20 
    21 (use srfi-1 srfi-13 posix extras utils srfi-69)
    22 (use miscmacros lookup-table locale)
    2320
    2421(eval-when (compile)
     
    3128    (no-bound-checks)
    3229    (export
    33 
    3430      ;; Extensions
    3531      most-specific-bundle-specifier
     
    4036      remove-bundle-directory!
    4137      load-best-available-bundle!
    42 
    43       ;; SRFI-29
    44       current-language current-country current-locale-details
    45       load-bundle! store-bundle! declare-bundle!
    46       localized-template) ) )
     38      current-locale-format-function
     39      localized-format
     40      ;; SRFI 29
     41      current-language
     42      current-country
     43      current-locale-details
     44      load-bundle!
     45      store-bundle!
     46      declare-bundle!
     47      localized-template ) ) )
     48
     49(use srfi-1 srfi-12 srfi-13 posix extras utils)
     50(use miscmacros lookup-table locale misc-extn-directory)
    4751
    4852;;;
     
    5559
    5660(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
    57 
    58 ;; The bundles dictionary
    59 
    60 (define *localization-bundles* (make-dict 1 equal?))
    6161
    6262;; Um, the user really should set a locale
     
    6767;;;
    6868
     69;;
     70
    6971(define-inline (->symbol obj)
    7072  (string->symbol (->string obj)) )
    7173
    72 (define-inline (->boolean obj)
    73   (not (not obj)) )
     74;;
    7475
    7576(define-inline (make-srfi-29-exception loc msg . args)
     
    7879    (make-property-condition 'srfi-29)) )
    7980
    80 ;; Ensure the directory for the specified path exists.
    81 
    82 (define-inline (create-pathname-directory pathname)
    83   (let loop ([dir (pathname-directory pathname)])
    84     (when dir
    85       (unless (directory? dir)
    86         (loop (pathname-directory dir))
    87         (create-directory dir))) ) )
     81(define-inline (signal-srfi-29-exception loc msg . args)
     82  (abort (apply make-srfi-29-exception loc msg args)) )
     83
     84;;
     85
     86(define-inline (locale-item? x)
     87  (or (not x) (symbol? x)) )
     88
     89(define-inline (locale-details? obj)
     90  (and (list? obj)
     91       (every locale-item? obj)) )
    8892
    8993;; bundle-specifier: (list-of symbol)
    9094;; i.e. package + locale, (package-name [language] [country] [details ...])
    9195
    92 (define-inline (bundle-specification->pathname bundle-specifier)
     96(define (bundle-specification->pathname bundle-specifier)
    9397  (if (null? bundle-specifier)
    94     (signal
    95       (make-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier))
    96     (let ([pn (symbol->string (first bundle-specifier))]
    97           [len (length bundle-specifier)])
    98       (if (eqv? 1 len)
    99         pn
    100         (let ([ln (symbol->string (second bundle-specifier))])
    101           (if (eqv? 2 len)
    102             (make-pathname ln pn)
    103             (make-pathname `(,ln ,(symbol->string (third bundle-specifier))) pn)) ) ))) )
    104 
    105 (define (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
    106   (make-pathname
    107     (optional alternate-dir SYSTEM-BUNDLES)
    108     (bundle-specification->pathname bundle-specifier)) )
    109 
    110 ;;
     98      (signal-srfi-29-exception 'load-bundle! "must specify package name" bundle-specifier)
     99      (make-pathname (reverse! (fold (lambda (x l)
     100                                       (if x
     101                                           (cons (symbol->string x) l)
     102                                           l ) )
     103                                     '()
     104                                     (cdr bundle-specifier)))
     105                     (symbol->string (car bundle-specifier))) ) )
     106
     107(define-inline (bundle-specification->absolute-pathname bundle-specifier alternate-dir)
     108  (make-pathname (optional alternate-dir SYSTEM-BUNDLES)
     109                 (bundle-specification->pathname bundle-specifier)) )
     110
     111;; Package Bundle Cache
     112
     113(define *package-bundle-cache* (make-dict 1 eq?))
     114
     115(define (invalidate-package-bundle-cache . bundle-specifier)
     116  (if (not (null? bundle-specifier))
     117      (dict-delete! *package-bundle-cache* (caar bundle-specifier))
     118      (set! *package-bundle-cache* (make-dict 1 eq?)) ) )
     119
     120;; Bundles Dictionary
     121
     122(define *localization-bundles* (make-dict 1 equal?))
    111123
    112124(define-inline (find-bundle bundle-specifier)
    113125  (dict-ref *localization-bundles* bundle-specifier) )
    114126
    115 (define-inline (add-bundle bundle-specifier bundle-alist)
     127(define-inline (set-bundle! bundle-specifier bundle-alist)
    116128  (dict-set! *localization-bundles* bundle-specifier (alist->dict bundle-alist equal?)) )
    117129
    118 (define-inline (remove-bundle bundle-specifier)
     130(define-inline (reset-bundle! bundle-specifier)
     131  (invalidate-package-bundle-cache bundle-specifier)
    119132  (dict-delete! *localization-bundles* bundle-specifier) )
    120133
     134;;
     135
     136(define-inline (cached-package-bundle package-name thunk)
     137  (or (dict-ref *package-bundle-cache* package-name)
     138      (let loop ([specifier (thunk)])
     139        (and (not (null? specifier))
     140             (if* (find-bundle specifier)
     141                  (begin
     142                    (dict-set! *package-bundle-cache* package-name it)
     143                    it )
     144                  (loop (drop-right! specifier 1)) ) ) ) ) )
     145
    121146;; Canonical current locale
    122147
    123148(define (locale-ref what)
    124   (let* ([locale
    125            (current-locale-components)]
    126          [as-sym
    127            (lambda (v)
    128              (cond
    129                [(symbol? v) v]
    130                [(string? v) (string->symbol (string-downcase v))]
    131                [(not v) v]
    132                [else (->symbol v)]) )]
    133            [opt-locale-component
    134              (lambda (c)
    135                (let ([v (locale-component-ref locale c)])
    136                  (if v
    137                    `(,(as-sym v))
    138                    '()) ) )])
     149  (let ([locale
     150          (current-locale-components)]
     151        [as-sym
     152          (lambda (v)
     153            (cond [(locale-item? v)  v]
     154                  [(string? v)       (string->symbol (string-downcase v))]
     155                  [else              (->symbol v)]) ) ] )
    139156    (switch what
    140       ['language (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
    141       ['country (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
    142       [else `(,@(opt-locale-component 'script) ,@(opt-locale-component 'codeset) ,@(opt-locale-component 'modifier))]) ) )
     157      ['language
     158        (as-sym (locale-component-ref locale 'language LANGUAGE-DEFAULT))]
     159      ['country
     160        (as-sym (locale-component-ref locale 'region COUNTRY-DEFAULT))]
     161      [else
     162        `(,(as-sym (locale-component-ref locale  'script))
     163          ,(as-sym (locale-component-ref locale  'codeset))
     164          ,(as-sym (locale-component-ref locale  'modifier))) ] ) ) )
    143165
    144166;;; Locale Parameters
    145167
    146 (define-parameter current-language (locale-ref 'language)
    147   (lambda (l)
    148     (if (symbol? l) l (current-language)) ) )
    149 
    150 (define-parameter current-country (locale-ref 'country)
    151   (lambda (l)
    152     (if (symbol? l) l (current-country)) ) )
    153 
    154 (define-parameter current-locale-details (locale-ref 'details)
    155   (lambda (lst)
    156     (cond
    157       [(null? lst) lst]
    158       [(and (pair? lst) (every symbol? lst)) lst]
    159       [else (current-locale-details)]) ) )
     168(define-parameter current-locale-format-function
     169  format
     170  (lambda (x)
     171    (if (procedure? x)
     172        x
     173        (begin
     174          (warning 'current-locale-format-function "invalid procedure" x)
     175          (current-locale-format-function) ) ) ) )
     176
     177(define-parameter current-language
     178  (locale-ref 'language)
     179  (lambda (x)
     180    (cond [(locale-item? x)
     181           (invalidate-package-bundle-cache)
     182           x ]
     183          [else
     184           (warning 'current-language "invalid locale item" x)
     185           (current-language) ] ) ) )
     186
     187(define-parameter current-country
     188  (locale-ref 'country)
     189  (lambda (x)
     190    (cond [(locale-item? x)
     191           (invalidate-package-bundle-cache)
     192           x ]
     193          [else
     194           (warning 'current-country "invalid locale item" x)
     195           (current-country) ] ) ) )
     196
     197(define-parameter current-locale-details
     198  (locale-ref 'details)
     199  (lambda (x)
     200    (cond [(locale-details? x)
     201           (invalidate-package-bundle-cache)
     202           x ]
     203          [else
     204            (warning 'current-locale-details "invalid locale item" x)
     205            (current-locale-details) ] ) ) )
    160206
    161207;; If you change (current-locale), you don't have to set current-*
     
    171217;;; Bundle Operations
    172218
     219;;
     220
    173221(define (most-specific-bundle-specifier package-name)
    174222  `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
     
    177225;; its' package name and a template name
    178226
    179 (define-inline (find-any-bundle specifier)
    180   (let loop ([specifier specifier])
    181     (cond
    182       [(null? specifier)        #f]
    183       [(find-bundle specifier)  => identity]
    184       [else
    185         (loop (drop-right specifier 1))]) ) )
    186 
    187 (define (localized-template package-name template-name)
    188   (let loop ([specifier (most-specific-bundle-specifier package-name)])
    189     (and (not (null? specifier))
    190          (and-let* ([bundle (find-any-bundle specifier)])
    191            (cond
    192              [(dict-ref bundle template-name)     => identity]
    193              [(null? (cdr specifier))             #f]
    194              [else
    195                (loop (drop-right specifier 1))]) ) ) ) )
     227(define (localized-template package-name template-name #!optional default)
     228  (let ([bundle (cached-package-bundle package-name
     229                                       (lambda ()
     230                                         (remove!
     231                                          not
     232                                          (most-specific-bundle-specifier package-name))))])
     233    (if bundle
     234        (dict-ref bundle template-name)
     235        default ) ) )
    196236
    197237;;
    198238
    199239(define (localized-template/default package-name template-name #!optional (default template-name))
    200   (or (localized-template package-name template-name) default) )
     240  (localized-template package-name template-name default) )
     241
     242;;
     243
     244(define (localized-format package-name template-name port . fmtargs)
     245  (let ([fmtstr (localized-template package-name template-name)])
     246    (if fmtstr
     247        (apply (current-locale-format-function) port fmtstr fmtargs)
     248        (let ([str (apply conc template-name #\space (intersperse fmtargs #\space))])
     249          (cond [(port? port)                     (display str port)]
     250                [(or (string? port) (not port))   str]
     251                [else                             (display str) ] ) ) ) ) )
    201252
    202253;; Declare a bundle of templates with a given bundle specifier
    203254
    204255(define (declare-bundle! bundle-specifier bundle-alist)
    205   (add-bundle bundle-specifier bundle-alist)
     256  (set-bundle! bundle-specifier bundle-alist)
    206257  #t )
    207258
     
    209260
    210261(define (undeclare-bundle! bundle-specifier)
    211   (remove-bundle bundle-specifier)
     262  (reset-bundle! bundle-specifier)
    212263  #t )
    213264
     
    217268  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    218269    (and (file-exists? path)
    219          (declare-bundle! bundle-specifier (with-input-from-file path read))) ) )
     270         (declare-bundle! bundle-specifier (with-input-from-file path read)) ) ) )
    220271
    221272;; Write bundle to file
     
    223274(define (store-bundle! bundle-specifier . alternate-dir)
    224275  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)]
    225         [can-write?
    226           (lambda (file)
    227             (or (file-write-access? file)
    228                 (signal
    229                   (make-srfi-29-exception 'store-bundle! "no write access" file))) )]
    230         [bundle (find-bundle bundle-specifier)])
     276        [bundle (find-bundle bundle-specifier)] )
    231277    (unless bundle
    232       (signal
    233         (make-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier)))
     278      (signal-srfi-29-exception 'store-bundle! "no such declared bundle" bundle-specifier) )
    234279    (create-pathname-directory path)
    235     (when (and (file-exists? path) (can-write? path))
    236       (delete-file path))
    237     (when (can-write? (pathname-directory path))
    238       (->boolean
    239         (with-output-to-file path
    240           (lambda () (write (dict->alist bundle)))))) ) )
     280    (delete-file* path)
     281    (with-output-to-file path (lambda () (write (dict->alist bundle))))
     282    #t ) )
    241283
    242284;; Remove declared bundle and file, if any
     
    244286(define (remove-bundle! bundle-specifier . alternate-dir)
    245287  (let ([path (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    246     (undeclare-bundle! bundle-specifier)
    247     (when (file-exists? path) (delete-file path) )
     288    (reset-bundle! bundle-specifier)
     289    (delete-file* path)
    248290    #t ) )
    249291
     
    251293
    252294(define (remove-bundle-directory! bundle-specifier . alternate-dir)
    253   (let* ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
     295  (let ([pathname (bundle-specification->absolute-pathname bundle-specifier alternate-dir)])
    254296    (delete-file* pathname)
    255297    (let ([topdir (optional alternate-dir SYSTEM-BUNDLES)])
     
    257299        (let* ([dir (pathname-directory path)]
    258300               [fillst (directory dir)])
    259           (cond
    260             [(equal? dir topdir)          #t]
    261             [(positive? (length fillst))  #f]
    262             [else
    263               (delete-directory dir)
    264               (loop dir)]) ) ) ) ) )
     301          (cond [(string=? dir topdir)        #t]
     302                [(positive? (length fillst))  #f]
     303                [else
     304                  (delete-directory dir)
     305                  (loop dir)]) ) ) ) ) )
    265306
    266307;; Try loading from most to least specific, returns #f when failure.
    267308
    268309(define (load-best-available-bundle! bundle-specifier . alternate-dir)
    269   (let loop ([specifier bundle-specifier])
    270     (if (null? specifier)
    271       #f
    272       (or
    273         (apply load-bundle! specifier alternate-dir)
    274         (loop (drop-right specifier 1)))) ) )
     310  (let loop ([specifier (remove not bundle-specifier)])
     311    (and (not (null? specifier))
     312         (or (apply load-bundle! specifier alternate-dir)
     313             (loop (drop-right! specifier 1)))) ) )
  • release/3/srfi-29/trunk/srfi-29.setup

    r8942 r9695  
    22
    33(required-extension-version
     4  'misc-extn              "3.1"
    45  'locale                 "0.3.1"
    56  'lookup-table           "1.5"
  • release/3/srfi-29/trunk/tests/srfi-29-test.scm

    r8942 r9695  
    3333  )
    3434
    35   (test/case "Bundles Alternate Directory" ([altdir "."])
     35  (test/case "Bundles Alternate Directory"
     36      ([altdir "."])
    3637
    3738    (expect-not-false "B1" (declare-bundle! '(srfi-29-test) bal1))
     
    5455  )
    5556
    56   (test/case "Bundles System Directory" (
    57       [sysdir (make-pathname (repository-path) "srfi-29-bundles")]
    58     )
     57  (test/case "Bundles System Directory"
    5958
    6059    (expect-not-false "B16" (declare-bundle! '(srfi-29-test) bal1))
     
    7776    (expect-not-false "B23.1" (load-bundle! '(srfi-29-test foo)))
    7877    (expect-not-false "B24.1" (load-bundle! '(srfi-29-test foo bar)))
    79 
    80     (expect-not-false "B22.2" (load-best-available-bundle! `(srfi-19 ,(current-language) ,(current-country) ,@(current-locale-details))))
    8178
    8279    (expect-eq "B25" 1 (localized-template 'srfi-29-test 'foo1))
     
    10198
    10299    (expect-true "SysDir RmDir" (remove-bundle-directory! '(srfi-29-test foo bar)))
     100
     101    (expect-success (reset-locale-parameters))
    103102  )
     103
     104  (expect-not-false "B22.2"
     105    (load-best-available-bundle! (most-specific-bundle-specifier 'srfi-19)))
     106    (expect-equal (warn "May fail when not English")
     107     "August" (localized-template 'srfi-19 'august))
     108    (expect-equal (warn "May fail when not English")
     109     "December" (localized-template 'srfi-19 'december))
    104110)
    105111
     112(test::for-each (cut test::styler-set! <> test::output-style-human))
    106113(run-test "SRFI-29 Tests")
     114
     115(test::forget!)
Note: See TracChangeset for help on using the changeset viewer.