Changeset 6175 in project for chicken/trunk/posixunix.scm


Ignore:
Timestamp:
09/27/07 20:12:03 (13 years ago)
Author:
Kon Lovett
Message:

Changes for PCRE 7.4, use of compiled regexp in posix & utils units.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/posixunix.scm

    r5358 r6175  
    388388    (no-procedure-checks-for-usual-bindings)
    389389    (bound-to-procedure
     390     string-match glob->regexp regexp make-anchored-pattern
    390391     ##sys#thread-yield! ##sys#make-string
    391392     ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
    392393     ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer make-pathname glob directory?
    393      pathname-file string-match process-fork file-close duplicate-fileno process-execute getenv
     394     pathname-file process-fork file-close duplicate-fileno process-execute getenv
    394395     make-string make-input-port make-output-port ##sys#thread-block-for-i/o create-pipe
    395      process-wait pathname-strip-directory ##sys#expand-home-path glob->regexp directory
     396     process-wait pathname-strip-directory ##sys#expand-home-path directory
    396397     decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
    397398     ##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
     
    535536      (let ([res (fcntl fd cmd arg)])
    536537        (if (fx= res -1)
    537           (posix-error #:file-error 'file-control "cannot control file" fd cmd)
    538           res ) ) ) ) )
     538            (posix-error #:file-error 'file-control "cannot control file" fd cmd)
     539            res ) ) ) ) )
    539540
    540541(define file-open
     
    766767
    767768(define directory
    768   (let ([string-append string-append]
     769  (let ([string-ref string-ref]
    769770        [make-string make-string]
    770771        [string string] )
     
    10921093  (define (group-information group)
    10931094    (let ([r (if (fixnum? group)
    1094                (##core#inline "C_getgrgid" group)
    1095                (begin
    1096                  (##sys#check-string group 'group-information)
    1097                  (##core#inline "C_getgrnam" (##sys#make-c-string group)) ) ) ] )
     1095                 (##core#inline "C_getgrgid" group)
     1096                 (begin
     1097                   (##sys#check-string group 'group-information)
     1098                   (##core#inline "C_getgrnam" (##sys#make-c-string group)) ) ) ] )
    10981099      (and r
    10991100         (list _group-name
     
    11291130      (let loop ([i 0])
    11301131        (if (fx>= i n)
    1131           '()
    1132           (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1))) ) ) ) )
     1132            '()
     1133            (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1))) ) ) ) )
    11331134
    11341135  (define (set-groups! lst0)
     
    14381439              (lambda ()
    14391440                (if (fx>= bufpos buflen)
    1440                   #!eof
    1441                   (##core#inline "C_subchar" buf bufpos)) )]
     1441                    #!eof
     1442                    (##core#inline "C_subchar" buf bufpos)) )]
    14421443            [fetch
    14431444              (lambda ()
     
    14451446                  (let loop ()
    14461447                    (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
    1447                       (cond
    1448                         [(fx= cnt -1)
    1449                           (if (fx= _errno _ewouldblock)
    1450                             (begin
    1451                               (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
    1452                               (##sys#thread-yield!)
    1453                               (loop) )
    1454                             (posix-error #:file-error loc "cannot read" fd nam) )]
    1455                         [(and more? (fx= cnt 0))
    1456                           ; When "more" keep trying, otherwise read once more
    1457                           ; to guard against race conditions
    1458                           (if (more?)
    1459                             (begin
    1460                               (##sys#thread-yield!)
    1461                               (loop) )
    1462                             (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
    1463                               (when (fx= cnt -1)
    1464                                 (if (fx= _errno _ewouldblock)
    1465                                   (set! cnt 0)
    1466                                   (posix-error #:file-error loc "cannot read" fd nam) ) )
     1448                      (cond [(fx= cnt -1)
     1449                              (if (fx= _errno _ewouldblock)
     1450                                  (begin
     1451                                    (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
     1452                                    (##sys#thread-yield!)
     1453                                    (loop) )
     1454                                  (posix-error #:file-error loc "cannot read" fd nam) )]
     1455                            [(and more? (fx= cnt 0))
     1456                              ; When "more" keep trying, otherwise read once more
     1457                              ; to guard against race conditions
     1458                              (if (more?)
     1459                                  (begin
     1460                                    (##sys#thread-yield!)
     1461                                    (loop) )
     1462                                  (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
     1463                                    (when (fx= cnt -1)
     1464                                      (if (fx= _errno _ewouldblock)
     1465                                          (set! cnt 0)
     1466                                          (posix-error #:file-error loc "cannot read" fd nam) ) )
     1467                                    (set! buflen cnt)
     1468                                    (set! bufpos 0) ) )]
     1469                            [else
    14671470                              (set! buflen cnt)
    1468                               (set! bufpos 0) ) )]
    1469                         [else
    1470                           (set! buflen cnt)
    1471                           (set! bufpos 0)]) ) ) ) )] )
     1471                              (set! bufpos 0)]) ) ) ) )] )
    14721472          (letrec (
    14731473              [this-port
     
    14941494                  (lambda (port n dest start)   ; Read-String!
    14951495                    (let loop ([n n] [m 0] [start start])
    1496                       (cond
    1497                         [(eq? n 0) m]
    1498                         [(fx< bufpos buflen)
    1499                           (let* ([rest (fx- buflen bufpos)]
    1500                                  [n2 (if (fx< n rest) n rest)])
    1501                             (##core#inline "C_substring_copy"
    1502                               buf dest bufpos (fx+ bufpos n2) start)
    1503                             (set! bufpos (fx+ bufpos n2))
    1504                             (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
    1505                         [else
    1506                           (fetch)
    1507                           (if (eq? buflen 0)
    1508                             m
    1509                             (loop n m start) ) ] ) ) )
     1496                      (cond [(eq? n 0) m]
     1497                            [(fx< bufpos buflen)
     1498                              (let* ([rest (fx- buflen bufpos)]
     1499                                     [n2 (if (fx< n rest) n rest)])
     1500                                (##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)
     1501                                (set! bufpos (fx+ bufpos n2))
     1502                                (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
     1503                            [else
     1504                              (fetch)
     1505                              (if (eq? buflen 0)
     1506                                  m
     1507                                  (loop n m start) ) ] ) ) )
    15101508                  (lambda (port limit)          ; Read-Line
    15111509                    (let loop ([str #f])
    1512                       (cond
    1513                         [(fx< bufpos buflen)
    1514                           (##sys#scan-buffer-line
    1515                             buf buflen bufpos
    1516                             (lambda (cur ptr)
    1517                               (let ([dest (##sys#make-string (fx- cur bufpos))])
    1518                                 (##core#inline "C_substring_copy" buf dest bufpos cur 0)
    1519                                 (set! bufpos ptr)
    1520                                 (cond
    1521                                   [(eq? cur ptr) ; no line-terminator encountered
    1522                                     (fetch)
    1523                                     (if (fx>= bufpos buflen)
    1524                                       (or str "")
    1525                                       (loop (if str (##sys#string-append str dest) dest)) ) ]
    1526                                   [else
    1527                                     (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
    1528                                     (if str (##sys#string-append str dest) dest) ] ) ) ) ) ]
    1529                         [else
    1530                           (fetch)
    1531                           (if (fx< bufpos buflen)
    1532                             (loop str)
    1533                             #!eof) ] ) ) ) )] )
     1510                      (cond [(fx< bufpos buflen)
     1511                              (##sys#scan-buffer-line
     1512                                buf buflen bufpos
     1513                                (lambda (cur ptr)
     1514                                  (let ([dest (##sys#make-string (fx- cur bufpos))])
     1515                                    (##core#inline "C_substring_copy" buf dest bufpos cur 0)
     1516                                    (set! bufpos ptr)
     1517                                    (cond [(eq? cur ptr) ; no line-terminator encountered
     1518                                            (fetch)
     1519                                            (if (fx>= bufpos buflen)
     1520                                                (or str "")
     1521                                                (loop (if str (##sys#string-append str dest) dest)) ) ]
     1522                                          [else
     1523                                            (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
     1524                                            (if str (##sys#string-append str dest) dest) ] ) ) ) ) ]
     1525                            [else
     1526                              (fetch)
     1527                              (if (fx< bufpos buflen)
     1528                                 (loop str)
     1529                                 #!eof) ] ) ) ) )] )
    15341530            (set-port-name! this-port nam)
    15351531            this-port ) ) ) ) ) )
     
    15461542            (lambda (str len)
    15471543              (let ([cnt (##core#inline "C_write" fd str len)])
    1548                 (cond
    1549                   [(fx= -1 cnt)
    1550                     (if (fx= _errno _ewouldblock)
    1551                       (begin
    1552                         (##sys#thread-yield!)
    1553                         (poke str len) )
    1554                       (posix-error loc #:file-error "cannot write" fd nam) ) ]
    1555                   [(fx< cnt len)
    1556                     (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
     1544                (cond [(fx= -1 cnt)
     1545                        (if (fx= _errno _ewouldblock)
     1546                            (begin
     1547                              (##sys#thread-yield!)
     1548                              (poke str len) )
     1549                            (posix-error loc #:file-error "cannot write" fd nam) ) ]
     1550                      [(fx< cnt len)
     1551                        (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
    15571552          [store
    15581553            (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])
    15591554              (if (fx= 0 bufsiz)
    1560                 (lambda (str)
    1561                   (when str
    1562                     (poke str (##sys#size str)) ) )
    1563                 (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
    1564                       [bufpos 0])
    15651555                  (lambda (str)
    1566                     (if str
    1567                       (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])
    1568                         (cond
    1569                           [(fx= 0 rem)
    1570                             (poke buf bufsiz)
    1571                             (set! bufpos 0)
    1572                             (loop bufsiz 0 len)]
    1573                           [(fx< rem len)
    1574                             (##core#inline "C_substring_copy" str buf start rem bufpos)
    1575                             (loop 0 rem (fx- len rem))]
    1576                           [else
    1577                             (##core#inline "C_substring_copy" str buf start len bufpos)
    1578                             (set! bufpos (fx+ bufpos len))] ) )
    1579                       (when (fx< 0 bufpos)
    1580                         (poke buf bufpos) ) ) ) ) ) )])
     1556                    (when str
     1557                      (poke str (##sys#size str)) ) )
     1558                  (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
     1559                        [bufpos 0])
     1560                    (lambda (str)
     1561                      (if str
     1562                          (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])
     1563                            (cond [(fx= 0 rem)
     1564                                    (poke buf bufsiz)
     1565                                    (set! bufpos 0)
     1566                                    (loop bufsiz 0 len)]
     1567                                  [(fx< rem len)
     1568                                    (##core#inline "C_substring_copy" str buf start rem bufpos)
     1569                                    (loop 0 rem (fx- len rem))]
     1570                                  [else
     1571                                    (##core#inline "C_substring_copy" str buf start len bufpos)
     1572                                    (set! bufpos (fx+ bufpos len))] ) )
     1573                          (when (fx< 0 bufpos)
     1574                            (poke buf bufpos) ) ) ) ) ) )])
    15811575        (letrec (
    15821576            [this-port
     
    16751669      (let ([v (##sys#file-info (##sys#expand-home-path filename))])
    16761670        (if v
    1677           (fx= 3 (##sys#slot v 4))
    1678           (posix-error #:file-error 'fifo? "file does not exist" filename) ) ) ) )
     1671            (fx= 3 (##sys#slot v 4))
     1672            (posix-error #:file-error 'fifo? "file does not exist" filename) ) ) ) )
    16791673
    16801674;;; Environment access:
     
    18551849        (##sys#check-port port 'terminal-name)
    18561850        (unless (and (eq? 'stream (##sys#slot port 7))
    1857                    (##core#inline "C_tty_portp" port) )
     1851                     (##core#inline "C_tty_portp" port) )
    18581852        (##sys#error 'terminal-name "port is not connected to a terminal" port) )
    18591853        (ttyname (##core#inline "C_C_fileno" port) ) ) ) )
     
    18621856    (let ([getit
    18631857         (foreign-lambda* c-string ()
    1864            "if(gethostname(C_hostbuf, 256) == -1) return(NULL);
    1865               else return(C_hostbuf);") ] )
     1858           "if(gethostname(C_hostbuf, 256) == -1) return(NULL);"
     1859           "else return(C_hostbuf);") ] )
    18661860      (lambda ()
    18671861        (let ([host (getit)])
    1868         (unless host
    1869           (posix-error #:error 'get-host-name "cannot retrieve host-name") )
    1870         host) ) ) ) ] )
     1862          (unless host
     1863            (posix-error #:error 'get-host-name "cannot retrieve host-name") )
     1864          host) ) ) ) ] )
    18711865
    18721866
     
    18741868
    18751869(define glob
    1876   (let ([glob->regexp glob->regexp]
     1870  (let ([regexp regexp]
     1871        [make-anchored-pattern make-anchored-pattern]
     1872        [string-match string-match]
     1873        [glob->regexp glob->regexp]
    18771874        [directory directory]
    18781875        [make-pathname make-pathname]
    18791876        [decompose-pathname decompose-pathname] )
    18801877    (lambda paths
    1881       (let conc ([paths paths])
     1878      (let conc-loop ([paths paths])
    18821879        (if (null? paths)
    18831880            '()
    18841881            (let ([path (car paths)])
    1885               (let-values ([(dir file ext) (decompose-pathname path)])
    1886                 (let ([rx (glob->regexp (make-pathname #f (or file "*") ext))])
    1887                   (let loop ([f (directory (or dir ".") #t)])
    1888                     (cond [(null? f) (conc (cdr paths))]
    1889                           [(string-match rx (car f))
    1890                            => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr f)))) ]
    1891                           [else (loop (cdr f))] ) ) ) ) ) ) ) ) ) )
     1882              (let-values ([(dir fil ext) (decompose-pathname path)])
     1883                (let* ([fnpatt (glob->regexp (make-pathname #f (or fil "*") ext))]
     1884                       [patt (make-anchored-pattern fnpatt)]
     1885                       [rx (regexp patt)])
     1886                  (let loop ([fns (directory (or dir ".") #t)])
     1887                    (cond [(null? fns) (conc-loop (cdr paths))]
     1888                          [(string-match rx (car fns))
     1889                           => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
     1890                          [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
    18921891
    18931892
     
    19311930             (let* ([prg (##sys#make-c-string (##sys#expand-home-path filename))]
    19321931                    [r (if envlist
    1933                          (##core#inline "C_execve" prg)
    1934                          (##core#inline "C_execvp" prg) )] )
     1932                           (##core#inline "C_execve" prg)
     1933                           (##core#inline "C_execvp" prg) )] )
    19351934               (when (fx= r -1)
    19361935                 (freeargs)
     
    19911990        (let ([args (if (pair? args) (car args) #f)]
    19921991              [pid (process-fork)] )
    1993         (cond [(not (eq? pid 0)) pid]
    1994               [args (process-execute f args)]
    1995               [else
    1996                (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) )
     1992          (cond [(not (eq? pid 0)) pid]
     1993                [args (process-execute f args)]
     1994                [else
     1995                 (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) )
    19971996
    19981997  ;;; Run subprocess connected with pipes:
     
    20982097  ;;; Run subprocess connected with pipes:
    20992098
    2100   #;(define process (void))
    2101   #;(define process* (void))
     2099  (define process)
     2100  (define process*)
    21022101  (let ([%process
    21032102          (lambda (loc err? cmd args env)
     
    21082107              (##sys#check-string cmd loc)
    21092108              (if args
    2110                 (chkstrlst args)
    2111                 (begin
    2112                   (set! args (##sys#shell-command-arguments cmd))
    2113                   (set! cmd (##sys#shell-command)) ) )
     2109                  (chkstrlst args)
     2110                  (begin
     2111                    (set! args (##sys#shell-command-arguments cmd))
     2112                    (set! cmd (##sys#shell-command)) ) )
    21142113              (when env (chkstrlst env))
    21152114              (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
    21162115                (if err?
    2117                   (values in out pid err)
    2118                   (values in out pid) ) ) ) )] )
     2116                    (values in out pid err)
     2117                    (values in out pid) ) ) ) )] )
    21192118    (set! process
    21202119      (lambda (cmd #!optional args env)
     
    21432142                      [else limit] ) ]
    21442143               [pproc
    2145                 (if (string? pred)
     2144                (if (or (string? pred) (regexp? pred))
    21462145                    (lambda (x) (string-match pred x))
    21472146                    pred) ] )
Note: See TracChangeset for help on using the changeset viewer.