Make srv-noisy* atomic

Make srv-noisy* atomic

; HTTP Server.

; To improve performance with static files, set static-max-age*.

(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")

(= quitsrv* nil breaksrv* nil)

(def serve ((o port 8080))
  (wipe quitsrv*)
  (ensure-srvdirs)
  (map [apply new-bgthread _] pending-bgthreads*)
  (w/socket s port
    (setuid 2) ; XXX switch from root to pg
    (prn "ready to serve port " port)
    (flushout)
    (= currsock* s)
    (until quitsrv*
      (handle-request s breaksrv*)))
  (prn "quit server"))

(def serve1 ((o port 8080))
  (w/socket s port (handle-request s t)))

(def ensure-srvdirs ()
  (map ensure-dir (list arcdir* logdir* staticdir*)))

(= srv-noisy* nil)

; http requests currently capped at 2 meg by socket-accept

; should threads process requests one at a time? no, then
; a browser that's slow consuming the data could hang the
; whole server.

; wait for a connection from a browser and start a thread
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.

(= threadlife* 30  requests* 0  requests/ip* (table)
   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))

(def handle-request (s breaksrv)
  (if breaksrv
      (handle-request-1 s)
      (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (let (i o ip) (socket-accept s)
    (if (and (or (ignore-ips* ip) (abusive-ip ip))
             (++ (spurned* ip 0)))
        (force-close i o)
        (do (++ requests*)
            (++ (requests/ip* ip 0))
            (with (th1 nil th2 nil)
              (= th1 (thread
                       (after (handle-request-thread i o ip)
                              (close i o)
                              (kill-thread th2))))
              (= th2 (thread
                       (sleep threadlife*)
                       (unless (dead th1)
                         (prn "srv thread took too long for " ip))
                       (break-thread th1)
                       (force-close i o))))))))

; Returns true if ip has made req-limit* requests in less than
; req-window* seconds.  If an ip is throttled, only 1 request is
; allowed per req-window* seconds.  If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).

; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.

(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2 dos-protection* nil)

(def abusive-ip (ip)
  (and dos-protection*
       (only.> (requests/ip* ip) 250)
       (let now (seconds)
         (do1 (if (req-times* ip)
                  (and (>= (qlen (req-times* ip))
                           (if (throttle-ips* ip) 1 req-limit*))
                       (let dt (- now (deq (req-times* ip)))
                         (if (< dt dos-window*) (set (ignore-ips* ip)))
                         (< dt req-window*)))
                  (do (= (req-times* ip) (queue))
                      nil))
              (enq now (req-times* ip))))))

(def noisy-header (lines (o label) (o footer "\n"))
  (when srv-noisy*
    (atomic
      (if label (pr label))
      (each line lines
        (prn line))
      (if footer (pr footer))))
  lines)

(def handle-request-thread (i o ip)
  (with (nls 0 lines nil line nil responded nil t0 (msec))
    (after
      (whilet c (unless responded (readc i))
        (if (is c #\newline)
            (if (is (++ nls) 2)
                (let (type op args n cooks ip2) (parseheader (noisy-header (rev lines)))
                  (if ip2 (= ip ip2))
                  (let t1 (msec)
                    (case type
                      get  (respond o op args cooks ip)
                      post (handle-post i o op args n cooks ip)
                           (respond-err o "Unknown request: " (car lines)))
                    (log-request type op args cooks ip t0 t1)
                    (set responded)))
                (do (push (string (rev line)) lines)
                    (wipe line)))
            (unless (is c #\return)
              (push c line)
              (= nls 0))))
      (close i o)))
  (harvest-fnids))

(def log-request (type op args cooks ip t0 t1)
  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
    (srvlog 'srv ip
                 parsetime
                 respondtime
                 (if (> (+ parsetime respondtime) 1000) "***" "")
                 type
                 op
                 (let arg1 (car args)
                   (if (caris arg1 "fnid") "" arg1))
                 cooks)))

; Could ignore return chars (which come from textarea fields) here by
; (unless (is c #\return) (push c line))

(def handle-post (i o op args n cooks ip)
  (if (no n)
      (respond-err o "Post request without Content-Length.")
      (let line nil
        (whilet c (and (> n 0) (readc i))
          (-- n)
          (push c line))
        (let line (string (rev line))
          (noisy-header (list line) "Post Contents: ")
          (respond o op (+ (parseargs line) args) cooks ip)))))

(= type-header* (table))

(def gen-type-header (ctype)
  (+ "HTTP/1.0 200 OK
Content-Type: "
     ctype
     "
Connection: close"))

(= header* (gen-type-header "text/html; charset=utf-8"))

(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
     '((image/x-icon "image/x-icon")
       (image/svg "image/svg+xml")
       (image/gif "image/gif")
       (image/jpg "image/jpeg")
       (image/png "image/png")
       (text/html "text/html; charset=utf-8")
       (text/css  "text/css")
       (text/xml  "text/xml")
       (application/json        "application/json")
       (application/javascript  "application/javascript")
       (application/manifest    "application/manifest+json")
       ))

(= rdheader* "HTTP/1.0 302 Moved")

(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))

(def save-optime (name elapsed)
  ; this is the place to put a/b testing
  ; toggle a flag and push elapsed into one of two lists
  (++ (opcounts* name 0))
  (unless (optimes* name) (= (optimes* name) (queue)))
  (enq-limit elapsed (optimes* name) 1000))

; For ops that want to add their own headers.  They must thus remember
; to prn a blank line before anything meant to be part of the page.

(mac defop-raw (name parms . body)
  (w/uniq t1
    `(= (srvops* ',name)
        (fn ,parms
          (let ,t1 (msec)
            (do1 (do ,@body)
                 (save-optime ',name (- (msec) ,t1))))))))

(mac defopr-raw (name parms . body)
  `(= (redirector* ',name) t
      (srvops* ',name)     (fn ,parms ,@body)))

(mac defop (name parm . body)
  (w/uniq gs
    `(do (wipe (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           (w/stdout ,gs (prn) ,@body)))))

; Defines op as a redirector.  Its retval is new location.

(mac defopr (name parm . body)
  (w/uniq gs
    `(do (set (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           ,@body))))

;(mac testop (name . args) `((srvops* ',name) ,@args))

(deftem request
  args  nil
  cooks nil
  ip    nil)

(= unknown-msg* "Unknown." max-age* (table) static-header* (table) static-max-age* nil)

(def respond (str op args cooks ip)
  (w/stdout str
    ;(hook 'respond op args cooks ip)
    (let (op args) (parseop op args)
      (iflet f (srvops* op)
             (let req (inst 'request 'args args 'cooks cooks 'ip ip)
               (if (redirector* op)
                   (do (prn rdheader*)
                       (prn "Location: " (f str req))
                       (prn))
                   (do (prn header*)
                       (awhen (max-age* op)
                         (prn "Cache-Control: max-age=" it))
                       (f str req))))
             (withs (op (car (tokens op #\?))
                     filetype (static-filetype op))
               (aif (and filetype (file-exists (string staticdir* op)))
                    (do (prn (or (static-header* op) (type-header* filetype)))
                        (awhen static-max-age*
                          (prn "Cache-Control: max-age=" it))
                        (prn)
                        (w/infile i it
                          (whilet b (readb i)
                            (writeb b str))))
                    (respond-err str unknown-msg*)))))))

(def static-filetype (sym)
  (let fname (str sym)
    (and (~find #\/ fname)
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "ico"  'image/x-icon
           "svg"  'image/svg
           "gif"  'image/gif
           "jpg"  'image/jpg
           "jpeg" 'image/jpg
           "png"  'image/png
           "css"  'text/css
           "txt"  'text/plain
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/plain
           "xml"  'text/xml
           "js"           'application/javascript
           "json"         'application/json
           "webmanifest"  'application/manifest
           ))))

(def respond-err (str msg . args)
  (w/stdout str
    (prn header*)
    (prn)
    (apply pr msg args)))

(def parseop (op args)
  (let xs (tokens op #\/)
    (if (< (len xs) 2)
        (list op args)
        (list (sym (car xs)) (join (list (list "path" (concat (cdr xs) #\/))) args)))))

(def parseheader (lines)
  (let (type op args) (parseurl (car lines))
    (list type
          op
          args
          (and (is type 'post)
               (some (fn (s)
                       (and (begins s "Content-Length:")
                            (errsafe:coerce (cadr (tokens s)) 'int)))
                     (cdr lines)))
          (some (fn (s)
                  (and (or (begins s "Cookie:")
                           (begins s "cookie:"))
                       (parsecookies s)))
                (cdr lines))
          (some (fn (s)
                  (and (begins s "CF-Connecting-IP:")
                       (errsafe:cadr (tokens s))))
                (cdr lines)))))

; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))

(def parseurl (s)
  (let (type url) (tokens s)
    (let (base args) (tokens url #\?)
      (list (sym (downcase type))
            (sym (cut base 1))
            (if args
                (parseargs args)
                nil)))))

; I don't urldecode field names or anything in cookies; correct?

(def parseargs (s)
  (map (fn ((k v)) (list k (urldecode v)))
       (map [tokens _ #\=] (tokens s #\&))))

(def parsecookies (s)
  (map [tokens _ #\=]
       (cdr (tokens s [or (whitec _) (is _ #\;)]))))

(def arg (req key) (alref req!args key))

; *** Warning: does not currently urlencode args, so if need to do
; that replace v with (urlencode v).

(def reassemble-args (req)
  (aif req!args
       (apply string "?" (intersperse '&
                                      (map (fn ((k v))
                                             (string k '= v))
                                           it)))
       ""))

(= fns* (table) fnids* nil timed-fnids* nil)

; count on huge (expt 64 10) size of fnid space to avoid clashes

(def new-fnid ()
  (check (sym (rand-string 10)) ~fns* (new-fnid)))

(def fnid (f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push key fnids*)
    key))

(def timed-fnid (lasts f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push (list key (seconds) lasts) timed-fnids*)
    key))

; Within f, it will be bound to the fn's own fnid.  Remember that this is
; so low-level that need to generate the newline to separate from the headers
; within the body of f.

(mac afnid (f)
  `(atlet it (new-fnid)
     (= (fns* it) ,f)
     (push it fnids*)
     it))

;(defop test-afnid req
;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
;    (pr "click here")))

; To be more sophisticated, instead of killing fnids, could first
; replace them with fns that tell the server it's harvesting too
; aggressively if they start to get called.  But the right thing to
; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.

(def harvest-fnids ((o n 50000))  ; was 20000
  (when (len> fns* n)
    (pull (fn ((id created lasts))
            (when (> (since created) lasts)
              (wipe (fns* id))
              t))
          timed-fnids*)
    (atlet nharvest (trunc (/ n 10))
      (let (kill keep) (split (rev fnids*) nharvest)
        (= fnids* (rev keep))
        (each id kill
          (wipe (fns* id)))))))

(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")

(= dead-msg* "\nUnknown or expired link.")

(defop-raw x (str req)
  (w/stdout str
    (aif (fns* (sym (arg req "fnid")))
         (it req)
         (pr dead-msg*))))

(defopr-raw y (str req)
  (aif (fns* (sym (arg req "fnid")))
       (w/stdout str (it req))
       "deadlink"))

; For asynchronous calls; discards the page.  Would be better to tell
; the fn not to generate it.

(defop-raw a (str req)
  (aif (fns* (sym (arg req "fnid")))
       (tostring (it req))))

(defopr r req
  (aif (fns* (sym (arg req "fnid")))
       (it req)
       "deadlink"))

(defop deadlink req
  (pr dead-msg*))

(def url-for (fnid)
  (string fnurl* "?fnid=" fnid))

(def flink (f)
  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))

(def rflink (f)
  (string rfnurl* "?fnid=" (fnid f)))

; Since it's just an expr, gensym a parm for (ignored) args.

(mac w/link (expr . body)
  `(tag (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(mac w/rlink (expr . body)
  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
     ,@body))

(mac onlink (text . body)
  `(w/link (do ,@body) (pr ,text)))

(mac onrlink (text . body)
  `(w/rlink (do ,@body) (pr ,text)))

; bad to have both flink and linkf; rename flink something like fnid-link

(mac linkf (text parms . body)
  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))

(mac rlinkf (text parms . body)
  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))

;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))

;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))

(mac w/link-if (test expr . body)
  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(def fnid-field (id)
  (gentag input type 'hidden name 'fnid value id))

; f should be a fn of one arg, which will be http request args.

(def fnform (f bodyfn (o redir))
  (tag (form method 'post action (if redir rfnurl2* fnurl*))
    (fnid-field (fnid f))
    (bodyfn)))

; Could also make a version that uses just an expr, and var capture.
; Is there a way to ensure user doesn't use "fnid" as a key?

(mac aform (f . body)
  (w/uniq ga
    `(tag (form method 'post action fnurl*)
       (fnid-field (fnid (fn (,ga)
                           (prn)
                           (,f ,ga))))
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prn) (pr req))
;          (fn () (single-input "" 'foo 20 "submit"))))

;(defop test2 req
;  (aform (fn (req) (pr req))
;    (single-input "" 'foo 20 "submit")))

; Like aform except creates a fnid that will last for lasts seconds
; (unless the server is restarted).

(mac taform (lasts f . body)
  (w/uniq (gl gf gi ga)
    `(withs (,gl ,lasts
             ,gf (fn (,ga) (prn) (,f ,ga)))
       (tag (form method 'post action fnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac arform (f . body)
  `(tag (form method 'post action rfnurl*)
     (fnid-field (fnid ,f))
     ,@body))

; overlong

(mac tarform (lasts f . body)
  (w/uniq (gl gf)
    `(withs (,gl ,lasts ,gf ,f)
       (tag (form method 'post action rfnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac aformh (f . body)
  `(tag (form method 'post action fnurl*)
     (fnid-field (fnid ,f))
     ,@body))

(mac arformh (f . body)
  `(tag (form method 'post action rfnurl2*)
     (fnid-field (fnid ,f))
     ,@body))

; only unique per server invocation

(= unique-ids* (table))

(def unique-id ((o len 8))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
        (unique-id)
        (= (unique-ids* id) id))))

(def srvlog (type . args)
  (w/appendfile o (logfile-name type)
    (w/stdout o (atomic (apply prs (seconds) args) (prn)))))

(def logfile-name (type)
  (string logdir* type "-" (memodate)))

(with (lastasked nil lastval nil)

(def memodate ()
  (let now (seconds)
    (if (or (no lastasked) (> (- now lastasked) 60))
        (= lastasked now lastval (datestring))
        lastval)))

)

(defop || req (pr "It's alive."))

(defop topips req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (each ip (let leaders nil
                   (maptable (fn (ip n)
                               (when (> n 100)
                                 (insort (compare > requests/ip*)
                                         ip
                                         leaders)))
                             requests/ip*)
                   leaders)
          (let n (requests/ip* ip)
            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))

(defop spurned req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (map (fn ((ip n)) (row ip n))
             (sortable spurned*))))))

; eventually promote to general util

(def sortable (ht (o f >))
  (let res nil
    (maptable (fn kv
                (insort (compare f cadr) kv res))
              ht)
    res))

; Background Threads

(= bgthreads* (table) pending-bgthreads* nil)

(def new-bgthread (id f sec)
  (aif (bgthreads* id) (break-thread it))
  (= (bgthreads* id) (new-thread (fn ()
                                   (while t
                                     (sleep sec)
                                     (f))))))

; should be a macro for this?

(mac defbg (id sec . body)
  `(do (pull [caris _ ',id] pending-bgthreads*)
       (push (list ',id (fn () ,@body) ,sec)
             pending-bgthreads*)))

; Idea: make form fields that know their value type because of
; gensymed names, and so the receiving fn gets args that are not
; strings but parsed values.

; HTTP Server.

; To improve performance with static files, set static-max-age*.

(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")

(= quitsrv* nil breaksrv* nil)

(def serve ((o port 8080))
  (wipe quitsrv*)
  (ensure-srvdirs)
  (map [apply new-bgthread _] pending-bgthreads*)
  (w/socket s port
    (setuid 2) ; XXX switch from root to pg
    (prn "ready to serve port " port)
    (flushout)
    (= currsock* s)
    (until quitsrv*
      (handle-request s breaksrv*)))
  (prn "quit server"))

(def serve1 ((o port 8080))
  (w/socket s port (handle-request s t)))

(def ensure-srvdirs ()
  (map ensure-dir (list arcdir* logdir* staticdir*)))

(= srv-noisy* nil)

; http requests currently capped at 2 meg by socket-accept

; should threads process requests one at a time? no, then
; a browser that's slow consuming the data could hang the
; whole server.

; wait for a connection from a browser and start a thread
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.

(= threadlife* 30  requests* 0  requests/ip* (table)
   throttle-ips* (table)  ignore-ips* (table)  spurned* (table))

(def handle-request (s breaksrv)
  (if breaksrv
      (handle-request-1 s)
      (errsafe (handle-request-1 s))))

(def handle-request-1 (s)
  (let (i o ip) (socket-accept s)
    (if (and (or (ignore-ips* ip) (abusive-ip ip))
             (++ (spurned* ip 0)))
        (force-close i o)
        (do (++ requests*)
            (++ (requests/ip* ip 0))
            (with (th1 nil th2 nil)
              (= th1 (thread
                       (after (handle-request-thread i o ip)
                              (close i o)
                              (kill-thread th2))))
              (= th2 (thread
                       (sleep threadlife*)
                       (unless (dead th1)
                         (prn "srv thread took too long for " ip))
                       (break-thread th1)
                       (force-close i o))))))))

; Returns true if ip has made req-limit* requests in less than
; req-window* seconds.  If an ip is throttled, only 1 request is
; allowed per req-window* seconds.  If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).

; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.

(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2 dos-protection* nil)

(def abusive-ip (ip)
  (and dos-protection*
       (only.> (requests/ip* ip) 250)
       (let now (seconds)
         (do1 (if (req-times* ip)
                  (and (>= (qlen (req-times* ip))
                           (if (throttle-ips* ip) 1 req-limit*))
                       (let dt (- now (deq (req-times* ip)))
                         (if (< dt dos-window*) (set (ignore-ips* ip)))
                         (< dt req-window*)))
                  (do (= (req-times* ip) (queue))
                      nil))
              (enq now (req-times* ip))))))

(def handle-request-thread (i o ip)
  (with (nls 0 lines nil line nil responded nil t0 (msec))
    (after
      (whilet c (unless responded (readc i))
        (if srv-noisy* (pr c))
        (if (is c #\newline)
            (if (is (++ nls) 2)
                (let (type op args n cooks ip2) (parseheader (rev lines))
                  (if ip2 (= ip ip2))
                  (let t1 (msec)
                    (case type
                      get  (respond o op args cooks ip)
                      post (handle-post i o op args n cooks ip)
                           (respond-err o "Unknown request: " (car lines)))
                    (log-request type op args cooks ip t0 t1)
                    (set responded)))
                (do (push (string (rev line)) lines)
                    (wipe line)))
            (unless (is c #\return)
              (push c line)
              (= nls 0))))
      (close i o)))
  (harvest-fnids))

(def log-request (type op args cooks ip t0 t1)
  (with (parsetime (- t1 t0) respondtime (- (msec) t1))
    (srvlog 'srv ip
                 parsetime
                 respondtime
                 (if (> (+ parsetime respondtime) 1000) "***" "")
                 type
                 op
                 (let arg1 (car args)
                   (if (caris arg1 "fnid") "" arg1))
                 cooks)))

; Could ignore return chars (which come from textarea fields) here by
; (unless (is c #\return) (push c line))

(def handle-post (i o op args n cooks ip)
  (if srv-noisy* (pr "Post Contents: "))
  (if (no n)
      (respond-err o "Post request without Content-Length.")
      (let line nil
        (whilet c (and (> n 0) (readc i))
          (if srv-noisy* (pr c))
          (-- n)
          (push c line))
        (if srv-noisy* (pr "\n\n"))
        (respond o op (+ (parseargs (string (rev line))) args) cooks ip))))

(= type-header* (table))

(def gen-type-header (ctype)
  (+ "HTTP/1.0 200 OK
Content-Type: "
     ctype
     "
Connection: close"))

(= header* (gen-type-header "text/html; charset=utf-8"))

(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
     '((image/x-icon "image/x-icon")
       (image/svg "image/svg+xml")
       (image/gif "image/gif")
       (image/jpg "image/jpeg")
       (image/png "image/png")
       (text/html "text/html; charset=utf-8")
       (text/css  "text/css")
       (text/xml  "text/xml")
       (application/json        "application/json")
       (application/javascript  "application/javascript")
       (application/manifest    "application/manifest+json")
       ))

(= rdheader* "HTTP/1.0 302 Moved")

(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))

(def save-optime (name elapsed)
  ; this is the place to put a/b testing
  ; toggle a flag and push elapsed into one of two lists
  (++ (opcounts* name 0))
  (unless (optimes* name) (= (optimes* name) (queue)))
  (enq-limit elapsed (optimes* name) 1000))

; For ops that want to add their own headers.  They must thus remember
; to prn a blank line before anything meant to be part of the page.

(mac defop-raw (name parms . body)
  (w/uniq t1
    `(= (srvops* ',name)
        (fn ,parms
          (let ,t1 (msec)
            (do1 (do ,@body)
                 (save-optime ',name (- (msec) ,t1))))))))

(mac defopr-raw (name parms . body)
  `(= (redirector* ',name) t
      (srvops* ',name)     (fn ,parms ,@body)))

(mac defop (name parm . body)
  (w/uniq gs
    `(do (wipe (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           (w/stdout ,gs (prn) ,@body)))))

; Defines op as a redirector.  Its retval is new location.

(mac defopr (name parm . body)
  (w/uniq gs
    `(do (set (redirector* ',name))
         (defop-raw ,name (,gs ,parm)
           ,@body))))

;(mac testop (name . args) `((srvops* ',name) ,@args))

(deftem request
  args  nil
  cooks nil
  ip    nil)

(= unknown-msg* "Unknown." max-age* (table) static-header* (table) static-max-age* nil)

(def respond (str op args cooks ip)
  (w/stdout str
    ;(hook 'respond op args cooks ip)
    (let (op args) (parseop op args)
      (iflet f (srvops* op)
             (let req (inst 'request 'args args 'cooks cooks 'ip ip)
               (if (redirector* op)
                   (do (prn rdheader*)
                       (prn "Location: " (f str req))
                       (prn))
                   (do (prn header*)
                       (awhen (max-age* op)
                         (prn "Cache-Control: max-age=" it))
                       (f str req))))
             (withs (op (car (tokens op #\?))
                     filetype (static-filetype op))
               (aif (and filetype (file-exists (string staticdir* op)))
                    (do (prn (or (static-header* op) (type-header* filetype)))
                        (awhen static-max-age*
                          (prn "Cache-Control: max-age=" it))
                        (prn)
                        (w/infile i it
                          (whilet b (readb i)
                            (writeb b str))))
                    (respond-err str unknown-msg*)))))))

(def static-filetype (sym)
  (let fname (str sym)
    (and (~find #\/ fname)
         (case (downcase (last (check (tokens fname #\.) ~single)))
           "ico"  'image/x-icon
           "svg"  'image/svg
           "gif"  'image/gif
           "jpg"  'image/jpg
           "jpeg" 'image/jpg
           "png"  'image/png
           "css"  'text/css
           "txt"  'text/plain
           "htm"  'text/html
           "html" 'text/html
           "arc"  'text/plain
           "xml"  'text/xml
           "js"           'application/javascript
           "json"         'application/json
           "webmanifest"  'application/manifest
           ))))

(def respond-err (str msg . args)
  (w/stdout str
    (prn header*)
    (prn)
    (apply pr msg args)))

(def parseop (op args)
  (let xs (tokens op #\/)
    (if (< (len xs) 2)
        (list op args)
        (list (sym (car xs)) (join (list (list "path" (concat (cdr xs) #\/))) args)))))

(def parseheader (lines)
  (let (type op args) (parseurl (car lines))
    (list type
          op
          args
          (and (is type 'post)
               (some (fn (s)
                       (and (begins s "Content-Length:")
                            (errsafe:coerce (cadr (tokens s)) 'int)))
                     (cdr lines)))
          (some (fn (s)
                  (and (or (begins s "Cookie:")
                           (begins s "cookie:"))
                       (parsecookies s)))
                (cdr lines))
          (some (fn (s)
                  (and (begins s "CF-Connecting-IP:")
                       (errsafe:cadr (tokens s))))
                (cdr lines)))))

; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))

(def parseurl (s)
  (let (type url) (tokens s)
    (let (base args) (tokens url #\?)
      (list (sym (downcase type))
            (sym (cut base 1))
            (if args
                (parseargs args)
                nil)))))

; I don't urldecode field names or anything in cookies; correct?

(def parseargs (s)
  (map (fn ((k v)) (list k (urldecode v)))
       (map [tokens _ #\=] (tokens s #\&))))

(def parsecookies (s)
  (map [tokens _ #\=]
       (cdr (tokens s [or (whitec _) (is _ #\;)]))))

(def arg (req key) (alref req!args key))

; *** Warning: does not currently urlencode args, so if need to do
; that replace v with (urlencode v).

(def reassemble-args (req)
  (aif req!args
       (apply string "?" (intersperse '&
                                      (map (fn ((k v))
                                             (string k '= v))
                                           it)))
       ""))

(= fns* (table) fnids* nil timed-fnids* nil)

; count on huge (expt 64 10) size of fnid space to avoid clashes

(def new-fnid ()
  (check (sym (rand-string 10)) ~fns* (new-fnid)))

(def fnid (f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push key fnids*)
    key))

(def timed-fnid (lasts f)
  (atlet key (new-fnid)
    (= (fns* key) f)
    (push (list key (seconds) lasts) timed-fnids*)
    key))

; Within f, it will be bound to the fn's own fnid.  Remember that this is
; so low-level that need to generate the newline to separate from the headers
; within the body of f.

(mac afnid (f)
  `(atlet it (new-fnid)
     (= (fns* it) ,f)
     (push it fnids*)
     it))

;(defop test-afnid req
;  (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
;    (pr "click here")))

; To be more sophisticated, instead of killing fnids, could first
; replace them with fns that tell the server it's harvesting too
; aggressively if they start to get called.  But the right thing to
; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.

(def harvest-fnids ((o n 50000))  ; was 20000
  (when (len> fns* n)
    (pull (fn ((id created lasts))
            (when (> (since created) lasts)
              (wipe (fns* id))
              t))
          timed-fnids*)
    (atlet nharvest (trunc (/ n 10))
      (let (kill keep) (split (rev fnids*) nharvest)
        (= fnids* (rev keep))
        (each id kill
          (wipe (fns* id)))))))

(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")

(= dead-msg* "\nUnknown or expired link.")

(defop-raw x (str req)
  (w/stdout str
    (aif (fns* (sym (arg req "fnid")))
         (it req)
         (pr dead-msg*))))

(defopr-raw y (str req)
  (aif (fns* (sym (arg req "fnid")))
       (w/stdout str (it req))
       "deadlink"))

; For asynchronous calls; discards the page.  Would be better to tell
; the fn not to generate it.

(defop-raw a (str req)
  (aif (fns* (sym (arg req "fnid")))
       (tostring (it req))))

(defopr r req
  (aif (fns* (sym (arg req "fnid")))
       (it req)
       "deadlink"))

(defop deadlink req
  (pr dead-msg*))

(def url-for (fnid)
  (string fnurl* "?fnid=" fnid))

(def flink (f)
  (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))

(def rflink (f)
  (string rfnurl* "?fnid=" (fnid f)))

; Since it's just an expr, gensym a parm for (ignored) args.

(mac w/link (expr . body)
  `(tag (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(mac w/rlink (expr . body)
  `(tag (a href (rflink (fn (,(uniq)) ,expr)))
     ,@body))

(mac onlink (text . body)
  `(w/link (do ,@body) (pr ,text)))

(mac onrlink (text . body)
  `(w/rlink (do ,@body) (pr ,text)))

; bad to have both flink and linkf; rename flink something like fnid-link

(mac linkf (text parms . body)
  `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))

(mac rlinkf (text parms . body)
  `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))

;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))

;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))

(mac w/link-if (test expr . body)
  `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
     ,@body))

(def fnid-field (id)
  (gentag input type 'hidden name 'fnid value id))

; f should be a fn of one arg, which will be http request args.

(def fnform (f bodyfn (o redir))
  (tag (form method 'post action (if redir rfnurl2* fnurl*))
    (fnid-field (fnid f))
    (bodyfn)))

; Could also make a version that uses just an expr, and var capture.
; Is there a way to ensure user doesn't use "fnid" as a key?

(mac aform (f . body)
  (w/uniq ga
    `(tag (form method 'post action fnurl*)
       (fnid-field (fnid (fn (,ga)
                           (prn)
                           (,f ,ga))))
       ,@body)))

;(defop test1 req
;  (fnform (fn (req) (prn) (pr req))
;          (fn () (single-input "" 'foo 20 "submit"))))

;(defop test2 req
;  (aform (fn (req) (pr req))
;    (single-input "" 'foo 20 "submit")))

; Like aform except creates a fnid that will last for lasts seconds
; (unless the server is restarted).

(mac taform (lasts f . body)
  (w/uniq (gl gf gi ga)
    `(withs (,gl ,lasts
             ,gf (fn (,ga) (prn) (,f ,ga)))
       (tag (form method 'post action fnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac arform (f . body)
  `(tag (form method 'post action rfnurl*)
     (fnid-field (fnid ,f))
     ,@body))

; overlong

(mac tarform (lasts f . body)
  (w/uniq (gl gf)
    `(withs (,gl ,lasts ,gf ,f)
       (tag (form method 'post action rfnurl*)
         (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
         ,@body))))

(mac aformh (f . body)
  `(tag (form method 'post action fnurl*)
     (fnid-field (fnid ,f))
     ,@body))

(mac arformh (f . body)
  `(tag (form method 'post action rfnurl2*)
     (fnid-field (fnid ,f))
     ,@body))

; only unique per server invocation

(= unique-ids* (table))

(def unique-id ((o len 8))
  (let id (sym (rand-string (max 5 len)))
    (if (unique-ids* id)
        (unique-id)
        (= (unique-ids* id) id))))

(def srvlog (type . args)
  (w/appendfile o (logfile-name type)
    (w/stdout o (atomic (apply prs (seconds) args) (prn)))))

(def logfile-name (type)
  (string logdir* type "-" (memodate)))

(with (lastasked nil lastval nil)

(def memodate ()
  (let now (seconds)
    (if (or (no lastasked) (> (- now lastasked) 60))
        (= lastasked now lastval (datestring))
        lastval)))

)

(defop || req (pr "It's alive."))

(defop topips req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (each ip (let leaders nil
                   (maptable (fn (ip n)
                               (when (> n 100)
                                 (insort (compare > requests/ip*)
                                         ip
                                         leaders)))
                             requests/ip*)
                   leaders)
          (let n (requests/ip* ip)
            (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))

(defop spurned req
  (when (admin (get-user req))
    (whitepage
      (sptab
        (map (fn ((ip n)) (row ip n))
             (sortable spurned*))))))

; eventually promote to general util

(def sortable (ht (o f >))
  (let res nil
    (maptable (fn kv
                (insort (compare f cadr) kv res))
              ht)
    res))

; Background Threads

(= bgthreads* (table) pending-bgthreads* nil)

(def new-bgthread (id f sec)
  (aif (bgthreads* id) (break-thread it))
  (= (bgthreads* id) (new-thread (fn ()
                                   (while t
                                     (sleep sec)
                                     (f))))))

; should be a macro for this?

(mac defbg (id sec . body)
  `(do (pull [caris _ ',id] pending-bgthreads*)
       (push (list ',id (fn () ,@body) ,sec)
             pending-bgthreads*)))

; Idea: make form fields that know their value type because of
; gensymed names, and so the receiving fn gets args that are not
; strings but parsed values.


hl2b/hl.arc: added <hl>mac emulation

hl2b/hl.arc: added <hl>mac emulation

(in-package hl)
(using <arc>v3)

(mac <hl>def (spec . rest)
  (if
    (acons spec)
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,(car spec)
             ; should really be <hl>fn, but for now we use
             ; <axiom>lambda
             (<axiom>lambda ,(cdr spec)
               ,@rest))))
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,spec
             ,(car rest))))))
(mac <hl>defm (sig . rest)
  (withs (f  (rep <arc>defm)
          rv (apply f (car sig) (cdr sig) rest)
          (set-axiom var (poly-fn types (fn-axiom parms . body) old))
             rv)
    ; NOTE! differences in <arc>polymorph and
    ; <hl>polymorph:
    ;   (<arc>polymorph signature generic specific)
    ;   (<hl>polymorph generic signature specific)
    ; - the change in order was done since we might
    ;   want to overload how overloading of particular
    ;   objects as generics are done
    ; wrap in w/gvl
    `((<axiom>symeval '<common>call-w/gvl)
      (<axiom>lambda ()
        (<axiom>set ,var (<hl>polymorph ,old ,types (<axiom>lambda ,parms ,@body)))))))
; WARNING! limited 'let only, no destructuring
; for bootstrapping purposes only.  Full destructuring
; support will be added in cs/, but cs/ itself can't
; use it.
(mac <hl>let (var val . rest)
  (if (isnt (type var) 'sym)
      (err "bootstrapping 'let does not support destructuring")
      `((<axiom>lambda (,var)
          ,@rest)
        ,val)))
(mac <hl>with (var-vals . rest)
  (let verify
       (fn (var)
         (if (is (type var) 'sym)
             var
             (err "bootstrapping 'with does not support destructuring")))
    `((<axiom>lambda (,@(map verify:car (pair var-vals)))
        ,@rest)
      ,@(map cadr (pair var-vals)))))
(mac <hl>withs (var-vals . rest)
  (if
    var-vals
      (let (var val . nvars) var-vals
        `(<hl>let ,var ,val
           (<hl>withs ,nvars ,@rest)))
      `((<axiom>lambda () ,@rest))))
(mac <hl>do rest
  `((<axiom>lambda () ,@rest)))
(mac <hl>mac (spec . rest)
  `((<axiom>symeval '<common>call-w/gvl)
    (<axiom>lambda ()
      (<axiom>set ,(car spec)
                  (<axiom>tag '<hl>mac
                    (<axiom>lambda ,(cons '<hl>macro-info (cdr spec))
                      ,@rest))))))

(def <common>call-w/gvl (f) (f))

(in-package hl)
(using <arc>v3)

(mac <hl>def (spec . rest)
  (if
    (acons spec)
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,(car spec)
             ; should really be <hl>fn, but for now we use
             ; <axiom>lambda
             (<axiom>lambda ,(cdr spec)
               ,@rest))))
      `((<axiom>symeval '<common>call-w/gvl)
         (<axiom>lambda ()
           (<axiom>set ,spec
             ,(car rest))))))
(mac <hl>defm (sig . rest)
  (withs (f  (rep <arc>defm)
          rv (apply f (car sig) (cdr sig) rest)
          (set-axiom var (poly-fn types (fn-axiom parms . body) old))
             rv)
    ; NOTE! differences in <arc>polymorph and
    ; <hl>polymorph:
    ;   (<arc>polymorph signature generic specific)
    ;   (<hl>polymorph generic signature specific)
    ; - the change in order was done since we might
    ;   want to overload how overloading of particular
    ;   objects as generics are done
    ; wrap in w/gvl
    `((<axiom>symeval '<common>call-w/gvl)
      (<axiom>lambda ()
        (<axiom>set ,var (<hl>polymorph ,old ,types (<axiom>lambda ,parms ,@body)))))))
; WARNING! limited 'let only, no destructuring
; for bootstrapping purposes only.  Full destructuring
; support will be added in cs/, but cs/ itself can't
; use it.
(mac <hl>let (var val . rest)
  (if (isnt (type var) 'sym)
      (err "bootstrapping 'let does not support destructuring")
      `((<axiom>lambda (,var)
          ,@rest)
        ,val)))
(mac <hl>with (var-vals . rest)
  (let verify
       (fn (var)
         (if (is (type var) 'sym)
             var
             (err "bootstrapping 'with does not support destructuring")))
    `((<axiom>lambda (,@(map verify:car (pair var-vals)))
        ,@rest)
      ,@(map cadr (pair var-vals)))))
(mac <hl>withs (var-vals . rest)
  (if
    var-vals
      (let (var val . nvars) var-vals
        `(<hl>let ,var ,val
           (<hl>withs ,nvars ,@rest)))
      `((<axiom>lambda () ,@rest))))
(mac <hl>do rest
  `((<axiom>lambda () ,@rest)))

(def <common>call-w/gvl (f) (f))


job #10296 fix bug in referential attribute check

.// For each class in the model do the following:
.//   Search for duplicate identifiers in the instance extent.
.//   Match referential attribute values with identifier attribute values.
.//   Find unconditional formalizer from a participant in a simple association.
.//   Find unconditional participant from a formalizer in a simple association.
.//   For an associator in a linked association ensure both ends have an instance.
.//   From the one end of an associative, find the unconditional associator.
.//   From the other end of an associative, find the unconditional associator.
.//   For a subtype, ensure a supertype is present.
.//   For a supertype, ensure exactly one subtype is present.
.//
.// Iterate over the given class.
.function t_class_instance_iteration .// string
  .param string key_letters
  .param string inner_body
  .param string trace_attribute
  .param string name
select many $l{key_letters}s from instances of ${key_letters};
for each $l{key_letters} in $l{key_letters}s
  instance_count = instance_count + 1;
  .if ( "" == trace_attribute )
  trace = "";
  .else
  trace = ::check_trace( trace_attribute:"${trace_attribute}", trace_id:$l{key_letters}.${trace_attribute}, name:\
    .if ( "" == name )
"" );
    .else
$l{key_letters}.${name} );
    .end if
  .end if
${inner_body}
end for;
.end function
.//
.// Ensure no duplicate instance identifiers.
.function t_duplication .// string
  .param string key_letters
  .param string where_clause
  .param integer Numb
  select many duplicate_$l{key_letters}s from instances of ${key_letters} where ( ${where_clause} );
  if ( cardinality duplicate_$l{key_letters}s != 1 )
    ::check_log( message: "uniqueness violation in ${key_letters} for identifier $t{Numb}", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  end if;
  check_count = check_count + 1;
.end function
.//
.// Select across link to required instance.
.function t_participation .// string
  .param string left_side
  .param string right_side
  .param integer Numb
  .param string multiplicity
  .param string phrase
  .param string attribute_comparison
  .assign right = ""
  .if ( "" == phrase )
  select ${multiplicity} $l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}];
  .else
    .if ( left_side == right_side )
      .assign right = "right_"
    .end if
  select ${multiplicity} ${right}$l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}.'${phrase}'];
  .end if
  if ( empty ${right}$l{right_side} )
  .if ( "" != phrase )
    ::check_log( message: "${multiplicity} instance not found ${left_side}->${right_side}[R$t{Numb}.'${phrase}']", trace:trace );
  .else
    ::check_log( message: "${multiplicity} instance not found ${left_side}->${right_side}[R$t{Numb}]", trace:trace );
  .end if
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  .if ( "" != attribute_comparison )
  else
    if ( not ( ${attribute_comparison} ) )
      ::check_log( message: "referentials do not match identifiers between ${left_side} and ${right_side}", trace:trace );
      local_error_count = local_error_count + 1;
      if ( 10 < local_error_count )
        break;
      end if;
    end if;
  .end if
  end if;
  check_count = check_count + 1;
.end function
.//
.// Loop through looking for a subtype.
.function t_supertype_loop .// string
  .param string super
  .param integer Numb
  .param string Loop_Body
  subtype_count = 0;
${Loop_Body}
  if ( subtype_count < 1 )
    ::check_log( message: "subtype not found from ${super} across R$t{Numb}", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  elif ( subtype_count > 1 )
    ::check_log( message: "more than one subtype found from ${super} across R$t{Numb}", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  else
    // nop
  end if;
  check_count = check_count + 1;
.end function
.//
.// Be sure supertype is present.
.function t_sub_to_super .// string
  .param string sub
  .param string super
  .param integer Numb
  select one $l{super} related by $l{sub}->${super}[R$t{Numb}];
  if ( empty $l{super} )
    ::check_log( message: "supertype not found across ${sub}->${super}[R$t{Numb}]", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  else
    select one myself_$l{sub} related by $l{super}->${sub}[R$t{Numb}];
    if ( empty myself_$l{sub} or ( myself_$l{sub} != $l{sub} ) )
      ::check_log( message: "same subtype not found looping back across ${sub}->${super}[R$t{Numb}]->${sub}[R$t{Numb}]", trace:trace );
      local_error_count = local_error_count + 1;
      if ( 10 < local_error_count )
        break;
      end if;
    end if;
  end if;
.end function
.//
.// Look for a particular subtype.
.function t_super_to_sub .// string
  .param string super
  .param string sub
  .param integer Numb
  select one $l{sub} related by $l{super}->${sub}[R$t{Numb}];
  if ( not_empty $l{sub} )
    subtype_count = subtype_count + 1;
  end if;
  check_count = check_count + 1;
.end function
.//
.function instance_uniqueness .// string
  .param inst_ref o_id
  .select one o_obj related by o_id->O_OBJ[R104]
  .assign where_clause = ""
  .assign prefix = ""
  .select many o_oidas related by o_id->O_OIDA[R105]
  .for each o_oida in o_oidas
    .assign clause = "selected." + o_oida.localAttributeName + " == " + $l{o_obj.Key_Lett} + "." + o_oida.localAttributeName
    .assign where_clause = where_clause + prefix + clause
    .assign prefix = " and "
  .end for
  .invoke r = t_duplication( o_obj.Key_Lett, where_clause, o_id.Oid_ID + 1 )
${r.body}
.end function
.//
.function compare_referentials_to_identifiers .// string
  .param string rgo_name
  .param string rto_name
  .param inst_ref r_rgo
  .param inst_ref r_rto
  .//
  .assign where_clause = ""
  .assign null_where_clause = ""
  .assign conjunction = ""
  .assign null_conjunction = ""
  .// Deal with reflexive names.
  .if ( rgo_name == rto_name )
    .assign rto_name = "right_" + rto_name
  .end if
  .select many o_oidas related by r_rto->O_ID[R109]->O_OIDA[R105]
  .for each o_oida in o_oidas
    .// Get the identifying attribute corresponding to this <o_oida> instance.
    .select any o_attr related by o_oida->O_ATTR[R105] where (selected.Attr_ID == o_oida.Attr_ID)
    .select any o_rtida related by r_rto->O_RTIDA[R110] where ((selected.Attr_ID == o_oida.Attr_ID) and ((selected.Obj_ID == o_oida.Obj_ID) and (selected.Oid_ID == o_oida.Oid_ID)))
    .// There can be more than one valid O_REF here, so get _any_ one.
    .// Note:  If MANY <o_rtida>, we need to rip through the (possible) combined referentials,
    .// unlinking any non-constrained elements.
    .select any o_ref related by o_rtida->O_REF[R111] where ( (selected.Obj_ID == r_rgo.Obj_ID) and (selected.OIR_ID == r_rgo.OIR_ID) )
    .// Get the referential attribute corresponding to the current <o_attr>.
    .select one ref_o_attr related by o_ref->O_RATTR[R108]->O_ATTR[R106]
    .select one o_dbattr related by o_attr->O_BATTR[R106]->O_DBATTR[R107]
    .select one s_dt related by ref_o_attr->O_RATTR[R106]->O_BATTR[R113]->O_ATTR[R106]->S_DT[R114] where ( selected.Name == "unique_id" )
    .if ( not_empty s_dt )
      .select many o_refs related by ref_o_attr->O_RATTR[R106]->O_REF[R108]
      .assign n = cardinality o_refs
      .if ( 1 == n )
        .// Do not attempt with combined referential.
        .assign null_clause = "::is_null_id( id:" + rgo_name + "." + ref_o_attr.Name + " )"
        .assign null_where_clause = null_where_clause + null_conjunction + null_clause
        .assign null_conjunction = " and "
      .end if
    .end if
    .assign clause = rto_name + "." + o_oida.localAttributeName + " == " + rgo_name + "." + ref_o_attr.Name
    .assign where_clause = where_clause + conjunction + clause
    .assign conjunction = " and "
  .end for
  .assign attr_null_where_clause = null_where_clause
${where_clause}\
.end function
.//
.function participant_participation .// string
  .param inst_ref o_obj
  .select many r_parts related by o_obj->R_OIR[R201]->R_RTO[R203]->R_PART[R204]
  .for each r_part in r_parts
    .select one r_simp related by r_part->R_SIMP[R207]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_form related by r_simp->R_FORM[R208]
      .if ( not_empty r_form )
        .if ( not r_form.Cond )
          .select one r_rgo related by r_form->R_RGO[R205]
          .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
          .assign card = "one"
          .if ( r_form.Mult )
            .assign card = "any"
          .end if
          .assign phrase = ""
          .if ( r_part.Obj_ID == r_form.Obj_ID )
            .assign phrase = r_form.Txt_Phrs
          .end if
          .select one r_rto related by r_part->R_RTO[R204]
          .invoke r = compare_referentials_to_identifiers( $l{target_o_obj.Key_Lett}, $l{o_obj.Key_Lett}, r_rgo, r_rto )
          .assign comparison = r.body
          .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // participant participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
        .end if
      .else
  // unformalized association R$t{r_rel.Numb}
      .end if
    .end if
  .end for
.end function
.//
.function formalizer_participation .// string
  .param inst_ref o_obj
  .select many r_forms related by o_obj->R_OIR[R201]->R_RGO[R203]->R_FORM[R205]
  .for each r_form in r_forms
    .select one r_simp related by r_form->R_SIMP[R208]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_part related by r_simp->R_PART[R207]
      .select one r_rto related by r_part->R_RTO[R204]
      .select one target_o_obj related by r_rto->R_OIR[R203]->O_OBJ[R201]
      .assign card = "one"
      .if ( r_part.Mult )
        .assign card = "any"
      .end if
      .assign phrase = ""
      .if ( r_part.Obj_ID == r_form.Obj_ID )
        .assign phrase = r_part.Txt_Phrs
      .end if
      .select one r_rgo related by r_form->R_RGO[R205]
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
      .assign comparison = r.body
      .assign null_where_clause = r.null_where_clause
      .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // formalizer participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
      .if ( r_part.Cond and ( "" != null_where_clause ) )
  // checking conditional link only if referential attribute is non-null
  if ( not ( ${null_where_clause} ) )
      .end if
      .if ( ( not r_part.Cond ) or ( "" != null_where_clause ) )
${r.body}
      .end if
      .if ( r_part.Cond and ( "" != null_where_clause ) )
  end if;
      .end if
    .end if
  .end for
.end function
.//
.function associator_participation .// string
  .param inst_ref o_obj
  .select many r_assrs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_ASSR[R205]
  .for each r_assr in r_assrs
    .select one r_assoc related by r_assr->R_ASSOC[R211]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .select one aone_r_rto related by r_aone->R_RTO[R204]
      .select one aone_o_obj related by aone_r_rto->R_OIR[R203]->O_OBJ[R201]
      .select one aoth_r_rto related by r_aoth->R_RTO[R204]
      .select one aoth_o_obj related by aoth_r_rto->R_OIR[R203]->O_OBJ[R201]
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aone.Txt_Phrs
      .end if
      .select one r_rgo related by r_assr->R_RGO[R205]
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aone_o_obj.Key_Lett}, r_rgo, aone_r_rto )
      .assign comparison = r.body
      .assign null_where_clause = r.null_where_clause
      .invoke r = t_participation( o_obj.Key_Lett, aone_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator one participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aone_o_obj.Name}(${aone_o_obj.Key_Lett})
      .if ( r_aone.Cond and ( "" != null_where_clause ) )
  // checking conditional link only if referential attribute is non-null
  if ( not ( ${null_where_clause} ) )
      .end if
      .if ( ( not r_aone.Cond ) or ( "" != null_where_clause ) )
${r.body}
      .end if
      .if ( r_aone.Cond and ( "" != null_where_clause ) )
  end if;
      .end if
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aoth.Txt_Phrs
      .end if
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aoth_o_obj.Key_Lett}, r_rgo, aoth_r_rto )
      .assign comparison = r.body
      .assign null_where_clause = r.null_where_clause
      .invoke r = t_participation( o_obj.Key_Lett, aoth_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator other participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aoth_o_obj.Name}(${aoth_o_obj.Key_Lett})
      .if ( r_aoth.Cond and ( "" != null_where_clause ) )
  // checking conditional link only if referential attribute is non-null
  if ( not ( ${null_where_clause} ) )
      .end if
      .if ( ( not r_aone.Cond ) or ( "" != null_where_clause ) )
${r.body}
      .end if
      .if ( r_aoth.Cond and ( "" != null_where_clause ) )
  end if;
      .end if
    .end if
  .end for
.end function
.//
.function aone_participation .// string
  .param inst_ref o_obj
  .select many r_aones related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AONE[R204]
  .for each r_aone in r_aones
    .select one r_assoc related by r_aone->R_ASSOC[R209]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .if ( not r_aoth.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aoth.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aoth.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aone->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{target_o_obj.Key_Lett}, $l{o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aone participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function aoth_participation .// string
  .param inst_ref o_obj
  .select many r_aoths related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AOTH[R204]
  .for each r_aoth in r_aoths
    .select one r_assoc related by r_aoth->R_ASSOC[R210]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .if ( not r_aone.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aone.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aone.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aoth->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{target_o_obj.Key_Lett}, $l{o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aoth participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function supertype_participation .// string
  .param inst_ref o_obj
  .select many r_supers related by o_obj->R_OIR[R201]->R_RTO[R203]->R_SUPER[R204]
  .for each r_super in r_supers
    .assign loop_body = ""
    .select one r_subsup related by r_super->R_SUBSUP[R212]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select many r_subs related by r_subsup->R_SUB[R213]
      .for each r_sub in r_subs
        .select one source_o_obj related by r_sub->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
        .invoke r = t_super_to_sub( o_obj.Key_Lett, source_o_obj.Key_Lett, r_rel.Numb )
        .assign loop_body = loop_body + r.body
      .end for
      .invoke r = t_supertype_loop( o_obj.Key_Lett, r_rel.Numb, loop_body )
  // super to sub participation R$t{r_rel.Numb}:  supertype ${o_obj.Name}(${o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.function subtype_participation .// string
  .param inst_ref o_obj
  .select many r_subs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_SUB[R205]
  .for each r_sub in r_subs
    .select one r_subsup related by r_sub->R_SUBSUP[R213]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one target_o_obj related by r_subsup->R_SUPER[R212]->R_RTO[R204]->R_OIR[R203]->O_OBJ[R201]
      .invoke r = t_sub_to_super( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb )
  // sub to super participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
      .if ( "EP_PKG" == o_obj.Key_Lett )
  if ( 0 == T::idtoi( id:ep_pkg.Sys_ID ) )
  // Look for supertype PE_PE only if not a top-level package (connected to System).
      .end if
${r.body}
      .if ( "EP_PKG" == o_obj.Key_Lett )
  end if;
      .end if
    .end if
  .end for
.end function
.//
.// Return true if the element exists (nested) in the given package name.
.function in_ep_pkg .// boolean
  .param inst_ref ep_pkg
  .param string ep_pkg_Name
  .assign inpkg = false
  .if ( not_empty ep_pkg )
    .if ( ep_pkg_Name == ep_pkg.Name )
      .assign inpkg = true
    .else
      .select one ep_pkg related by ep_pkg->PE_PE[R8001]->EP_PKG[R8000]
      .invoke r = in_ep_pkg( ep_pkg, ep_pkg_Name )
      .assign inpkg = r.result
    .end if
  .end if
  .assign attr_result = inpkg
.end function
.//
.function generate_actions .// string
// For each class in the model do the following:
//   Search for duplicate identifiers in the instance extent.
//   Find unconditional formalizer from a participant in a simple association.
//   Find unconditional participant from a formalizer in a simple association.
//   For an associator in a linked association ensure both ends have an instance.
//   For the one end of an associative, find the unconditional associator.
//   For the other end of an associative, find the unconditional associator.
//   For a subtype, be sure a supertype is present.
//   For a supertype, be sure exactly one subtype is present.
// Show only the first violation of any particular rule in each extent.
instance_count = 0;
check_count = 0;
total_error_count = 0;
subtype_count = 0;
trace = "";
  .// Sort the classes by class number for consistent generation (smaller change sets).
  .assign n = 0
  .while ( n <= 9999 )
  .assign n = n + 1
  .select many o_objs from instances of O_OBJ where ( selected.Numb == n )
  .for each o_obj in o_objs
    .assign trace_attribute = ""
    .assign name = ""
    .select one ep_pkg related by o_obj->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .assign text = ""
      .select many o_ids related by o_obj->O_ID[R104]
      .for each o_id in o_ids
        .select one o_oida related by o_id->O_OIDA[R105]
        .if ( not_empty o_oida )
          .invoke r = instance_uniqueness( o_id )
          .assign text = text + r.body
          .// Find an identifying attribute to use to provide the user some way
          .// to locate the erroneous element.
          .select one s_dt related by o_oida->O_ATTR[R105]->S_DT[R114] where ( selected.Name == "unique_id" )
          .if ( not_empty s_dt )
            .assign trace_attribute = o_oida.localAttributeName
          .else
            .select one s_dt related by o_oida->O_ATTR[R105]->O_RATTR[R106]->O_BATTR[R113]->O_ATTR[R106]->S_DT[R114] where ( selected.Name == "unique_id" )
            .if ( not_empty s_dt )
              .assign trace_attribute = o_oida.localAttributeName
            .end if
          .end if
        .end if
      .end for
      .// If class has an attribute named "Name", use it for tracing purposes.
      .select any o_attr related by o_obj->O_ATTR[R102] where ( selected.Root_Nam == "Name" )
      .if ( not_empty o_attr )
        .assign name = o_attr.Root_Nam
      .end if
      .// participant
      .invoke r = participant_participation( o_obj )
      .assign text = text + r.body
      .// formalizer
      .invoke r = formalizer_participation( o_obj )
      .assign text = text + r.body
      .// associator
      .invoke r = associator_participation( o_obj )
      .assign text = text + r.body
      .// aone
      .invoke r = aone_participation( o_obj )
      .assign text = text + r.body
      .// aoth
      .invoke r = aoth_participation( o_obj )
      .assign text = text + r.body
      .// subtype
      .invoke r = subtype_participation( o_obj )
      .assign text = text + r.body
      .// supertype
      .invoke r = supertype_participation( o_obj )
      .assign text = text + r.body
      .// iterate
      .invoke r = t_class_instance_iteration( o_obj.Key_Lett, text, trace_attribute, name )
local_error_count = 0;
${r.body}
total_error_count = total_error_count + local_error_count;
    .end if
  .end for
  .end while
::check_log_integer( message:"instances checked:  ", i:instance_count );
::check_log_integer( message:"checks made:  ", i:check_count );
::check_log_integer( message:"errors found:  ", i:total_error_count );
  .//
.end function
.//
.function ooaofooa_check_referential_integrity .// string
  .invoke r = generate_actions()
${r.body}
.end function
.//
.invoke r = ooaofooa_check_referential_integrity()
${r.body}
.emit to file "../ooa.txt"

.// For each class in the model do the following:
.//   Search for duplicate identifiers in the instance extent.
.//   Match referential attribute values with identifier attribute values.
.//   Find unconditional formalizer from a participant in a simple association.
.//   Find unconditional participant from a formalizer in a simple association.
.//   For an associator in a linked association ensure both ends have an instance.
.//   From the one end of an associative, find the unconditional associator.
.//   From the other end of an associative, find the unconditional associator.
.//   For a subtype, ensure a supertype is present.
.//   For a supertype, ensure exactly one subtype is present.
.//
.// Iterate over the given class.
.function t_class_instance_iteration .// string
  .param string key_letters
  .param string inner_body
  .param string trace_attribute
  .param string name
select many $l{key_letters}s from instances of ${key_letters};
for each $l{key_letters} in $l{key_letters}s
  instance_count = instance_count + 1;
  .if ( "" == trace_attribute )
  trace = "";
  .else
  trace = ::check_trace( trace_attribute:"${trace_attribute}", trace_id:$l{key_letters}.${trace_attribute}, name:\
    .if ( "" == name )
"" );
    .else
$l{key_letters}.${name} );
    .end if
  .end if
${inner_body}
end for;
.end function
.//
.// Ensure no duplicate instance identifiers.
.function t_duplication .// string
  .param string key_letters
  .param string where_clause
  .param integer Numb
  select many duplicate_$l{key_letters}s from instances of ${key_letters} where ( ${where_clause} );
  if ( cardinality duplicate_$l{key_letters}s != 1 )
    ::check_log( message: "uniqueness violation in ${key_letters} for identifier $t{Numb}", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  end if;
  check_count = check_count + 1;
.end function
.//
.// Select across link to required instance.
.function t_participation .// string
  .param string left_side
  .param string right_side
  .param integer Numb
  .param string multiplicity
  .param string phrase
  .param string attribute_comparison
  .assign right = ""
  .if ( "" == phrase )
  select ${multiplicity} $l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}];
  .else
    .if ( left_side == right_side )
      .assign right = "right_"
    .end if
  select ${multiplicity} ${right}$l{right_side} related by $l{left_side}->${right_side}[R$t{Numb}.'${phrase}'];
  .end if
  if ( empty ${right}$l{right_side} )
  .if ( "" != phrase )
    ::check_log( message: "${multiplicity} instance not found ${left_side}->${right_side}[R$t{Numb}.'${phrase}']", trace:trace );
  .else
    ::check_log( message: "${multiplicity} instance not found ${left_side}->${right_side}[R$t{Numb}]", trace:trace );
  .end if
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  .if ( "" != attribute_comparison )
  else
    if ( not ( ${attribute_comparison} ) )
      ::check_log( message: "referentials do not match identifiers between ${left_side} and ${right_side}", trace:trace );
      local_error_count = local_error_count + 1;
      if ( 10 < local_error_count )
        break;
      end if;
    end if;
  .end if
  end if;
  check_count = check_count + 1;
.end function
.//
.// Loop through looking for a subtype.
.function t_supertype_loop .// string
  .param string super
  .param integer Numb
  .param string Loop_Body
  subtype_count = 0;
${Loop_Body}
  if ( subtype_count < 1 )
    ::check_log( message: "subtype not found from ${super} across R$t{Numb}", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  elif ( subtype_count > 1 )
    ::check_log( message: "more than one subtype found from ${super} across R$t{Numb}", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  else
    // nop
  end if;
  check_count = check_count + 1;
.end function
.//
.// Be sure supertype is present.
.function t_sub_to_super .// string
  .param string sub
  .param string super
  .param integer Numb
  select one $l{super} related by $l{sub}->${super}[R$t{Numb}];
  if ( empty $l{super} )
    ::check_log( message: "supertype not found across ${sub}->${super}[R$t{Numb}]", trace:trace );
    local_error_count = local_error_count + 1;
    if ( 10 < local_error_count )
      break;
    end if;
  else
    select one myself_$l{sub} related by $l{super}->${sub}[R$t{Numb}];
    if ( empty myself_$l{sub} or ( myself_$l{sub} != $l{sub} ) )
      ::check_log( message: "same subtype not found looping back across ${sub}->${super}[R$t{Numb}]->${sub}[R$t{Numb}]", trace:trace );
      local_error_count = local_error_count + 1;
      if ( 10 < local_error_count )
        break;
      end if;
    end if;
  end if;
.end function
.//
.// Look for a particular subtype.
.function t_super_to_sub .// string
  .param string super
  .param string sub
  .param integer Numb
  select one $l{sub} related by $l{super}->${sub}[R$t{Numb}];
  if ( not_empty $l{sub} )
    subtype_count = subtype_count + 1;
  end if;
  check_count = check_count + 1;
.end function
.//
.function instance_uniqueness .// string
  .param inst_ref o_id
  .select one o_obj related by o_id->O_OBJ[R104]
  .assign where_clause = ""
  .assign prefix = ""
  .select many o_oidas related by o_id->O_OIDA[R105]
  .for each o_oida in o_oidas
    .assign clause = "selected." + o_oida.localAttributeName + " == " + $l{o_obj.Key_Lett} + "." + o_oida.localAttributeName
    .assign where_clause = where_clause + prefix + clause
    .assign prefix = " and "
  .end for
  .invoke r = t_duplication( o_obj.Key_Lett, where_clause, o_id.Oid_ID + 1 )
${r.body}
.end function
.//
.function compare_referentials_to_identifiers .// string
  .param string rgo_name
  .param string rto_name
  .param inst_ref r_rgo
  .param inst_ref r_rto
  .//
  .assign where_clause = ""
  .assign null_where_clause = ""
  .assign conjunction = ""
  .assign null_conjunction = ""
  .// Deal with reflexive names.
  .if ( rgo_name == rto_name )
    .assign rto_name = "right_" + rto_name
  .end if
  .select many o_oidas related by r_rto->O_ID[R109]->O_OIDA[R105]
  .for each o_oida in o_oidas
    .// Get the identifying attribute corresponding to this <o_oida> instance.
    .select any o_attr related by o_oida->O_ATTR[R105] where (selected.Attr_ID == o_oida.Attr_ID)
    .select any o_rtida related by r_rto->O_RTIDA[R110] where ((selected.Attr_ID == o_oida.Attr_ID) and ((selected.Obj_ID == o_oida.Obj_ID) and (selected.Oid_ID == o_oida.Oid_ID)))
    .// There can be more than one valid O_REF here, so get _any_ one.
    .// Note:  If MANY <o_rtida>, we need to rip through the (possible) combined referentials,
    .// unlinking any non-constrained elements.
    .select any o_ref related by o_rtida->O_REF[R111] where ( (selected.Obj_ID == r_rgo.Obj_ID) and (selected.OIR_ID == r_rgo.OIR_ID) )
    .// Get the referential attribute corresponding to the current <o_attr>.
    .select one ref_o_attr related by o_ref->O_RATTR[R108]->O_ATTR[R106]
    .select one o_dbattr related by o_attr->O_BATTR[R106]->O_DBATTR[R107]
    .select one s_dt related by ref_o_attr->O_RATTR[R106]->O_BATTR[R113]->O_ATTR[R106]->S_DT[R114] where ( selected.Name == "unique_id" )
    .if ( not_empty s_dt )
      .select many o_refs related by ref_o_attr->O_RATTR[R106]->O_REF[R108]
      .assign n = cardinality o_refs
      .if ( 1 == n )
        .// Do not attempt with combined referential.
        .assign null_clause = "::is_null_id( id:" + rgo_name + "." + ref_o_attr.Name + " )"
        .assign null_where_clause = null_where_clause + null_conjunction + null_clause
        .assign null_conjunction = " and "
      .end if
    .end if
    .assign clause = rto_name + "." + o_oida.localAttributeName + " == " + rgo_name + "." + ref_o_attr.Name
    .assign where_clause = where_clause + conjunction + clause
    .assign conjunction = " and "
  .end for
  .assign attr_null_where_clause = null_where_clause
${where_clause}\
.end function
.//
.function participant_participation .// string
  .param inst_ref o_obj
  .select many r_parts related by o_obj->R_OIR[R201]->R_RTO[R203]->R_PART[R204]
  .for each r_part in r_parts
    .select one r_simp related by r_part->R_SIMP[R207]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_form related by r_simp->R_FORM[R208]
      .if ( not_empty r_form )
        .if ( not r_form.Cond )
          .select one r_rgo related by r_form->R_RGO[R205]
          .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
          .assign card = "one"
          .if ( r_form.Mult )
            .assign card = "any"
          .end if
          .assign phrase = ""
          .if ( r_part.Obj_ID == r_form.Obj_ID )
            .assign phrase = r_form.Txt_Phrs
          .end if
          .select one r_rto related by r_part->R_RTO[R204]
          .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
          .assign comparison = r.body
          .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // participant participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
        .end if
      .else
  // unformalized association R$t{r_rel.Numb}
      .end if
    .end if
  .end for
.end function
.//
.function formalizer_participation .// string
  .param inst_ref o_obj
  .select many r_forms related by o_obj->R_OIR[R201]->R_RGO[R203]->R_FORM[R205]
  .for each r_form in r_forms
    .select one r_simp related by r_form->R_SIMP[R208]
    .select one r_rel related by r_simp->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_part related by r_simp->R_PART[R207]
      .select one r_rto related by r_part->R_RTO[R204]
      .select one target_o_obj related by r_rto->R_OIR[R203]->O_OBJ[R201]
      .assign card = "one"
      .if ( r_part.Mult )
        .assign card = "any"
      .end if
      .assign phrase = ""
      .if ( r_part.Obj_ID == r_form.Obj_ID )
        .assign phrase = r_part.Txt_Phrs
      .end if
      .select one r_rgo related by r_form->R_RGO[R205]
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{target_o_obj.Key_Lett}, r_rgo, r_rto )
      .assign comparison = r.body
      .assign null_where_clause = r.null_where_clause
      .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // formalizer participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
      .if ( r_part.Cond and ( "" != null_where_clause ) )
  // checking conditional link only if referential attribute is non-null
  if ( not ( ${null_where_clause} ) )
      .end if
      .if ( ( not r_part.Cond ) or ( "" != null_where_clause ) )
${r.body}
      .end if
      .if ( r_part.Cond and ( "" != null_where_clause ) )
  end if;
      .end if
    .end if
  .end for
.end function
.//
.function associator_participation .// string
  .param inst_ref o_obj
  .select many r_assrs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_ASSR[R205]
  .for each r_assr in r_assrs
    .select one r_assoc related by r_assr->R_ASSOC[R211]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .select one aone_r_rto related by r_aone->R_RTO[R204]
      .select one aone_o_obj related by aone_r_rto->R_OIR[R203]->O_OBJ[R201]
      .select one aoth_r_rto related by r_aoth->R_RTO[R204]
      .select one aoth_o_obj related by aoth_r_rto->R_OIR[R203]->O_OBJ[R201]
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aone.Txt_Phrs
      .end if
      .select one r_rgo related by r_assr->R_RGO[R205]
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aone_o_obj.Key_Lett}, r_rgo, aone_r_rto )
      .assign comparison = r.body
      .assign null_where_clause = r.null_where_clause
      .invoke r = t_participation( o_obj.Key_Lett, aone_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator one participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aone_o_obj.Name}(${aone_o_obj.Key_Lett})
      .if ( r_aone.Cond and ( "" != null_where_clause ) )
  // checking conditional link only if referential attribute is non-null
  if ( not ( ${null_where_clause} ) )
      .end if
      .if ( ( not r_aone.Cond ) or ( "" != null_where_clause ) )
${r.body}
      .end if
      .if ( r_aone.Cond and ( "" != null_where_clause ) )
  end if;
      .end if
      .assign phrase = ""
      .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
        .assign phrase = r_aoth.Txt_Phrs
      .end if
      .invoke r = compare_referentials_to_identifiers( $l{o_obj.Key_Lett}, $l{aoth_o_obj.Key_Lett}, r_rgo, aoth_r_rto )
      .assign comparison = r.body
      .assign null_where_clause = r.null_where_clause
      .invoke r = t_participation( o_obj.Key_Lett, aoth_o_obj.Key_Lett, r_rel.Numb, "one", phrase, comparison )
  // associator other participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${aoth_o_obj.Name}(${aoth_o_obj.Key_Lett})
      .if ( r_aoth.Cond and ( "" != null_where_clause ) )
  // checking conditional link only if referential attribute is non-null
  if ( not ( ${null_where_clause} ) )
      .end if
      .if ( ( not r_aone.Cond ) or ( "" != null_where_clause ) )
${r.body}
      .end if
      .if ( r_aoth.Cond and ( "" != null_where_clause ) )
  end if;
      .end if
    .end if
  .end for
.end function
.//
.function aone_participation .// string
  .param inst_ref o_obj
  .select many r_aones related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AONE[R204]
  .for each r_aone in r_aones
    .select one r_assoc related by r_aone->R_ASSOC[R209]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aoth related by r_assoc->R_AOTH[R210]
      .if ( not r_aoth.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aoth.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aoth.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aone->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{target_o_obj.Key_Lett}, $l{o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aone participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function aoth_participation .// string
  .param inst_ref o_obj
  .select many r_aoths related by o_obj->R_OIR[R201]->R_RTO[R203]->R_AOTH[R204]
  .for each r_aoth in r_aoths
    .select one r_assoc related by r_aoth->R_ASSOC[R210]
    .select one r_rel related by r_assoc->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one r_aone related by r_assoc->R_AONE[R209]
      .if ( not r_aone.Cond )
        .select one r_rgo related by r_assoc->R_ASSR[R211]->R_RGO[R205]
        .select one target_o_obj related by r_rgo->R_OIR[R203]->O_OBJ[R201]
        .assign phrase = ""
        .if ( r_aone.Obj_ID == r_aoth.Obj_ID )
          .assign phrase = r_aone.Txt_Phrs
        .end if
        .assign card = "one"
        .if ( r_aone.Mult )
          .assign card = "any"
        .end if
        .select one r_rto related by r_aoth->R_RTO[R204]
        .invoke r = compare_referentials_to_identifiers( $l{target_o_obj.Key_Lett}, $l{o_obj.Key_Lett}, r_rgo, r_rto )
        .assign comparison = r.body
        .invoke r = t_participation( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb, card, phrase, comparison )
  // aoth participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
${r.body}
      .end if
    .end if
  .end for
.end function
.//
.function supertype_participation .// string
  .param inst_ref o_obj
  .select many r_supers related by o_obj->R_OIR[R201]->R_RTO[R203]->R_SUPER[R204]
  .for each r_super in r_supers
    .assign loop_body = ""
    .select one r_subsup related by r_super->R_SUBSUP[R212]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select many r_subs related by r_subsup->R_SUB[R213]
      .for each r_sub in r_subs
        .select one source_o_obj related by r_sub->R_RGO[R205]->R_OIR[R203]->O_OBJ[R201]
        .invoke r = t_super_to_sub( o_obj.Key_Lett, source_o_obj.Key_Lett, r_rel.Numb )
        .assign loop_body = loop_body + r.body
      .end for
      .invoke r = t_supertype_loop( o_obj.Key_Lett, r_rel.Numb, loop_body )
  // super to sub participation R$t{r_rel.Numb}:  supertype ${o_obj.Name}(${o_obj.Key_Lett})
${r.body}
    .end if
  .end for
.end function
.//
.function subtype_participation .// string
  .param inst_ref o_obj
  .select many r_subs related by o_obj->R_OIR[R201]->R_RGO[R203]->R_SUB[R205]
  .for each r_sub in r_subs
    .select one r_subsup related by r_sub->R_SUBSUP[R213]
    .select one r_rel related by r_subsup->R_REL[R206]
    .select one ep_pkg related by r_rel->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .select one target_o_obj related by r_subsup->R_SUPER[R212]->R_RTO[R204]->R_OIR[R203]->O_OBJ[R201]
      .invoke r = t_sub_to_super( o_obj.Key_Lett, target_o_obj.Key_Lett, r_rel.Numb )
  // sub to super participation R$t{r_rel.Numb}:  ${o_obj.Name}(${o_obj.Key_Lett}) -> ${target_o_obj.Name}(${target_o_obj.Key_Lett})
      .if ( "EP_PKG" == o_obj.Key_Lett )
  if ( 0 == T::idtoi( id:ep_pkg.Sys_ID ) )
  // Look for supertype PE_PE only if not a top-level package (connected to System).
      .end if
${r.body}
      .if ( "EP_PKG" == o_obj.Key_Lett )
  end if;
      .end if
    .end if
  .end for
.end function
.//
.// Return true if the element exists (nested) in the given package name.
.function in_ep_pkg .// boolean
  .param inst_ref ep_pkg
  .param string ep_pkg_Name
  .assign inpkg = false
  .if ( not_empty ep_pkg )
    .if ( ep_pkg_Name == ep_pkg.Name )
      .assign inpkg = true
    .else
      .select one ep_pkg related by ep_pkg->PE_PE[R8001]->EP_PKG[R8000]
      .invoke r = in_ep_pkg( ep_pkg, ep_pkg_Name )
      .assign inpkg = r.result
    .end if
  .end if
  .assign attr_result = inpkg
.end function
.//
.function generate_actions .// string
// For each class in the model do the following:
//   Search for duplicate identifiers in the instance extent.
//   Find unconditional formalizer from a participant in a simple association.
//   Find unconditional participant from a formalizer in a simple association.
//   For an associator in a linked association ensure both ends have an instance.
//   For the one end of an associative, find the unconditional associator.
//   For the other end of an associative, find the unconditional associator.
//   For a subtype, be sure a supertype is present.
//   For a supertype, be sure exactly one subtype is present.
// Show only the first violation of any particular rule in each extent.
instance_count = 0;
check_count = 0;
total_error_count = 0;
subtype_count = 0;
trace = "";
  .// Sort the classes by class number for consistent generation (smaller change sets).
  .assign n = 0
  .while ( n <= 9999 )
  .assign n = n + 1
  .select many o_objs from instances of O_OBJ where ( selected.Numb == n )
  .for each o_obj in o_objs
    .assign trace_attribute = ""
    .assign name = ""
    .select one ep_pkg related by o_obj->PE_PE[R8001]->EP_PKG[R8000]
    .invoke r = in_ep_pkg( ep_pkg, "ooaofooa" )
    .if ( r.result )
      .assign text = ""
      .select many o_ids related by o_obj->O_ID[R104]
      .for each o_id in o_ids
        .select one o_oida related by o_id->O_OIDA[R105]
        .if ( not_empty o_oida )
          .invoke r = instance_uniqueness( o_id )
          .assign text = text + r.body
          .// Find an identifying attribute to use to provide the user some way
          .// to locate the erroneous element.
          .select one s_dt related by o_oida->O_ATTR[R105]->S_DT[R114] where ( selected.Name == "unique_id" )
          .if ( not_empty s_dt )
            .assign trace_attribute = o_oida.localAttributeName
          .else
            .select one s_dt related by o_oida->O_ATTR[R105]->O_RATTR[R106]->O_BATTR[R113]->O_ATTR[R106]->S_DT[R114] where ( selected.Name == "unique_id" )
            .if ( not_empty s_dt )
              .assign trace_attribute = o_oida.localAttributeName
            .end if
          .end if
        .end if
      .end for
      .// If class has an attribute named "Name", use it for tracing purposes.
      .select any o_attr related by o_obj->O_ATTR[R102] where ( selected.Root_Nam == "Name" )
      .if ( not_empty o_attr )
        .assign name = o_attr.Root_Nam
      .end if
      .// participant
      .invoke r = participant_participation( o_obj )
      .assign text = text + r.body
      .// formalizer
      .invoke r = formalizer_participation( o_obj )
      .assign text = text + r.body
      .// associator
      .invoke r = associator_participation( o_obj )
      .assign text = text + r.body
      .// aone
      .invoke r = aone_participation( o_obj )
      .assign text = text + r.body
      .// aoth
      .invoke r = aoth_participation( o_obj )
      .assign text = text + r.body
      .// subtype
      .invoke r = subtype_participation( o_obj )
      .assign text = text + r.body
      .// supertype
      .invoke r = supertype_participation( o_obj )
      .assign text = text + r.body
      .// iterate
      .invoke r = t_class_instance_iteration( o_obj.Key_Lett, text, trace_attribute, name )
local_error_count = 0;
${r.body}
total_error_count = total_error_count + local_error_count;
    .end if
  .end for
  .end while
::check_log_integer( message:"instances checked:  ", i:instance_count );
::check_log_integer( message:"checks made:  ", i:check_count );
::check_log_integer( message:"errors found:  ", i:total_error_count );
  .//
.end function
.//
.function ooaofooa_check_referential_integrity .// string
  .invoke r = generate_actions()
${r.body}
.end function
.//
.invoke r = ooaofooa_check_referential_integrity()
${r.body}
.emit to file "../ooa.txt"