Changeset 6250 in project


Ignore:
Timestamp:
10/02/07 05:08:35 (12 years ago)
Author:
kon
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • fspath/trunk/fspath.scm

    r6249 r6250  
    55;;
    66
    7 (use srfi-1 srfi-9 srfi-13 utils)
     7(use srfi-1 srfi-9 srfi-13 utils regex)
    88(use uri)
    99
     
    9595  (name         fs:filename-name              $fs:filename-name-set!)
    9696  (extension    fs:filename-extension   $fs:filename-extension-set!)
    97   (generation   fs:filename-version         $fs:filename-generation-set!) )
     97  (generation   fs:filename-generation  $fs:filename-generation-set!) )
    9898
    9999;; Pathname Record Object
     
    126126    (fs:filename-name obj)
    127127    (fs:filename-extension obj)
    128     (fs:pathname-generation obj)))
     128    (fs:filename-generation obj)))
    129129
    130130(define-reader-ctor 'fs:filename
    131131  (lambda (name extension generation)
    132     (%fs:make-filename name extension generation))
     132    (%fs:make-filename name extension generation)) )
    133133
    134134;;; Internals
     
    198198  (unless (fs:name? obj)
    199199    (error loc "invalid extension" obj) ) )
     200
     201;;; Filename
     202
     203;; Filename namestring -> list
     204
     205(cond-expand
     206  [(or windows unix)
     207    (define parse-filename
     208      (let ([genrx (regexp "\\.~(\\d+)~$" #f #f #t)]
     209            [extrx (regexp "\\.(.+)$" #f #f #t)])
     210        (lambda (str loc)
     211          (let* ([len (string-length str)]
     212                 [genmat (string-search genrx str)]
     213                 [genstr (and genmat (car genmat))]
     214                 [genlen (if genstr (string-length genstr) 0)]
     215                 [extmat (string-search extrx str 0 (- len genlen))]
     216                 [extstr (and extmat (car extmat))]
     217                 [extlen (if extstr (string-length extstr) 0)]
     218                 [filstr (substring str 0 (- len extlen genlen))])
     219          (%fs:make-filename
     220            (and (not (string-null? filstr))
     221                 filstr)
     222            extstr
     223            (and genstr
     224                 (string->number genstr))) ) ) ) )]
     225  [else] )
     226
     227;;
     228
     229(define (ensure-name obj loc)
     230  (cond [(string? obj)        obj]
     231        [(symbol? obj)        obj]
     232        [else
     233          (error loc "invalid name" obj)]) )
     234
     235;;
     236
     237(define (ensure-extension obj loc)
     238  (cond [(string? obj)        obj]
     239        [(symbol? obj)        (symbol->string obj)]
     240        [else
     241          (error loc "invalid extension" obj)]) )
     242
     243;;
     244
     245(define (ensure-generation obj loc)
     246  (cond [(integer? obj)       obj]
     247        [(newest-symbol? obj) obj]
     248        [(string? obj)        obj]
     249        [(symbol? obj)        obj]
     250        [else
     251          (error loc "invalid generation" obj)]) )
     252
     253;;
     254
     255(define (unparse-name nam)
     256  (if nam (fs:name->string nam) "") )
     257
     258;;
     259
     260(define (unparse-extension ext)
     261  (if ext (string-append "." (fs:name->string ext)) "") )
     262
     263;;
     264
     265(cond-expand
     266  [(or unix windows)
     267    (define (unparse-generation gen)
     268      (if gen
     269          (if (newest-symbol? gen)
     270              ""
     271              (string-append ".~" (number->string gen) "~"))
     272          "") ) ]
     273  [else] )
     274
     275;; Filename list -> namestring
     276
     277(define (unparse-filename fil loc)
     278  (string-append
     279    (unparse-name (fs:filename-name fil))
     280    (unparse-extension (fs:filename-extension fil))
     281    (unparse-generation (fs:filename-generation fil))) )
     282
     283;;
     284
     285(define (ensure-filename fil loc)
     286  (cond [(fs:filename? fil) fil]
     287        [(symbol? fil)      (%fs:make-filename fil #f #f)]
     288        [(string? fil)      (parse-filename fil loc)]
     289        [(null? fil)        #f]
     290        [(pair? fil)        (apply fs:make-filename fil)]
     291        [else
     292          (error loc "invalid filename" fil)]) )
     293
     294;;
     295
     296(define (fs:make-filename . rest)
     297  (let-optionals rest ([name #f] [extension #f] [generation #f])
     298    (%fs:make-filename
     299      (and name (ensure-name name 'fs:make-filename))
     300      (and extension (ensure-extension extension 'fs:make-filename))
     301      (and generation (ensure-generation generation 'fs:make-filename))) ) )
     302
     303;;
     304
     305(define (fs:namestring->filename str)
     306  (parse-filename str 'fs:namestring->filename) )
     307
     308;;
     309
     310(define (fs:filename-namestring flnm)
     311  (cond [(fs:filename? flnm)   (unparse-filename flnm 'fs:filename-namestring)]
     312        [else
     313          (error 'fs:filename-namestring "invalid filename" flnm) ] ) )
     314
     315;;
     316
     317(define (->fs:filename obj)
     318  (cond [(fs:filename? obj) obj]
     319        [(string? obj)      (fs:namestring->filename obj)]
     320        [(symbol? obj)      (%fs:make-filename obj #f #f)]
     321        [else
     322          (error '->fs:filename "invalid filename" obj)]) )
     323
     324;;; Host
    200325
    201326;;
     
    217342              (error loc "invalid host" host)]) ) ]
    218343  [else] )
     344
     345;;
     346
     347(cond-expand
     348  [windows
     349    (define (unparse-host obj loc)
     350      #f ) ]
     351  [unix
     352    (define (unparse-host obj loc)
     353      #f ) ]
     354  [else] )
     355
     356;;; Base
    219357
    220358;;
     
    242380  [else] )
    243381
    244 ;; Filename namestring -> list
    245 
    246 (cond-expand
    247   [(or windows unix)
    248     (define parse-filename
    249       (let ([genrx (regexp "\\.~(\\d+)~$" #f #f #t)]
    250             [extrx (regexp "\\.(.+)$" #f #f #t)])
    251         (lambda (str loc)
    252           (let* ([len (string-length str)]
    253                  [genmat (string-search genrx str)]
    254                  [genstr (and genmat (car genmat))]
    255                  [genlen (if genstr (string-length genstr) 0)]
    256                  [extmat (string-search extrx str 0 (- len genlen))]
    257                  [extstr (and extmat (car extmat))]
    258                  [extlen (if extstr (string-length extstr) 0)]
    259                  [filstr (substring str 0 (- len extlen genlen))])
    260           (%fs:make-filename
    261             (and (not (string-null? filstr))
    262                  filstr)
    263             extstr
    264             (and genstr
    265                  (string->number genstr))) ) ) ) )]
    266   [else] )
    267 
    268 ;;
    269 
    270 (define (ensure-name name loc)
    271   (cond [(string? obj)        obj]
    272         [(symbol? obj)        obj]
    273         [else
    274           (error loc "invalid name" name)]) )
    275 
    276 ;;
    277 
    278 (define (ensure-extension extension loc)
    279   (cond [(string? obj)        obj]
    280         [(symbol? obj)        (symbol->string obj)]
    281         [else
    282           (error loc "invalid extension" extension)]) )
    283 
    284 ;;
    285 
    286 (define (ensure-generation generation loc)
    287   (cond [(integer? obj)       obj]
    288         [(newest-symbol? obj) obj]
    289         [(string? obj)        obj]
    290         [(symbol? obj)        obj]
    291         [else
    292           (error loc "invalid generation" generation)]) )
    293 
    294 ;;
    295 
    296 (define (unparse-name nam)
    297   (if nam (fs:name->string nam) "") )
    298 
    299 ;;
    300 
    301 (define (unparse-extension ext)
    302   (if ext (string-append "." (fs:name->string ext)) "") )
    303 
    304 ;;
    305 
    306 (cond-expand
    307   [(or unix windows)
    308     (define (unparse-generation gen)
    309       (if gen
    310           (if (newest-symbol? gen)
    311               ""
    312               (string-append ".~" (integer->string gen) "~"))
    313           "") ) ]
    314   [else] )
    315 
    316 ;; Filename list -> namestring
    317 
    318 (define (unparse-filename fil loc)
    319   (string-append
    320     (unparse-name (fs:filename-name fil))
    321     (unparse-extension (fs:filename-extension fil))
    322     (unparse-generation (fs:filename-generation fil))) )
    323 
    324 ;;
    325 
    326 (define (fs:make-filename . rest)
    327   (let-optionals rest ([name #f] [extension #f] [generation #f])
    328     (%fs:make-filename
    329       (and name (ensure-name name 'fs:make-filename))
    330       (and extension (ensure-extension extension 'fs:make-filename))
    331       (and generation (ensure-generation generation 'fs:make-filename))) ) )
    332 
    333 ;;
    334 
    335 (define (ensure-filename fil loc)
    336   (cond [(fs:filename? fil) fil]
    337         [(symbol? fil)      (%fs:make-filename fil #f #f)]
    338         [(string? fil)      (parse-filename fil loc)]
    339         [(null? fil)        #f]
    340         [(pair? fil)        (apply fs:make-filename fil)]
    341         [else
    342           (error loc "invalid filename" fil)]) )
    343 
    344 ;;
    345 
    346 (define (fs:namestring->filename str)
    347   (parse-filename str 'fs:namestring->filename) )
    348 
    349 ;;
    350 
    351 (define (fs:filename-namestring flnm)
    352   (cond [(fs:filename? flnm)   (unparse-filename flnm 'fs:filename-namestring)]
    353         [else
    354           (error 'fs:filename-namestring "invalid filename" flnm) ] ) )
    355 
    356 ;;
    357 
    358 (define (->fs:filename obj)
    359   (cond [(fs:filename? obj) obj]
    360         [(string? obj)      (fs:namestring->filename obj)]
    361         [(symbol? obj)      (%fs:make-filename obj #f #f)]
    362         [else
    363           (error '->fs:filename "invalid filename" obj)]) )
     382;;
     383
     384(cond-expand
     385  [windows
     386    (define (unparse-base obj loc)
     387      #f ) ]
     388  [unix
     389    (define (unparse-base obj loc)
     390      #f ) ]
     391  [else] )
     392
     393;;; Directory
    364394
    365395;; Directory namestring -> list
     
    383413(cond-expand
    384414  [(or unix windows)
    385     (define (unparse-directory obj sepstr loc)
     415    (define (unparse-directory obj loc)
    386416      (if (not obj)
    387417          ""
     
    413443    (unparse-base (fs:pathname-base pn) loc)
    414444    (unparse-directory (fs:pathname-directory pn) loc)
    415     (unparse-filename (fs:pathname-filename pn) loc)) )
    416 
    417 ;;
    418 
    419 (define (fs:pathname-namestring pn)
    420   (cond [(fs:pathname? pn)  (unparse-pathname pn 'fs:pathname-namestring)]
    421         [else
    422           (error 'fs:pathname-namestring "invalid pathname" pn) ] ) )
    423 
    424 ;;
    425 
    426 (define (->fs:namestring obj)
    427   (cond [(string? obj)        obj]
    428         [(fs:filename? obj)   (fs:filename-namestring obj)]
    429         [else                 (fs:pathname-namestring obj)] ) )
     445    (unparse-filename (fs:pathname-file pn) loc)) )
    430446
    431447;;
     
    442458        (and base (ensure-base base 'fs:make-pathname))
    443459        (and directory (ensure-directory directory 'fs:make-pathname))
    444         (and file (ensure-filename file 'fs:make-pathname))) ) )
     460        (and file (ensure-filename file 'fs:make-pathname))) ) ) )
     461
     462;;
     463
     464(cond-expand
     465  [windows
     466    (define (parse-pathname obj loc)
     467      #f ) ]
     468  [unix
     469    (define (parse-pathname obj loc)
     470      #f ) ]
     471  [else] )
    445472
    446473;;
     
    448475(define (->fs:pathname obj)
    449476  (cond [(fs:pathname? obj) obj]
    450         [(string? obj)      (parse-pathname obj)]
    451         [(symbol? obj)      ]
    452         [else
    453           (error '->fs:filename "invalid filename" obj)]) )
    454 
    455 ;;
    456 
    457 
     477        [(fs:filename? obj) (%fs:make-pathname #f #f #f obj)]
     478        [(string? obj)      (parse-pathname obj '->fs:pathname)]
     479        [else
     480          (error '->fs:pathname "invalid pathname" obj)]) )
     481
     482;;
     483
     484(define (fs:pathname-namestring pn)
     485  (cond [(fs:pathname? pn)  (unparse-pathname pn 'fs:pathname-namestring)]
     486        [else
     487          (error 'fs:pathname-namestring "invalid pathname" pn) ] ) )
     488
     489;;
     490
     491(define (->fs:namestring obj)
     492  (cond [(string? obj)        obj]
     493        [(fs:filename? obj)   (fs:filename-namestring obj)]
     494        [else                 (fs:pathname-namestring obj)] ) )
     495
     496;;;
     497
     498#|
    458499;; Platform specific
    459500
     
    464505
    465506    (define (unparse-path file #!optional (verpat ".~[^~]*~"))
     507      )
    466508
    467509    ;; Path namestring -> list
     
    669711    (define ($fs:pathname->namestring fspath)
    670712      (error 'fs:pathname->namestring "unsupported" fspath) ) ] )
     713|#
Note: See TracChangeset for help on using the changeset viewer.