Timer cancel follow-ups, SIGPIPE in children, java.time and File(URI) fixes

CHANGELOG.md

@@ -55,6 +55,29 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ### Fixed
 
+- **`new File(uri)`, `Paths.get(uri)` and `Path.of(uri)` read the URI's path.**
+  They took the URI's string as the path, so `file:///tmp/a%20b` became the
+  relative path `file:/tmp/a%20b` and nothing under it existed. They now decode
+  the path of a `file:` URI and refuse the rest with the JDK's messages — an
+  authority (even `localhost`), a query, a fragment, an opaque or relative URI;
+  `Paths.get` of another scheme is a `FileSystemNotFoundException`.
+  `clojure.java.io/file` of a URI reads it the lenient way, through its URL, as
+  Clojure does (#1198).
+
+- **`java.time`'s `Month` overloads.** `LocalDate/of`, `LocalDateTime/of`,
+  `YearMonth/of`, `MonthDay/of` and `Year.atMonth` take a `java.time.Month`
+  where the month number goes, as the JDK's do; a `Month` was a
+  `ClassCastException`. `LocalDateTime/ofInstant` and an `ofEpochSecond` that
+  applies its offset come from jolt-lang/time, which owns zones (#1197).
+
+- **Spawned processes start with `SIGPIPE` at its default, as on the JVM.**
+  The runtime ignores `SIGPIPE` for its own writes, and an ignored signal
+  survives `exec`, so every child and everything it ran inherited it. A
+  producer whose consumer exited early (`yes | head`, `cmd | grep -q`) got
+  `EPIPE` and ran its error path — "Broken pipe" on stderr, a different exit
+  status — instead of being ended by the signal. A shell cannot undo that
+  itself, so the spawn now resets it (#1196).
+
 - **A timed wait on a fiber no longer pins the fiber until its deadline.** The
   runtime's timer had no cancel, so a fiber's timed socket read, accept or
   connect, or a timed `deref`, left its deadline armed after the wait ended,

host/chez/java/class-hierarchy.ss

@@ -682,6 +682,7 @@
 (jch-register-supers! "java.nio.file.NotDirectoryException" '("java.nio.file.FileSystemException"))
 (jch-register-supers! "java.nio.file.NotLinkException" '("java.nio.file.FileSystemException"))
 (jch-register-supers! "java.nio.file.DirectoryNotEmptyException" '("java.nio.file.FileSystemException"))
+(jch-register-supers! "java.nio.file.FileSystemNotFoundException" '("java.lang.RuntimeException"))
 (jch-register-supers! "java.net.UnknownHostException" '("java.io.IOException"))
 (jch-register-supers! "java.net.SocketException" '("java.io.IOException"))
 (jch-register-supers! "java.net.ConnectException" '("java.net.SocketException"))

host/chez/java/io.ss

@@ -546,7 +546,12 @@
     (if (null? cs)
         ;; (io/file url) strips the scheme — File of url.toURI on the JVM; only a
         ;; file: url names a path. url-file-coercion is defined below; call-time ref.
-        (if (and (null? rest) (jhost? path) (string=? (jhost-tag path) "url")) (url-file-coercion path) (make-jfile p))
+        (cond ((null? rest)
+               (cond ((url-jhost? path) (url-file-coercion path))
+                     ;; as-file of a URI is as-file of its URL (clojure.java.io)
+                     ((uri-jhost? path) (url-spec-file-coercion (uri-field path 'string)))
+                     (else (make-jfile p))))
+              (else (make-jfile p)))
         (loop (string-append p "/" (file-path-of (car cs))) (cdr cs)))))
 ;; the on-disk path of a value: a relative path resolves against JOLT_PWD.
 (define (jfile-fs f) (project-relative (file-path-of f)))
@@ -652,15 +657,49 @@
                          (string-append "//" host path)))
                    rest))
          (p (uri-decode-lenient rest)))
-    (if (and windows?
-             (>= (string-length p) 3)
-             (char=? (string-ref p 0) #\/)
-             (windows-drive-prefix? (substring p 1 (string-length p)))
-             (or (= (string-length p) 3) (path-separator-char? (string-ref p 3))))
-        (substring p 1 (string-length p))
-        p)))
+    (uri-path->drive-path windows? p)))
 (define (file-url->path spec) (file-url->path-for (win32?) spec))
 
+;; A URI path names a drive as "/C:/..."; on Windows the path is "C:/...".
+(define (uri-path->drive-path windows? p)
+  (if (and windows?
+           (>= (string-length p) 3)
+           (char=? (string-ref p 0) #\/)
+           (windows-drive-prefix? (substring p 1 (string-length p)))
+           (or (= (string-length p) 3) (path-separator-char? (string-ref p 3))))
+      (substring p 1 (string-length p))
+      p))
+
+;; new File(URI), and the default filesystem's getPath(URI) under Paths.get and
+;; Path.of (jolt-lang/jolt#1198). Unlike a file: URL, which clojure.java.io reads
+;; leniently above, the JDK takes only an absolute, hierarchical file: URI with
+;; no authority, query or fragment, and says which rule failed, in this order.
+;; A localhost authority is refused here, not dropped. Both callers used to hand
+;; the URI's string on as the path, so "file:///tmp/a%20b" became the relative
+;; path "file:/tmp/a%20b".
+(define (uri->file-path-for windows? u)
+  (define (bad msg) (throw-jvm 'IllegalArgumentException msg))
+  (let ((scheme (uri-field u 'scheme)))
+    (when (jolt-nil? scheme) (bad "URI is not absolute"))
+    (when (uri-opaque? u) (bad "URI is not hierarchical"))
+    (unless (string-ci=? scheme "file") (bad "URI scheme is not \"file\""))
+    (unless (jolt-nil? (uri-field u 'authority)) (bad "URI has an authority component"))
+    (unless (jolt-nil? (uri-field u 'fragment)) (bad "URI has a fragment component"))
+    (unless (jolt-nil? (uri-field u 'query)) (bad "URI has a query component"))
+    (let ((p (uri-field u 'dec-path)))
+      (when (or (jolt-nil? p) (string=? p "")) (bad "URI path component is empty"))
+      (uri-path->drive-path windows? p))))
+(define (uri->file-path u) (uri->file-path-for (win32?) u))
+;; Path.of(URI): the scheme picks the filesystem provider first, and only the
+;; default one ("file") is installed.
+(define (nio-uri->path u)
+  (let ((scheme (uri-field u 'scheme)))
+    (cond ((jolt-nil? scheme) (throw-jvm 'IllegalArgumentException "Missing scheme"))
+          ((string-ci=? scheme "file") (uri->file-path u))
+          (else (jolt-throw (jolt-host-throwable
+                              "java.nio.file.FileSystemNotFoundException"
+                              (string-append "Provider \"" scheme "\" not installed")))))))
+
 ;; The path a STRING names as a clojure.java.io source or sink. Its Coercions
 ;; try (URL. s) before (File. s), so "file:/a/b" is the file /a/b rather than a
 ;; relative path whose first segment is "file:"; any other string is a path.
@@ -2577,17 +2616,19 @@
 ;; io/as-file of a file: URL yields the file it points at (JVM: new
 ;; File(url.toURI())); a URL with any other protocol has no filesystem path —
 ;; IllegalArgumentException, as the JVM's File(URI) throws.
-(define (url-file-coercion u)
-  (if (string=? (url-protocol (url-spec u)) "file")
-      (make-jfile (file-url->path (url-spec u)))
-      (throw-jvm 'IllegalArgumentException (string-append "Not a file: " (url-spec u)))))
+(define (url-file-coercion u) (url-spec-file-coercion (url-spec u)))
+(define (url-spec-file-coercion spec)
+  (if (string=? (url-protocol spec) "file")
+      (make-jfile (file-url->path spec))
+      (throw-jvm 'IllegalArgumentException (string-append "Not a file: " spec))))
 (def-var! "clojure.java.io" "as-file"
   ;; Clojure extends Coercions to nil, so (io/as-file nil) is nil -- NOT a File
   ;; whose path is "". The difference is load-bearing one call downstream, where
   ;; the JVM raises on the nil and jolt was quietly reading the process's cwd.
   (lambda (x) (cond ((jolt-nil? x) x)
                     ((jfile? x) x)
-                    ((and (jhost? x) (string=? (jhost-tag x) "url")) (url-file-coercion x))
+                    ((url-jhost? x) (url-file-coercion x))
+                    ((uri-jhost? x) (url-spec-file-coercion (uri-field x 'string)))
                     (else (make-jfile (file-path-of x))))))
 ;; "reader" is bound by natives-array.ss (loaded later) so a char[] argument is
 ;; handled; that binding delegates here via jolt-io-reader for everything else.
@@ -3048,6 +3089,7 @@
 (define (jolt-file-ctor a . rest)
   (cond ((pair? rest) (jolt-make-file (jolt-file-join a (car rest))))
         ((jolt-nil? a) (throw-jvm (quote NullPointerException) jolt-nil))
+        ((uri-jhost? a) (make-jfile (uri->file-path a)))
         (else (jolt-make-file a))))
 (register-class-ctor! "File" jolt-file-ctor)
 ;; File statics: the platform separators plus createTempFile / listRoots.

host/chez/java/nio-file.ss

@@ -102,6 +102,10 @@
                      (else (string-append acc (path-join-sep windows? acc) p))))
              "" parts))
 (define (npath-get first . more)
+  (if (and (null? more) (uri-jhost? first))
+      (make-nio-path (npath-join-for (nio-windows?) (list (nio-uri->path first))))
+      (npath-get-strings first more)))
+(define (npath-get-strings first more)
   (make-nio-path (npath-join-for (nio-windows?)
                                  (cons (npath-string-of first)
                                        (map npath-string-of (npath-spread-args more))))))

host/chez/java/process.ss

@@ -556,6 +556,30 @@
   (jolt-foreign-proc-safe "posix_spawn_file_actions_addinherit_np" '(void* int) 'int))
 (define proc-POSIX-SPAWN-CLOEXEC-DEFAULT #x4000)   ; <sys/spawn.h>, Darwin
 
+;; A child starts with SIGPIPE at SIG_DFL, as the JVM's do (jolt-lang/jolt#1196).
+;; This process ignores SIGPIPE — Chez's runtime does, so a write to a closed pipe
+;; answers EPIPE instead of killing jolt — and an IGNORED disposition survives
+;; exec, unlike a handler. Left alone, every child and everything it runs saw a
+;; closed pipe as an error: `yes | head` printed "Broken pipe" from yes and exited
+;; through its error path instead of dying of the signal. The shell cannot undo it
+;; either; POSIX has a non-interactive sh keep a signal ignored on entry ignored.
+;; POSIX_SPAWN_SETSIGDEF resets the signals in the attribute's set in the child,
+;; between fork and exec. The flag is 4 and SIGPIPE 13 on every host that spawns
+;; here (Linux glibc/musl/bionic, Darwin). sigset_t is 4 bytes on Darwin and 128
+;; on glibc; a posix_spawnattr_t is a pointer on Darwin and bionic and 336 bytes
+;; on glibc — the allocations below cover the widest.
+(define proc-attr-setsigdefault
+  (jolt-foreign-proc-safe "posix_spawnattr_setsigdefault" '(void* void*) 'int))
+(define proc-c-sigemptyset (jolt-foreign-proc-safe "sigemptyset" '(void*) 'int))
+(define proc-c-sigaddset   (jolt-foreign-proc-safe "sigaddset"   '(void* int) 'int))
+(define proc-POSIX-SPAWN-SETSIGDEF #x04)
+(define proc-SIGPIPE 13)
+(define proc-attr-bytes 512)
+(define proc-sigset-bytes 256)
+(define (proc-sigdefault-ok?)
+  (and proc-attr-init proc-attr-setflags proc-attr-destroy proc-attr-setsigdefault
+       proc-c-sigemptyset proc-c-sigaddset #t))
+
 ;; What posix_spawn-with-pipes needs, and nothing more. The R8 fiber-parking
 ;; extension's own bindings (fcntl, errno) are gated separately by
 ;; proc-nonblock-ok? above: losing parking is a performance story, losing this
@@ -1021,14 +1045,24 @@
              (err-p (and (not inherit-err?) (mk-pipe #t #f)))
              (barrier (proc-exec-barrier-pipe))
              (fa (sa-foreign-alloc 128))
-             ;; posix_spawnattr_t is one pointer on Darwin, the only place this
-             ;; is allocated; 64 bytes leaves room for a wider layout regardless.
-             (attr (and (proc-cloexec-default?) (sa-foreign-alloc 64)))
+             (cloexec? (proc-cloexec-default?))
+             (sigdef? (proc-sigdefault-ok?))
+             (attr (and (or cloexec? sigdef?) (sa-foreign-alloc proc-attr-bytes)))
              (pidbuf (sa-foreign-alloc 8)))
         (proc-fa-init fa)
         (when attr
           (proc-attr-init attr)
-          (proc-attr-setflags attr proc-POSIX-SPAWN-CLOEXEC-DEFAULT)
+          (proc-attr-setflags attr
+            (fxior (if cloexec? proc-POSIX-SPAWN-CLOEXEC-DEFAULT 0)
+                   (if sigdef? proc-POSIX-SPAWN-SETSIGDEF 0)))
+          (when sigdef?
+            (let ((set (sa-foreign-alloc proc-sigset-bytes)))
+              (proc-c-sigemptyset set)
+              (proc-c-sigaddset set proc-SIGPIPE)
+              ;; the attribute keeps its own copy
+              (proc-attr-setsigdefault attr set)
+              (sa-foreign-free set))))
+        (when cloexec?
           ;; An inherited stream has no dup2 naming it, so under the flag it
           ;; would be closed with everything else: name it.
           (when inherit-in?  (proc-fa-inherit fa 0))
@@ -1045,7 +1079,7 @@
         ;; LAST of the file actions, so the dup2s above have already moved the
         ;; child's ends onto 0/1/2 by the time everything else goes. Under
         ;; CLOEXEC_DEFAULT the kernel does this part.
-        (unless attr
+        (unless cloexec?
           (proc-close-inherited-fds!
             fa (append (if in-p  (list (car in-p)  (cdr in-p))  '())
                        (if out-p (list (car out-p) (cdr out-p)) '())
@@ -1056,7 +1090,7 @@
                (envp (proc-marshal-argv
                       (map (lambda (p) (string-append (car p) "=" (cdr p)))
                            (proc-child-env-pairs))))
-               ;; attrp is NULL — or carries only the CLOEXEC_DEFAULT flag, never
+               ;; attrp carries CLOEXEC_DEFAULT and SETSIGDEF at most, never
                ;; SETSIGMASK — so the child inherits this thread's signal mask,
                ;; which must carry none of jolt's own blocking (concurrency.ss).
                (rc (jolt-with-empty-sigmask

host/chez/locks.ss

@@ -500,25 +500,34 @@
 ;; deref 1.15x against a 1.1x ceiling (release binary, A/B/A). Threaded through,
 ;; the fast path is an `(if ibox ...)` that falls through (jolt-a0f1).
 (define (jolt-cv-wait/ibox mu cv deadline decide ibox who)
-  ;; Registered OUTSIDE mu, and only for a fiber. Outside because the timer's
-  ;; thunks run with timeout-mu released but registering takes it, so doing this
-  ;; under mu would order mu above timeout-mu here and below it there.
+  ;; The deadline wake is registered only for a fiber; a thread waits on cv with
+  ;; the deadline itself. It is cancelled as the wait ends, however it ends, so a
+  ;; timed deref answered in a millisecond does not leave its wake — and, through
+  ;; mu and cv, whatever those keep reachable — pending on the timer until the
+  ;; deadline. Arming and cancelling only take timeout-mu, a leaf (async.ss: no
+  ;; thunk runs under it), so the handler below may do either at the raise point,
+  ;; under mu or not.
   ;;
-  ;; The deadline is cancelled as the wait ends, however it ends, so a timed deref
-  ;; answered in a millisecond does not leave its wake — and, through mu and cv,
-  ;; whatever those keep reachable — pending on the timer until the deadline. The
-  ;; cancel on a raise runs at the raise point, possibly under mu; that is sound
-  ;; because cancelling only takes timeout-mu, which is a leaf (async.ss).
+  ;; A raise passing through is not necessarily the end of the wait: a handler
+  ;; further out may resume it. So the handler cancels, and if the raise comes
+  ;; back, re-arms — otherwise the resumed wait parks with nothing to wake it at
+  ;; its deadline. A wake that had already been collected to run is not re-armed;
+  ;; it is on its way. The park's own may-park! assertion (the park/lock gate
+  ;; wants it in jolt-cv-wait/park, next to the commit) runs after arming; when it
+  ;; refuses, its raise passes through the handler and the wake is cancelled.
   (if (and deadline (jolt-current-fiber))
-      (begin
-        ;; before the deadline timer registers a wake for this wait
-        (jolt-fiber-may-park! who)
-        (let* ((timer (jolt-timer-at! deadline (lambda () (jolt-with-mutex mu (jolt-cv-wake! cv)))))
-               (r (with-exception-handler
-                    (lambda (e) (jolt-timer-cancel! timer) (raise-continuable e))
-                    (lambda () (jolt-cv-wait/park mu cv deadline decide ibox who)))))
-          (jolt-timer-cancel! timer)
-          r))
+      (let* ((arm (lambda ()
+                    (jolt-timer-at! deadline (lambda () (jolt-with-mutex mu (jolt-cv-wake! cv))))))
+             (timer (arm))
+             (r (with-exception-handler
+                  (lambda (e)
+                    (let* ((pending? (jolt-timer-cancel! timer))
+                           (v (raise-continuable e)))
+                      (when pending? (set! timer (arm)))
+                      v))
+                  (lambda () (jolt-cv-wait/park mu cv deadline decide ibox who)))))
+        (jolt-timer-cancel! timer)
+        r)
       (jolt-cv-wait/park mu cv deadline decide ibox who)))
 
 (define (jolt-cv-wait/park mu cv deadline decide ibox who)

stdlib/jolt/time/enums.clj

@@ -14,6 +14,10 @@
 (defn month [n] (impl/value :jolt.time/month {:value n}))
 (defn month-val [e] (impl/field e :value))
 (defn- month-name [e] (nth u/month-names (dec (month-val e))))
+;; A month argument: the JDK overloads every `of` that takes a month number with
+;; one that takes a Month (LocalDate, LocalDateTime, YearMonth, MonthDay).
+(defn month-num [m]
+  (if (= :jolt.time/month (impl/type-of m)) (month-val m) (u/->long m)))
 
 (impl/register-type! :jolt.time/month
   {:eq   (fn [a b] (= (month-val a) (month-val b)))

stdlib/jolt/time/local.clj

@@ -119,7 +119,7 @@
 (declare ldt? ldt-epoch-day ldt-nod)
 
 (statics! ["LocalDate" "java.time.LocalDate"]
-  {"of"         (fn [y m d] (ld-of (u/->long y) (u/->long m) (u/->long d)))
+  {"of"         (fn [y m d] (ld-of (u/->long y) (e/month-num m) (u/->long d)))
    "ofEpochDay" (fn [n] (local-date (u/->long n)))
    "ofYearDay"  (fn [y doy] (local-date (+ (days-from-civil (u/->long y) 1 1) (dec (u/->long doy)))))
    "parse"      (fn [s & _] (local-date (parse-iso-date (str s))))
@@ -289,9 +289,9 @@
 
 (statics! ["LocalDateTime" "java.time.LocalDateTime"]
   {"of"      (fn ([d t] (local-dt (ld-epoch-day d) (lt-nano-of-day t)))
-                ([y mo d h mi] (local-dt (days-from-civil (u/->long y) (u/->long mo) (u/->long d)) (u/hmsn->nano (u/->long h) (u/->long mi) 0 0)))
-                ([y mo d h mi s] (local-dt (days-from-civil (u/->long y) (u/->long mo) (u/->long d)) (u/hmsn->nano (u/->long h) (u/->long mi) (u/->long s) 0)))
-                ([y mo d h mi s nano] (local-dt (days-from-civil (u/->long y) (u/->long mo) (u/->long d)) (u/hmsn->nano (u/->long h) (u/->long mi) (u/->long s) (u/->long nano)))))
+                ([y mo d h mi] (local-dt (days-from-civil (u/->long y) (e/month-num mo) (u/->long d)) (u/hmsn->nano (u/->long h) (u/->long mi) 0 0)))
+                ([y mo d h mi s] (local-dt (days-from-civil (u/->long y) (e/month-num mo) (u/->long d)) (u/hmsn->nano (u/->long h) (u/->long mi) (u/->long s) 0)))
+                ([y mo d h mi s nano] (local-dt (days-from-civil (u/->long y) (e/month-num mo) (u/->long d)) (u/hmsn->nano (u/->long h) (u/->long mi) (u/->long s) (u/->long nano)))))
    "ofEpochSecond" (fn [secs nano _off]
                      (let [es (u/->long secs)]
                        (local-dt (u/floor-div es 86400) (+ (* (u/floor-mod es 86400) nps) (u/->long nano)))))