Changeset 15722 in project


Ignore:
Timestamp:
09/03/09 05:03:48 (10 years ago)
Author:
Kon Lovett
Message:

Save

Location:
release/4/srfi-29/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-29/trunk/srfi-29.scm

    r15712 r15722  
    1414;;
    1515;; - Possible race condition creating a bundle file or directory
    16 
    17 ;; Default Bundles Directory is '(repository-path) "srfi-29-bundles"'.
    18 
    19 ;; Within the bundle directory the structure
    20 ;; is [(language) [(country) [(details)]] (module).
    2116
    2217(module srfi-29
     
    4136    load-best-available-bundle!
    4237    current-locale-format-function
    43     localized-format )
    44 
    45   (import chicken scheme
    46           (only srfi-1 reverse! every drop-right! remove fold)
     38    localized-format
     39    localized-templates
     40    declared-bundle-specifiers
     41    declared-bundle-templates)
     42
     43  (import scheme chicken
     44          (only srfi-1 map! reverse! every drop-right! remove remove! fold list-copy)
    4745          (only srfi-13 string-downcase)
    48           (only files delete-file* make-pathname pathname-directory directory )
    49           (only posix create-directory delete-directory)
    50           (only lookup-table make-dict dict-ref dict-set! dict-delete! dict->alist alist->dict)
    51           (only miscmacros define-parameter)
     46          (only extras format)
     47          (only data-structures intersperse conc ->string)
     48          (only files delete-file* make-pathname pathname-directory)
     49          (only posix directory? create-directory delete-directory directory)
     50          (only lookup-table make-dict dict-ref dict-set! dict-delete!
     51                             dict->alist alist->dict
     52                             dict-keys
     53                             dict-safe-mode)
     54          (only miscmacros define-parameter if*)
    5255          (only locale current-locale-components locale-component-ref)
    5356          (only conditions make-exn-condition+)
    54           (only type-errors warning-argument-type) )
    55   (require-extension srfi-1 srfi-13 posix files miscmacros lookup-table conditions locale)
     57          (only type-errors warning-argument-type)
     58          (only type-checks check-procedure define-check+error-type) )
     59  (require-library srfi-1 srfi-13 extras data-structures files posix
     60                   lookup-table miscmacros locale
     61                   conditions type-errors type-checks)
    5662
    5763  (declare
     
    6470      invalidate-package-bundle-cache ) )
    6571
    66 ;;;
     72;;; Utilities
    6773
    6874;;
     
    7278;; Ensure the directory for the specified path exists.
    7379
    74 (define (create-pathname-directory pathname) (create-directory (pathname-directory pathname) #t))
    75 
    76 ;;
    77 
    78 (define (display/port obj port)
    79   (cond ((port? port)                     (display obj port))
    80         ((or (string? port) (not port))   (->string obj))
    81         (else                             (display obj) ) ) )
    82 
    83 ;; Constants
     80#; ;NEEDS FIX IN CHICKEN 4.1.8
     81(define (create-pathname-directory pathname)
     82  (create-directory (pathname-directory pathname) #t))
     83
     84(define (create-pathname-directory pathname)
     85  (let loop ((dir (pathname-directory pathname)))
     86    (when (and dir (not (directory? dir)))
     87      (loop (pathname-directory dir))
     88      (create-directory dir)) ) )
     89
     90;;; Constants
    8491
    8592(define-constant DEFAULT-BUNDLE-DIR "srfi-29-bundles")
     
    8996(define SYSTEM-BUNDLES (make-pathname (repository-path) DEFAULT-BUNDLE-DIR))
    9097
    91 ;;
    92 
    93 (define (make-srfi-29-condition) (make-property-condition 'srfi-29))
    94 (define (make-insufficient-condition) (make-property-condition 'insufficient))
    95 (define (make-undefined-condition) (make-property-condition 'undefined))
    96 
    97 (define (error-insufficient loc msg . args)
    98   (abort (make-exn-condition+ loc msg args (make-srfi-29-condition) (make-insufficient-condition))) )
     98;; Within the bundle directory the structure
     99;; is [(language) [(country) [(details)]] (package-name).
     100
     101;;; Errors
    99102
    100103(define (error-undefined loc msg . args)
    101   (abort (make-exn-condition+ loc msg args (make-srfi-29-condition) (make-undefined-condition))) )
    102 
    103 ;;
     104  (abort
     105    (make-exn-condition+ loc msg args
     106                         (make-property-condition 'srfi-29)
     107                         (make-property-condition 'undefined))) )
     108
     109;;; Locale Operations
    104110
    105111(define (locale-item? x) (or (not x) (symbol? x)))
    106112
    107 (define (locale-details? obj) (and (list? obj) (every %locale-item? obj)))
     113(define (locale-details? obj) (and (list? obj) (every locale-item? obj)))
    108114
    109115(define (coerce-locale-item obj)
     
    126132        (coerce-locale-item (locale-component-ref lc what)) ) ) ) )
    127133
     134;;; Bundle Specification Operations
     135
    128136;; bundle-specifier: (list-of symbol)
    129137;; i.e. package + locale: (package-name [language] [country] [details ...])
    130138
     139(define (bundle-specifier? obj) (and (pair? obj) (every symbol? obj)))
     140
     141(define-check+error-type bundle-specifier)
     142
    131143(define (bundle-specification-directory bndl-spec)
    132144  (reverse! (fold cons-locale-item '() (cdr bndl-spec))) )
    133145
    134 (define (bundle-specification-filename bndl-spec)
    135   (symbol->string (car bndl-spec)) )
     146(define (bundle-specification-filename bndl-spec) (symbol->string (car bndl-spec)))
    136147
    137148(define (bundle-specification->pathname bndl-spec)
    138   (make-pathname (bundle-specification-directory bndl-spec) (bundle-specification-filename bndl-spec)) )
     149  (make-pathname (bundle-specification-directory bndl-spec)
     150                 (bundle-specification-filename bndl-spec)) )
    139151
    140152(define (bundle-specification->absolute-pathname bndl-spec alt-dir)
    141153  (make-pathname alt-dir (bundle-specification->pathname bndl-spec)) )
    142154
     155(define (need-bundle-absolute-pathname loc bndl-spec alt-dir)
     156  (check-bundle-specifier loc bndl-spec)
     157  (bundle-specification->absolute-pathname bndl-spec alt-dir) )
     158
    143159;; Bundles Dictionary
    144160
     161;All declared bundles
     162
    145163(define *localization-bundles* (make-dict equal?))
    146164
    147 (define (find-bundle bndl-spec)
    148   (dict-ref *localization-bundles* bndl-spec) )
    149 
    150 (define (set-bundle! bndl-spec bndl-alist)
     165(define (bundle-ref bndl-spec) (dict-ref *localization-bundles* bndl-spec))
     166
     167(define (bundle-set! bndl-spec bndl-alist)
    151168  (dict-set! *localization-bundles* bndl-spec (alist->dict bndl-alist equal?)) )
    152169
    153 (define (reset-bundle! bndl-spec)
     170(define (bundle-reset! bndl-spec)
    154171  (invalidate-package-bundle-cache bndl-spec)
    155172  (dict-delete! *localization-bundles* bndl-spec) )
    156173
     174(define (*bundle-specifiers) (dict-keys *localization-bundles*))
     175
     176(define (need-bundle loc bndl-spec)
     177  (or (bundle-ref bndl-spec)
     178      (error-undefined loc "undeclared bundle specification" bndl-spec)) )
     179
    157180;; Package Bundle Cache
     181
     182;Most specific declared bundles that are actually used
     183;A subset of the *localization-bundles*
    158184
    159185(define *package-bundle-cache* (make-dict eq?))
     
    167193      (let loop ((bndl-spec (remove! not (most-specific-bundle-specifier package-name))))
    168194        (and (not (null? bndl-spec))
    169              (if* (find-bundle bndl-spec)
     195             (if* (bundle-ref bndl-spec)
    170196                  (begin
    171197                    (dict-set! *package-bundle-cache* package-name it)
     
    229255  (current-locale-details (locale-ref 'details)) )
    230256
    231 ;;; Bundle Operations
    232 
    233 ;; Returns the full bundle specifier for the specified package using the default locale
    234 
    235 (define (most-specific-bundle-specifier package-name)
    236   `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
     257;;; Template Operations
    237258
    238259;; Returns the localized template from the most specific bundle given
     
    257278;; relevant details is made to proper destination.
    258279
    259 (define (localized-format package-name template-name port . fmtargs)
     280(define (localized-format package-name template-name . fmtargs)
    260281
    261282  (define (format-info-string package-name template-name fmtargs)
     
    268289                    (and (string? template-name)
    269290                         template-name))))
    270     (if fmtstr (apply (current-locale-format-function) port fmtstr fmtargs)
    271         (display/port (format-info-string package-name template-name fmtargs) port) ) ) )
     291    (if fmtstr (apply (current-locale-format-function) fmtstr fmtargs)
     292        (format-info-string package-name template-name fmtargs) ) ) )
    272293
    273294;; Create or update the value for a template in an existing package.
     
    279300    #t ) )
    280301
     302;;; Bundle Operations
     303
     304;; Returns the full bundle specifier for the specified package using the default locale
     305
     306(define (most-specific-bundle-specifier package-name)
     307  `(,package-name ,(current-language) ,(current-country) ,@(current-locale-details)) )
     308
    281309;; Declare a bundle of templates with a given bundle specifier
    282310
    283311(define (declare-bundle! bndl-spec bndl-alist)
    284   (set-bundle! bndl-spec bndl-alist)
     312  (check-bundle-specifier 'declare-bundle! bndl-spec)
     313  (bundle-set! bndl-spec bndl-alist)
    285314  #t )
    286315
     
    288317
    289318(define (undeclare-bundle! bndl-spec)
    290   (reset-bundle! bndl-spec)
     319  (check-bundle-specifier 'undeclare-bundle! bndl-spec)
     320  (bundle-reset! bndl-spec)
    291321  #t )
    292 
    293 ;; Error checking versions
    294 
    295 (define (need-bundle loc bndl-spec)
    296   (or (find-bundle bndl-spec)
    297       (error-undefined loc "undeclared bundle specification" bndl-spec)) )
    298 
    299 (define (check-bundle-specifier loc obj)
    300   (unless (and (list? obj) (not (null? obj)))
    301     (error-insufficient loc "null bundle specification" obj) ) )
    302 
    303 (define (need-bundle-absolute-pathname loc bndl-spec alt-dir)
    304   (check-bundle-specifier loc bndl-spec)
    305   (bundle-specification->absolute-pathname bndl-spec alt-dir) )
    306322
    307323;; Reads bundle file & declares.
     
    329345  (let-optionals args ((alt-dir SYSTEM-BUNDLES))
    330346    (let ((path (need-bundle-absolute-pathname 'remove-bundle! bndl-spec alt-dir)))
    331       (reset-bundle! bndl-spec)
     347      (bundle-reset! bndl-spec)
    332348      (delete-file* path)
    333349      #t ) ) )
     
    359375               (loop (drop-right! bndl-spec 1)) ) ) ) ) )
    360376
     377;;; Introspection
     378
     379;;
     380
     381(define (localized-templates package-name)
     382  (parameterize ((dict-safe-mode #t))
     383    (dict->alist (cached-package-bundle package-name)) ) )
     384
     385;;
     386
     387(define (declared-bundle-specifiers) (map! list-copy (*bundle-specifiers)))
     388
     389;;
     390
     391(define (declared-bundle-templates bndl-spec)
     392  (check-bundle-specifier 'declared-bundle-templates bndl-spec)
     393  (parameterize ((dict-safe-mode #t))
     394    (dict->alist (need-bundle 'declared-bundle-templates bndl-spec)) ) )
     395
    361396;;;
    362397
  • release/4/srfi-29/trunk/srfi-29.setup

    r15712 r15722  
    55(verify-extension-name "srfi-29")
    66
    7 (require-extension-version
     7#;(required-chicken-version "4.1.8") ;needs posixunix create-directory fix
     8
     9(required-extension-version
     10  'locale         "0.6.1"
     11  'lookup-table   "1.9.1"
    812  'check-errors   "1.3.0")
    913
  • release/4/srfi-29/trunk/tests/run.scm

    r15712 r15722  
    3131    )
    3232
     33    (test-group "Bundles"
     34
     35      (test-assert "" (declare-bundle! '(srfi-29-test) bal1))
     36      (test-assert "" (declare-bundle! '(srfi-29-test foo) bal2))
     37      (test-assert "" (declare-bundle! '(srfi-29-test foo bar) bal3))
     38
     39      (test "declared-bundle-specifiers <problematic>"
     40            '((srfi-29-test foo bar) (srfi-29-test foo) (srfi-29-test))
     41            (declared-bundle-specifiers))
     42      (test "declared-bundle-templates" bal1 (declared-bundle-templates '(srfi-29-test)))
     43      (test "declared-bundle-templates foo" bal2 (declared-bundle-templates '(srfi-29-test foo)))
     44      (test "declared-bundle-templates foo bar" bal3 (declared-bundle-templates '(srfi-29-test foo bar)))
     45
     46      (test "" 1 (localized-template 'srfi-29-test 'foo1))
     47      (test "" 2 (localized-template 'srfi-29-test "bar1"))
     48      (test "" 3 (localized-template 'srfi-29-test 'baz1))
     49
     50      (test-assert "" (undeclare-bundle! '(srfi-29-test)))
     51      (test-assert "" (undeclare-bundle! '(srfi-29-test foo)))
     52      (test-assert "" (undeclare-bundle! '(srfi-29-test foo bar)))
     53
     54      (test-assert "" (not (localized-template 'srfi-29-test 'foo1)))
     55      (test-assert "" (not (localized-template 'srfi-29-test "bar1")))
     56      (test-assert "" (not (localized-template 'srfi-29-test 'baz1)))
     57    )
     58
    3359    (test-group "Bundles Alternate Directory"
    34         ([altdir "."])
     60
     61      (define altdir ".")
    3562
    3663      (test-assert "B1" (declare-bundle! '(srfi-29-test) bal1))
     
    79106      (test "B27" 3 (localized-template 'srfi-29-test 'baz1))
    80107
     108      (test "localized-templates" bal1 (localized-templates 'srfi-29-test))
     109
    81110      (current-language 'foo)
    82111
     
    85114      (test "B30" 6 (localized-template 'srfi-29-test 'baz2))
    86115
     116      (test "localized-templates language foo" bal2 (localized-templates 'srfi-29-test))
     117
    87118      (current-country 'bar)
    88119
     
    90121      (test "B32" 8 (localized-template 'srfi-29-test "bar3"))
    91122      (test "B33" 9 (localized-template 'srfi-29-test 'baz3))
     123
     124      (test "localized-templates language foo, country bar" bal3 (localized-templates 'srfi-29-test))
    92125
    93126      (test-assert "B37.1" (localized-template-set! 'srfi-29-test 'baz3 'foobar))
Note: See TracChangeset for help on using the changeset viewer.