New inaddr-str and in6addr-str functions.

* lisplib.c (sock_set_entries): Register autoload entries for
inaddr-str and in6addr-str. Register prefix symbol to be
interned.

* share/txr/stdlib/socket.tl (sockaddr-in, sockaddr-in6): Both
structs get a new member, prefix, defaulting to the respective
number of bits in the address.
(inaddr-str, in6addr-str): New functions.

* tests/014/iaddr-str, tests/014/inaddr-str.expected,
tests/014/in6addr-str.tl, tests/014/in6addr-str.expected:
New files

* txr.1: Documented.

1 files changed, 114 insertions, 0 deletions

diff --git a/share/txr/stdlib/socket.tl b/share/txr/stdlib/socket.tl
index 3236460c..54df9758 100644
--- a/share/txr/stdlib/socket.tl
+++ b/share/txr/stdlib/socket.tl
@@ -29,10 +29,12 @@
 
 (defstruct sockaddr-in sockaddr
   (addr 0) (port 0)
+  (prefix 32)
   (:static family af-inet))
 
 (defstruct sockaddr-in6 sockaddr
   (addr 0) (port 0) (flow-info 0) (scope-id 0)
+  (prefix 128)
   (:static family af-inet6))
 
 (defstruct sockaddr-un sockaddr
@@ -152,6 +154,118 @@
              (prefix (if (search cand-prefix '(0 0)) pieces cand-prefix)))
         `@(sys:in6addr-condensed-text prefix)/@(or width w)`))))
 
+(defun inaddr-str (str)
+  (labels ((invalid ()
+             (error "~s: invalid address ~s" 'inaddr-str str))
+           (mkaddr (octets port)
+             (unless [all octets (op <= 0 @1 255)]
+               (invalid))
+             (unless (<= 0 port 65535)
+               (invalid))
+             (new sockaddr-in
+                  addr (+ (ash (pop octets) 24)
+                          (ash (pop octets) 16)
+                          (ash (pop octets) 8)
+                          (car octets))
+                  port port))
+           (mkaddr-pf (octets prefix port)
+             (unless [all octets (op <= 0 @1 255)]
+               (invalid))
+             (unless (<= 0 prefix 32)
+               (invalid))
+             (unless (<= 0 port 65535)
+               (invalid))
+             (let* ((addr (+ (ash (or (pop octets) 0) 24)
+                             (ash (or (pop octets) 0) 16)
+                             (ash (or (pop octets) 0) 8)
+                             (or (car octets) 0))))
+               (new sockaddr-in
+                    addr (logand addr (ash -1 (- 32 prefix)))
+                    port port
+                    prefix prefix))))
+    (cond
+      ((r^$ #/\d+\.\d+\.\d+\.\d+:\d+/ str)
+       (tree-bind (addr port) (split* str (rpos #\: str))
+         (mkaddr [mapcar toint (spl #\. addr)] (toint port))))
+      ((r^$ #/\d+\.\d+\.\d+\.\d+(:\d+)?/ str)
+       (mkaddr [mapcar toint (spl #\. str)] 0))
+      ((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+/ str)
+       (tree-bind (addr prefix) (spl #\/ str)
+         (mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) 0)))
+      ((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+:\d+/ str)
+       (tree-bind (addr prefix port) (split-str-set str ":/")
+         (mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) (toint port))))
+      (t (invalid)))))
+
+(defun in6addr-str (str)
+  (labels ((invalid ()
+             (error "~s: invalid address ~s" 'in6addr-str str))
+           (mkaddr-full (pieces)
+             (unless [all pieces (op <= 0 @1 #xffff)]
+               (invalid))
+             (unless (eql 8 (length pieces))
+               (invalid))
+             (new sockaddr-in6
+                  addr (reduce-left (op + @2 (ash @1 16)) pieces)))
+           (mkaddr-brev (pieces-x pieces-y)
+             (let ((len-x (len pieces-x))
+                   (len-y (len pieces-y)))
+               (unless (<= (+ len-x len-y) 7)
+                 (invalid))
+               (let* ((val-x (reduce-left (op + @2 (ash @1 16)) pieces-x 0))
+                      (val-y (reduce-left (op + @2 (ash @1 16)) pieces-y 0))
+                      (addr (cond
+                              ((null pieces-x) val-y)
+                              ((null pieces-y) (ash val-x (* 16 (- 8 len-x))))
+                              (t (+ val-y
+                                    (ash val-x (* 16 (- 8 len-x))))))))
+                 (new sockaddr-in6
+                      addr addr))))
+           (str-to-pieces (str)
+              (unless (empty str)
+                [mapcar (lop toint 16) (spl #\: str)]))
+           (octets-to-pieces (octets)
+             (unless [all octets (op <= 0 @1 255)]
+               (invalid))
+             (list (+ (ash (pop octets) 8)
+                      (pop octets))
+                   (+ (ash (pop octets) 8)
+                      (pop octets)))))
+    (cond
+      ((r^$ #/\[.*\]:\d+/ str)
+       (tree-bind (addr-str port-str) (split* str (rpos #\: str))
+         (let ((addr (in6addr-str [addr-str 1..-1]))
+               (port (toint port-str)))
+           (unless (<= 0 port 65535)
+             (invalid))
+           (set addr.port port)
+           addr)))
+      ((r^$ #/[^\/]+\/\d+/ str)
+       (tree-bind (addr-str prefix-str) (split* str (rpos #\/ str))
+         (let ((addr (in6addr-str addr-str))
+               (prefix (toint prefix-str)))
+           (unless (<= 0 prefix 128)
+             (invalid))
+           (upd addr.addr (logand (ash -1 (- 128 prefix))))
+           (set addr.prefix prefix)
+           addr)))
+      ((r^$ #/[\da-fA-F]*(:[\da-fA-F]*)*/ str)
+       (upd str (regsub #/::/ "@"))
+       (let* ((str-splat (regsub #/::/ "@" str))
+              (maj-pieces (spl #\@ str-splat)))
+         (caseql (len maj-pieces)
+           (1 (mkaddr-full (str-to-pieces (car maj-pieces))))
+           (2 (mkaddr-brev (str-to-pieces (car maj-pieces))
+                           (str-to-pieces (cadr maj-pieces))))
+           (t (invalid)))))
+      ((r^$ #/::0*[fF][fF][fF][fF]:\d+\.\d+\.\d+\.\d+/ str)
+       (let* ((bigsplit (split* str (rpos #\: str)))
+              (4part (cadr bigsplit))
+              (octets [mapcar toint (spl #\. 4part)])
+              (pieces (cons #xffff (octets-to-pieces octets))))
+         (mkaddr-brev nil pieces)))
+      (t (invalid)))))
+
 (defplace (sock-peer sock) body
   (getter setter
     ^(macrolet ((,getter () ^(sock-peer ',',sock))