m.stangl
9e3e8e16ae
TEST_LINIENZUG (ebenso hmrec:stubs-aus und vsp-headless-aus) schaltete die GUI am Ende pauschal wieder ein. Unter SSG_RUN_ALL_TESTS fragte der direkt folgende EXPORTSIVAS dann nach Hoehen-Check/Bereinigen und der Lauf blieb stehen. Alle drei stellen jetzt den Vorzustand von *ssg-gui-aus* wieder her. SSG_RUN_ALL_TESTS schaltet zusaetzlich *csv-hoehencheck-fragen* und *csv-bereinigen-vor-export* fuer den Lauf ab (unmittelbar vor jedem Export erneut, export.lsp belegt nil beim Nachladen wieder mit T), erzwingt GUI aus mit Warnung und stellt am Ende die Vorgaben wieder her. Neues Laufprotokoll DXFM_LOG/testlauf_<name>.dbg je Test (Debug-Schalter "testlauf", Standard ein): Zustand vor/nach dem Test, Fehler, Ergebnis-JSON, Export-Schritte. Eigene Datei mit sofortigem Schreiben statt dbgopen, damit die Module mit ihren eigenen .dbg-Dateien es nicht umlenken und bei einem Haenger der letzte Schritt sichtbar ist. Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
694 lines
30 KiB
Common Lisp
694 lines
30 KiB
Common Lisp
;; ============================================================
|
|
;; test_hm_recformat.lsp - Regressionstest fuer das AUFZEICHNUNGSFORMAT
|
|
;; (rec = recorded): baut die 5 VarioFoerderer-Linienzuege der Anlage HundM
|
|
;; aus den Journalen nach, die in der Kundenzeichnung stehen.
|
|
;;
|
|
;; ABGRENZUNG zu TEST_HUNDM05 (tests/test_hundm05.lsp): dort werden dieselben
|
|
;; 5 Ketten aus einer SPEC gebaut (tests/testdata/hundm05.json, das neue
|
|
;; Eingabeformat) - das ist der Test fuer den Bau-Pfad und der, der
|
|
;; routinemaessig laeuft. HIER geht es um etwas anderes: das Journal kommt
|
|
;; roh aus der XDATA einer echten Zeichnung. Damit ist dies der einzige Test,
|
|
;; der belegt, dass ein BESTEHENDER VF_n-Block weiter abspielbar bleibt -
|
|
;; also dass Doppelklick-Editieren und 2D/3D-Konvertierung an Altbestand
|
|
;; funktionieren (Invariante I1 in doc/todo/plan-vf-interactive.md). Ein
|
|
;; spec-gebautes Journal kann das nicht zeigen, es kommt aus dem Uebersetzer.
|
|
;;
|
|
;; Darum in tests/alltests.json auf "disabled": true - er baut dieselbe
|
|
;; Geometrie wie TEST_HUNDM05 und kostet doppelte CAD-Zeit. Bei Aenderungen
|
|
;; am Journal-Format, an den vfl-in-*-Wrappern oder am XDATA-Layout aber
|
|
;; bewusst einschalten: dann ist er der Test, der zaehlt.
|
|
;;
|
|
;; Datenquelle: tests/testdata/hm_recformat.json, erzeugt von
|
|
;; python lib/vf_journal_export.py data/polylines.dxf \
|
|
;; tests/testdata/hm_recformat.json --csv results/HundM_export.csv
|
|
;; Das sind die EINGABE-JOURNALE der echten Ketten - ausgelesen aus der XDATA
|
|
;; (App SSG_VF_EDIT, Marker "linienzug") der VF_n-Bloecke in data/polylines.dxf,
|
|
;; also genau die Werte, mit denen die Ketten in BricsCAD gebaut wurden.
|
|
;;
|
|
;; JSON-Aufbau (FLACH, weil ssg-load-json zeilenweise liest - Details in
|
|
;; doc/json-input-lisp.md Abschnitt 6):
|
|
;; Kopf-Objekt (traegt "test_id"): test_id, anlagetyp, modus,
|
|
;; anzahl_eingaben, block, dxf_handle, startpunkt_mm,
|
|
;; rotation_grad, beschreibung, sivas_* , erwartung_hinweis
|
|
;; Eingabe-Objekt (traegt "typ"): point_abs | point_rel | real | int |
|
|
;; string | step | nil - in exakter Frage-Reihenfolge
|
|
;; ("nil" = Frage gestellt und bewusst uebergangen, z.B.
|
|
;; keine Zufuehrungsachse gewaehlt)
|
|
;; Ein Kopf-Objekt beginnt eine Kette, die folgenden Eingabe-Objekte gehoeren
|
|
;; dazu (hmrec:gruppiere).
|
|
;;
|
|
;; WARUM REPLAY UND KEINE EINGABE-MOCKS (Unterschied zu test_linienzug.lsp):
|
|
;; test_linienzug.lsp ersetzt getpoint/getstring/getint/getreal durch Mocks und
|
|
;; rechnet Punkte aus "dL"+"hz" selbst aus. Das geht nur, weil
|
|
;; linienzug_tests.json zu JEDEM Segment ein "hz" mitfuehrt. Ein echtes Journal
|
|
;; tut das nicht: vfl-in-abstand journalisiert die Fahrtrichtung NUR beim
|
|
;; allerersten Segment der Kette, jedes weitere erbt sie vom Vorgaenger. Ein
|
|
;; Mock kann diese geerbte Richtung nicht kennen - er wuerde einen Punkt in der
|
|
;; falschen Richtung liefern und die Projektion in vfl-neue-linie-messen ergaebe
|
|
;; eine falsche (bis auf 0 zusammenfallende) Laenge. Darum wird hier derselbe
|
|
;; Weg genommen, den die Produktion beim Editieren/Konvertieren nutzt:
|
|
;; vfl-journal-replay-start + vf-linienzug-modus (siehe vfl-konvertiere-ent in
|
|
;; Lisp/vf_linienzug.lsp). Die vfl-in-*-Wrapper ziehen ihre Werte dann direkt
|
|
;; aus der Replay-Queue - inklusive der Sonderregel fuer "hz".
|
|
;;
|
|
;; Voraussetzungen:
|
|
;; - SSG_LIB geladen (VarioFoerderer inkl. vf_linienzug, Gefaellestrecke,
|
|
;; ssg_core, ssg_dbg)
|
|
;; - Umgebungsvariable DXFMAKRO gesetzt
|
|
;;
|
|
;; Speichert (via SSG_RUN_ALL_TESTS bei "save":"dxf"):
|
|
;; tests/output/hm_recformat_tests.dxf
|
|
;; tests/output/hm_recformat_results.json (via hm_recformat:export-results)
|
|
;;
|
|
;; Aufruf in BricsCAD:
|
|
;; (load (strcat (getenv "DXFMAKRO") "/tests/test_hm_recformat.lsp"))
|
|
;; TEST_HM_RECFORMAT ; in der aktuellen Dimension (ssg-ils-dim-aktuell)
|
|
;; TEST_HM_RECFORMAT_2D ; erzwungen 2D
|
|
;; TEST_HM_RECFORMAT_3D ; erzwungen 3D
|
|
;;
|
|
;; Debug-Datei (nur wenn eingeschaltet): (dbg-schalter-on "hm_recformat")
|
|
;; schreibt hm_recformat.dbg ins DXFM_LOG-Verzeichnis (Journal je Kette als JSON).
|
|
;; ============================================================
|
|
|
|
|
|
;; ============================================================
|
|
;; Ergebnis-JSON
|
|
;; ============================================================
|
|
|
|
;; --- JSON-Hilfen fuer Diagnosefelder (Strings/String-Listen) ---
|
|
;; Die extra-Felder in hmrec:result-json werden ROH in das JSON gesetzt,
|
|
;; ein Text muss also selbst seine Anfuehrungszeichen mitbringen und die
|
|
;; JSON-Sonderzeichen maskieren.
|
|
(defun hmrec:json-escape (s / out i c)
|
|
(setq out "" i 1)
|
|
(while (<= i (strlen s))
|
|
(setq c (substr s i 1))
|
|
(setq out (cond ((= c "\"") (strcat out "\\\""))
|
|
((= c "\\") (strcat out "\\\\"))
|
|
((= c "\n") (strcat out " "))
|
|
(T (strcat out c))))
|
|
(setq i (1+ i)))
|
|
out)
|
|
|
|
(defun hmrec:json-str (s)
|
|
(if s (strcat "\"" (hmrec:json-escape s) "\"") "null"))
|
|
|
|
(defun hmrec:json-liste (lst / s first)
|
|
(setq s "[" first T)
|
|
(foreach x lst
|
|
(if (not first) (setq s (strcat s ", ")))
|
|
(setq s (strcat s (hmrec:json-str x)) first nil))
|
|
(strcat s "]"))
|
|
|
|
;; --- Headless-Diagnose der Produktion lesen ---
|
|
;; vfl-headless-abbruch (Lisp/vf_linienzug.lsp) legt bei erschoepfter
|
|
;; Replay-Queue Art der Eingabe, Glied-Nummer und Eingabe-Nummer ab. Das ist
|
|
;; die eigentliche Desync-Auskunft - ohne sie weiss man nur, DASS Werte offen
|
|
;; blieben, nicht WO der Ablauf abgewichen ist.
|
|
(defun hmrec:headless-fehler-text ( / f)
|
|
(if (and (boundp '*vfl-headless-fehler*) *vfl-headless-fehler*)
|
|
(progn
|
|
(setq f *vfl-headless-fehler*)
|
|
(strcat (cdr (assoc "was" f)) " @ " (cdr (assoc "ort" f))))
|
|
nil))
|
|
|
|
;; Zaehler der trotz allem erreichten Live-Eingaben (muss 0 bleiben).
|
|
(defun hmrec:prompts ()
|
|
(if (and (boundp '*hmrec-prompts*) *hmrec-prompts*) *hmrec-prompts* 0))
|
|
|
|
|
|
;; "dimension" haelt fest, in welcher Dimension (2D/3D) gebaut wurde. Das ist
|
|
;; KEINE Eigenschaft der Eingabedaten: hm_recformat.json beschreibt die Ketten
|
|
;; dimensionsfrei. Womit unsere Makros bauen, entscheidet ssg-ils-dim-aktuell -
|
|
;; unsere Bibliothek hat von jedem Block eine _2D- und eine _3D-Variante.
|
|
;; extra: Alist zusaetzlicher Felder ((name . wert-string)), wird als
|
|
;; JSON-Zahlen/Strings so uebernommen, wie sie uebergeben werden.
|
|
(defun hmrec:result-json (test-id kind status block-name block-handle
|
|
insert-point attribs extra /
|
|
json tag val first)
|
|
(setq json (strcat " {\n"
|
|
" \"test_id\": \"" test-id "\",\n"
|
|
" \"kind\": \"" kind "\",\n"
|
|
" \"status\": \"" status "\",\n"
|
|
" \"dimension\": \""
|
|
(if (and (boundp '*hmrec-dimension*) *hmrec-dimension*)
|
|
*hmrec-dimension* "?") "\",\n"
|
|
" \"block_name\": \"" (if block-name block-name "") "\",\n"
|
|
" \"block_handle\": \"" (if block-handle block-handle "") "\",\n"
|
|
" \"insert_point\": ["
|
|
(if insert-point
|
|
(strcat (rtos (car insert-point) 2 1) ", "
|
|
(rtos (cadr insert-point) 2 1) ", "
|
|
(rtos (if (caddr insert-point) (caddr insert-point) 0.0) 2 1))
|
|
"0.0, 0.0, 0.0")
|
|
"],\n"))
|
|
(foreach f extra
|
|
(setq json (strcat json " \"" (car f) "\": " (cdr f) ",\n")))
|
|
(setq json (strcat json " \"actual_attributes\": {"))
|
|
(setq first T)
|
|
(foreach att attribs
|
|
(setq tag (car att) val (cdr att))
|
|
(if (not first) (setq json (strcat json ",")))
|
|
(setq json (strcat json "\n \"" tag "\": \"" (if val val "") "\""))
|
|
(setq first nil))
|
|
(setq json (strcat json "\n }\n }"))
|
|
json
|
|
)
|
|
|
|
|
|
;; --- Aus einer Block-ENAME ein Ergebnis-JSON erzeugen ---
|
|
;; status: "executed" bei sauberem Lauf; ein abweichender Status (z.B. bei
|
|
;; einem Queue-Desync) wird durchgereicht, die Block-Angaben bleiben dabei
|
|
;; erhalten - sonst waere der betroffene Block im Ergebnis nicht auffindbar.
|
|
(defun hmrec:ent-json-status (test-id kind status ent extra / ed)
|
|
(if ent
|
|
(progn
|
|
(setq ed (entget ent))
|
|
(hmrec:result-json test-id kind status
|
|
(cdr (assoc 2 ed)) (cdr (assoc 5 ed)) (cdr (assoc 10 ed))
|
|
(ssg-attrib-read ent) extra))
|
|
(hmrec:result-json test-id kind "failed" nil nil nil nil extra))
|
|
)
|
|
|
|
(defun hmrec:ent-json (test-id kind ent extra)
|
|
(hmrec:ent-json-status test-id kind "executed" ent extra)
|
|
)
|
|
|
|
|
|
;; --- Letzten INSERT mit Blocknamen-Praefix suchen ---
|
|
;; AutoLISP kennt KEIN entprev (nur entnext und entlast) - rueckwaerts durch
|
|
;; die Zeichnung laufen geht also nicht. Gesucht wird darum VORWAERTS, wobei
|
|
;; der letzte Treffer gewinnt. Ein blosses (entlast) genuegt nicht: nach dem
|
|
;; Bau koennen weitere Objekte entstehen (z.B. Beschriftungstexte), entlast
|
|
;; ist dann nicht der gesuchte Block - genau daran scheiterte der Testlauf.
|
|
;; ab-ent = Stand der Zeichnung VOR dem Bau. Damit prueft die Suche nur die
|
|
;; neu entstandenen Objekte: schnell, und sie kann nicht versehentlich den
|
|
;; Block eines frueheren Baus liefern (siehe Kommentar bei -ab).
|
|
(defun hmrec:insert-prefix-p (ent pref / ed bn)
|
|
(setq ed (entget ent) bn (cdr (assoc 2 ed)))
|
|
(and ed (= (cdr (assoc 0 ed)) "INSERT") bn
|
|
(>= (strlen bn) (strlen pref))
|
|
(= (substr bn 1 (strlen pref)) pref)))
|
|
|
|
;; Vorwaertslauf ab ab-ent (nil = ganze Zeichnung); der LETZTE Treffer
|
|
;; gewinnt. Der entget-Test faengt ein inzwischen ungueltiges ab-ent ab
|
|
;; (entget liefert dann nil, entnext wuerde einen Fehler werfen).
|
|
(defun hmrec:suche-vorwaerts (pref ab-ent / ent found)
|
|
(setq ent (if (and ab-ent (entget ab-ent)) (entnext ab-ent) (entnext)))
|
|
(while ent
|
|
(if (hmrec:insert-prefix-p ent pref) (setq found ent))
|
|
(setq ent (entnext ent)))
|
|
found)
|
|
|
|
(defun hmrec:last-insert-prefix-ab (pref ab-ent / ent)
|
|
(if ab-ent
|
|
;; MIT Marker nur die neu entstandenen Objekte pruefen - und BEWUSST
|
|
;; ohne entlast-Kurzschluss: hat dieser Bau keinen Block erzeugt, waere
|
|
;; entlast der Block eines FRUEHEREN Baus und das Ergebnis wuerde der
|
|
;; falschen Kette zugeordnet. Kein Treffer = kein Block, das ist die
|
|
;; richtige Antwort.
|
|
(hmrec:suche-vorwaerts pref ab-ent)
|
|
(progn
|
|
;; Ohne Marker: erst entlast (der haeufige Fall, das gerade
|
|
;; eingefuegte Objekt), sonst die ganze Zeichnung.
|
|
(setq ent (entlast))
|
|
(if (and ent (hmrec:insert-prefix-p ent pref))
|
|
ent
|
|
(hmrec:suche-vorwaerts pref nil)))))
|
|
|
|
(defun hmrec:last-insert-prefix (pref)
|
|
(hmrec:last-insert-prefix-ab pref nil))
|
|
|
|
|
|
;; ============================================================
|
|
;; JSON-Eintraege -> Ketten
|
|
;; ============================================================
|
|
|
|
;; Das flache JSON-Array in Ketten gruppieren: ein Objekt mit "test_id" ist
|
|
;; ein Kopf und beginnt eine neue Kette, die folgenden Objekte mit "typ" sind
|
|
;; ihre Eingaben (Reihenfolge = Frage-Reihenfolge, bleibt erhalten).
|
|
;; Rueckgabe: Liste von (kopf eingaben-liste).
|
|
(defun hmrec:gruppiere (daten / ketten kopf eingaben)
|
|
(setq ketten '() kopf nil eingaben '())
|
|
(foreach obj daten
|
|
(cond
|
|
((ssg-val obj "test_id")
|
|
(if kopf
|
|
(setq ketten (cons (list kopf (reverse eingaben)) ketten)))
|
|
(setq kopf obj eingaben '()))
|
|
((ssg-val obj "typ")
|
|
(if kopf (setq eingaben (cons obj eingaben))))
|
|
)
|
|
)
|
|
(if kopf (setq ketten (cons (list kopf (reverse eingaben)) ketten)))
|
|
(reverse ketten)
|
|
)
|
|
|
|
|
|
;; --- Wert als String lesen (auch wenn er als Zahl im JSON steht) ---
|
|
;; Die Menue-Antworten sind Strings ("1"/"2"/"90"/"30"). Steht in einer von
|
|
;; Hand gepflegten Datei versehentlich 1 statt "1", wuerde ein Zahlenwert in
|
|
;; die Replay-Queue wandern und der Vergleich (= antwort "1") schlagen fehl -
|
|
;; darum hier immer nach String wandeln.
|
|
(defun hmrec:als-string (v)
|
|
(cond
|
|
((null v) "")
|
|
((= (type v) 'STR) v)
|
|
((= (type v) 'INT) (itoa v))
|
|
((= (type v) 'REAL) (rtos v 2 6))
|
|
(T "")
|
|
)
|
|
)
|
|
|
|
|
|
;; --- Einen Eingabe-Eintrag in Journal-Eintraege uebersetzen ---
|
|
;; Journal-Format (vfl-entry->string in Lisp/vf_linienzug.lsp):
|
|
;; ("PT" x y z) / ("REAL" . r) / ("DL" . r) / ("INT" . i) / ("STR" . s) /
|
|
;; ("STEP" . label)
|
|
;; Ein "point_rel" wird zu EINEM oder ZWEI Eintraegen: immer die Laenge (DL),
|
|
;; zusaetzlich die Fahrtrichtung (REAL) nur dort, wo sie im Journal steht
|
|
;; (allererstes Segment der Kette, siehe Kopfkommentar).
|
|
;; Rueckgabe: Liste von Journal-Eintraegen (kann leer sein).
|
|
(defun hmrec:eintrag->journal (e / typ w hz)
|
|
(setq typ (ssg-val e "typ"))
|
|
(cond
|
|
((= typ "point_abs")
|
|
(setq w (ssg-val e "wert"))
|
|
(if (and w (listp w) (>= (length w) 3))
|
|
(list (cons "PT" (mapcar 'float w)))
|
|
nil))
|
|
((= typ "point_rel")
|
|
(setq w (ssg-val e "dL") hz (ssg-val e "hz"))
|
|
(cond
|
|
((not (numberp w)) nil)
|
|
((numberp hz) (list (cons "DL" (float w)) (cons "REAL" (float hz))))
|
|
(T (list (cons "DL" (float w))))))
|
|
((= typ "real")
|
|
(setq w (ssg-val e "wert"))
|
|
(if (numberp w) (list (cons "REAL" (float w))) nil))
|
|
((= typ "int")
|
|
(setq w (ssg-val e "wert"))
|
|
(if (numberp w) (list (cons "INT" (fix w))) nil))
|
|
((= typ "string")
|
|
(list (cons "STR" (hmrec:als-string (ssg-val e "wert")))))
|
|
((= typ "step")
|
|
(list (cons "STEP" (hmrec:als-string (ssg-val e "wert")))))
|
|
;; Eine Frage, die gestellt und bewusst uebergangen wurde (bisher nur die
|
|
;; Zufuehrungsachse des AS-Elements, siehe ProtokollSink.as_achse in
|
|
;; lib/vf_journal_export.py) - im Journal ein wertloser "NIL"-Eintrag.
|
|
;; Er MUSS mitlaufen: beim Replay poppt ihn vfl-in-point, sonst zoege
|
|
;; dieser Aufruf den naechsten Wert aus der Queue (Desync).
|
|
((= typ "nil")
|
|
(list (cons "NIL" nil)))
|
|
(T nil)
|
|
)
|
|
)
|
|
|
|
|
|
;; --- Alle Eingaben einer Kette in ein Vorwaerts-Journal uebersetzen ---
|
|
;; Vorwaerts = Bau-Reihenfolge, genau so erwartet es vfl-journal-replay-start.
|
|
(defun hmrec:journal-bauen (eingaben / out)
|
|
(setq out '())
|
|
(foreach e eingaben
|
|
(foreach j (hmrec:eintrag->journal e)
|
|
(setq out (cons j out))))
|
|
(reverse out)
|
|
)
|
|
|
|
|
|
;; --- Nicht verbrauchte Werte in der Replay-Queue zaehlen ---
|
|
;; STEP-Marker zaehlen nicht mit: vfl-replay-pop ueberspringt sie, sie sind
|
|
;; also kein offener Wert. Bleibt hier etwas uebrig, ist der Bau-Ablauf vom
|
|
;; aufgezeichneten abgewichen (Desync) - das MUSS auffallen.
|
|
(defun hmrec:queue-rest ( / n)
|
|
(setq n 0)
|
|
(if (and (boundp '*vfl-replay-queue*) *vfl-replay-queue*)
|
|
(foreach e *vfl-replay-queue*
|
|
(if (/= (car e) "STEP") (setq n (1+ n)))))
|
|
n
|
|
)
|
|
|
|
|
|
;; ============================================================
|
|
;; Eine Kette bauen
|
|
;; ============================================================
|
|
|
|
;; Spielt das Journal einer Kette ab. Ablauf wie vfl-konvertiere-ent
|
|
;; (Lisp/vf_linienzug.lsp): Queue setzen, vf-linienzug-modus laufen lassen,
|
|
;; danach den entstandenen VF_n-Block einsammeln.
|
|
;;
|
|
;; vl-catch-all-apply ist hier BEWUSST gesetzt (anders als im interaktiven
|
|
;; Editier-Pfad vfl-edit-ent): bricht eine Kette ab, muss die Testschleife
|
|
;; ueber die restlichen Ketten weiterlaufen. Der Preis ist derselbe wie beim
|
|
;; Batch-Konverter - der *error*-Handler in vf-linienzug-modus (der die
|
|
;; Teil-Geometrie zu einem Block wickelt) kommt dann nicht zum Zug und die
|
|
;; Teilgeometrie bleibt lose in der Zeichnung liegen. Der Testfall wird darum
|
|
;; klar als "failed" samt Fehlertext gemeldet.
|
|
;; *error* wird um den Aufruf herum gesichert: nach einem abgefangenen Abbruch
|
|
;; steht dort noch der Handler-Lambda von vf-linienzug-modus (es kommt nicht
|
|
;; mehr zu dessen (setq *error* old-error)) - ohne Restore wuerde die naechste
|
|
;; Kette auf einem Handler mit toten dynamischen Bindungen aufsetzen.
|
|
(defun hmrec:build-linienzug (kopf eingaben / tid journal anz offen err ent
|
|
alt-error extra hl-fehler meldungen vor-ent)
|
|
(setq tid (ssg-val kopf "test_id"))
|
|
(setq journal (hmrec:journal-bauen eingaben))
|
|
(setq anz (length journal))
|
|
(princ (strcat "\n [LINIENZUG] " tid " -> " (itoa (length eingaben))
|
|
" Eingaben, " (itoa anz) " Journal-Eintraege"))
|
|
(if (ssg-val kopf "beschreibung")
|
|
(princ (strcat "\n " (ssg-val kopf "beschreibung"))))
|
|
(if (and (boundp '*hmrec-dbg*) *hmrec-dbg*)
|
|
(progn
|
|
(dbgmsg (strcat "KETTE " tid " JOURNAL " (vfl-journal->json journal)))
|
|
(dbgflush)))
|
|
|
|
(cond
|
|
;; Ohne Journal (oder ohne Startpunkt an erster Stelle) nichts bauen: ein
|
|
;; Replay ohne PT wuerde den Startpunkt interaktiv erfragen und die ganze
|
|
;; Kette an der falschen Stelle aufbauen.
|
|
((null journal)
|
|
(princ (strcat "\n FEHLER: " tid " - keine Eingaben lesbar."
|
|
" Stehen die Zahlen-Arrays in EINER Zeile?"
|
|
" (ssg-cfg-parse-array kann keine umgebrochenen lesen)"))
|
|
(hmrec:result-json tid "linienzug" "failed" nil nil nil nil
|
|
(list (cons "eingaben_gesamt" (itoa anz))
|
|
(cons "eingaben_offen" (itoa anz)))))
|
|
|
|
((/= (car (car journal)) "PT")
|
|
(princ (strcat "\n FEHLER: " tid " - erster Eintrag ist kein"
|
|
" Startpunkt (point_abs), nichts gebaut."))
|
|
(hmrec:result-json tid "linienzug" "failed" nil nil nil nil
|
|
(list (cons "eingaben_gesamt" (itoa anz))
|
|
(cons "eingaben_offen" (itoa anz)))))
|
|
|
|
(T
|
|
;; Stand der Zeichnung VOR dem Bau: der fertige VF_-Block wird danach
|
|
;; ab hier gesucht (siehe hmrec:last-insert-prefix-ab).
|
|
(setq vor-ent (entlast))
|
|
(setq alt-error *error*)
|
|
(vfl-journal-reset)
|
|
(vfl-journal-replay-start journal)
|
|
(setq err (vl-catch-all-apply 'vf-linienzug-modus '()))
|
|
(setq offen (hmrec:queue-rest))
|
|
;; Diagnose VOR dem Reset sichern: vfl-journal-reset loescht
|
|
;; *vfl-headless-fehler* und *vfl-meldungen* mit (beide gehoeren zum
|
|
;; einzelnen Lauf, nicht zur Sitzung).
|
|
(setq hl-fehler (hmrec:headless-fehler-text))
|
|
(setq meldungen (if (boundp '*vfl-meldungen*) *vfl-meldungen* nil))
|
|
(setq *error* alt-error)
|
|
(vfl-journal-reset)
|
|
(setq extra (list (cons "eingaben_gesamt" (itoa anz))
|
|
(cons "eingaben_offen" (itoa offen))
|
|
(cons "prompts" (itoa (hmrec:prompts)))
|
|
(cons "headless_fehler" (hmrec:json-str hl-fehler))
|
|
(cons "meldungen" (hmrec:json-liste meldungen))))
|
|
(cond
|
|
;; Der Headless-Riegel der Produktion hat gegriffen: die Journal-Daten
|
|
;; passen nicht zum tatsaechlichen Bau-Ablauf. Praeziser als "failed",
|
|
;; weil hl-fehler Glied UND Eingabe-Nummer nennt.
|
|
(hl-fehler
|
|
(princ (strcat "\n DESYNC: " tid " - " hl-fehler))
|
|
(hmrec:ent-json-status tid "linienzug" "desync"
|
|
(hmrec:last-insert-prefix-ab "VF_" vor-ent) extra))
|
|
((vl-catch-all-error-p err)
|
|
(princ (strcat "\n FEHLER: " tid " abgebrochen -> "
|
|
(vl-catch-all-error-message err)))
|
|
(hmrec:result-json tid "linienzug" "failed" nil nil nil nil extra))
|
|
;; Kette gebaut, aber der Ablauf hat nicht alle aufgezeichneten Werte
|
|
;; abgerufen: die Geometrie kann nicht der Vorlage entsprechen.
|
|
((> offen 0)
|
|
(princ (strcat "\n FEHLER: " tid " - " (itoa offen)
|
|
" Journal-Werte NICHT verbraucht (Ablauf weicht"
|
|
" von der Aufzeichnung ab)."))
|
|
(hmrec:ent-json-status tid "linienzug" "desync"
|
|
(hmrec:last-insert-prefix-ab "VF_" vor-ent) extra))
|
|
(T
|
|
(setq ent (hmrec:last-insert-prefix-ab "VF_" vor-ent))
|
|
(if ent
|
|
(princ (strcat " -> Block " (cdr (assoc 2 (entget ent)))))
|
|
(princ "\n FEHLER: kein VF_-Block gefunden"))
|
|
(hmrec:ent-json tid "linienzug" ent extra)))))
|
|
)
|
|
|
|
|
|
;; ============================================================
|
|
;; Headless-Absicherung: Dialoge aus, leere Queue bricht ab
|
|
;; ============================================================
|
|
;; Die Journale sind vollstaendig, es darf also keine Live-Eingabe geben.
|
|
;; Falls doch (Desync), wuerde ein getpoint/getstring den Testlauf blockieren
|
|
;; und ein alert-Fenster ihn haengen lassen. Darum werden die Eingabe-
|
|
;; Funktionen fuer die Dauer des Tests durch Abbruch-Stubs ersetzt (liefern
|
|
;; nil = Abbruch, was vf-linienzug-modus sauber beendet) und alert auf die
|
|
;; Konsole umgeleitet. Alles mit Save/Restore, siehe hmrec:stubs-aus.
|
|
;; Die Stubs haben feste 1- bzw. 2-Arity (AutoLISP kennt keine optionalen
|
|
;; Parameter) - genau wie die Mocks in test_linienzug.lsp. Ruft der Bau-Ablauf
|
|
;; eine der Funktionen mit anderer Argumentzahl auf, gibt es einen
|
|
;; Argumentfehler statt einer Warnung; beides landet im vl-catch-all-apply um
|
|
;; vf-linienzug-modus und meldet die Kette als "failed". Wichtig ist nur, dass
|
|
;; kein Prompt und kein Dialog den Lauf blockiert.
|
|
(defun hmrec:stub-warnung (was)
|
|
(setq *hmrec-prompts* (1+ (hmrec:prompts)))
|
|
(princ (strcat "\n WARNUNG: unerwartete Live-Eingabe (" was
|
|
") - Replay-Queue leer, Kette wird abgebrochen."))
|
|
nil
|
|
)
|
|
(defun hmrec:stub-getpoint (a b) (hmrec:stub-warnung "getpoint"))
|
|
(defun hmrec:stub-getstring (a) (hmrec:stub-warnung "getstring"))
|
|
(defun hmrec:stub-getint (a) (hmrec:stub-warnung "getint"))
|
|
(defun hmrec:stub-getreal (a) (hmrec:stub-warnung "getreal"))
|
|
(defun hmrec:stub-alert (msg)
|
|
(princ (strcat "\n ALERT (unterdrueckt): " (if msg msg "")))
|
|
(princ)
|
|
)
|
|
|
|
(defun hmrec:stubs-an ( / )
|
|
(setq *hmrec-alt-getpoint* vfl-getpoint
|
|
*hmrec-alt-getstring* getstring
|
|
*hmrec-alt-getint* getint
|
|
*hmrec-alt-getreal* getreal
|
|
*hmrec-alt-alert* alert)
|
|
(setq vfl-getpoint hmrec:stub-getpoint
|
|
getstring hmrec:stub-getstring
|
|
getint hmrec:stub-getint
|
|
getreal hmrec:stub-getreal
|
|
alert hmrec:stub-alert)
|
|
;; Wizard-Dialoge aus (waehrend eines Replays greifen sie ohnehin nicht,
|
|
;; siehe vfl-wizard-aktiv - aber nach einem Desync wuerde ein Dialog
|
|
;; aufgehen und warten).
|
|
(setq *hmrec-alt-wizard* (if (boundp '*vfl-wizard-mode*) *vfl-wizard-mode*))
|
|
(setq *vfl-wizard-mode* nil)
|
|
(setq *hmrec-alt-gui* (if (boundp '*ssg-gui-aus*) *ssg-gui-aus*))
|
|
(if (car (atoms-family 1 '("SSG-GUI-AUS"))) (ssg-gui-aus))
|
|
;; Headless-Riegel der Produktion einschalten: eine erschoepfte Replay-Queue
|
|
;; ist dann ein harter, lokalisierter Abbruch statt eines stillen Rueckfalls
|
|
;; auf Live-Eingabe (siehe vfl-headless-abbruch). Die Stubs oben bleiben als
|
|
;; zweites Netz - sie fangen die Prompts ausserhalb der vfl-in-*-Wrapper
|
|
;; (Modus 3, Nebenpfade) und zaehlen sie.
|
|
(setq *hmrec-alt-headless* (if (boundp '*vfl-headless*) *vfl-headless*))
|
|
(setq *vfl-headless* T)
|
|
(setq *hmrec-prompts* 0)
|
|
(princ)
|
|
)
|
|
|
|
(defun hmrec:stubs-aus ( / )
|
|
(setq vfl-getpoint *hmrec-alt-getpoint*
|
|
getstring *hmrec-alt-getstring*
|
|
getint *hmrec-alt-getint*
|
|
getreal *hmrec-alt-getreal*
|
|
alert *hmrec-alt-alert*)
|
|
(setq *vfl-wizard-mode* *hmrec-alt-wizard*)
|
|
(setq *vfl-headless* *hmrec-alt-headless*)
|
|
(setq *ssg-gui-aus* *hmrec-alt-gui*) ; Vorzustand, nicht pauschal an
|
|
(princ)
|
|
)
|
|
|
|
|
|
;; ============================================================
|
|
;; Alle Ketten bauen
|
|
;; ============================================================
|
|
;; Eigene Funktion, damit der Aufrufer sie in vl-catch-all-apply klammern und
|
|
;; die Eingabe-Stubs GARANTIERT zuruecknehmen kann (ein hier entkommender
|
|
;; Fehler wuerde sonst getstring/getpoint/alert der laufenden BricsCAD-Sitzung
|
|
;; ersetzt zuruecklassen).
|
|
;; Rueckgabe: Ergebnis-Liste in Bau-Reihenfolge.
|
|
(defun hmrec:ketten-bauen (ketten / kette res out tid fehlertext)
|
|
(setq out '())
|
|
(foreach kette ketten
|
|
;; Dimensions-Override je Kette neu setzen: der Abbruch-Handler in
|
|
;; vf-linienzug-modus setzt *ssg-ils-dim* zurueck, ein Abbruch wuerde die
|
|
;; folgenden Ketten sonst in der falschen Dimension bauen.
|
|
(if (and (boundp '*hmrec-dim-override*) *hmrec-dim-override*)
|
|
(setq *ssg-ils-dim* *hmrec-dim-override*))
|
|
;; Je Kette gefangen: ein Fehler NACH dem Bau (z.B. beim Auswerten des
|
|
;; Ergebnisses) darf nicht die restlichen Ketten mitnehmen - sonst steht
|
|
;; am Ende "0 OK, 0 Fehler" und man sieht nicht einmal, welche Kette
|
|
;; gebaut wurde. Der Bau selbst ist in hmrec:build-linienzug bereits
|
|
;; separat gefangen; dieser Riegel hier deckt alles danach ab.
|
|
(setq tid (ssg-val (car kette) "test_id"))
|
|
(setq res (vl-catch-all-apply 'hmrec:build-linienzug
|
|
(list (car kette) (cadr kette))))
|
|
(if (vl-catch-all-error-p res)
|
|
(progn
|
|
(setq fehlertext (vl-catch-all-error-message res))
|
|
(princ (strcat "\n FEHLER: " tid " - Ausnahme: " fehlertext))
|
|
(setq res (hmrec:result-json tid "linienzug" "failed"
|
|
nil nil nil nil
|
|
(list (cons "fehler_text"
|
|
(hmrec:json-str fehlertext)))))))
|
|
(if res (setq out (cons res out))))
|
|
(reverse out)
|
|
)
|
|
|
|
|
|
;; ============================================================
|
|
;; JSON-Export der Ergebnisse
|
|
;; ============================================================
|
|
(defun hm_recformat:export-results (tests-out-dir / out-json f first)
|
|
(if (null *hmrec-test-results*)
|
|
(princ "\n Keine Ergebnisse vorhanden.")
|
|
(progn
|
|
(vl-mkdir tests-out-dir)
|
|
(setq out-json (strcat tests-out-dir "/hm_recformat_results.json"))
|
|
(setq f (open out-json "w"))
|
|
(if f
|
|
(progn
|
|
(write-line "[" f)
|
|
(setq first T)
|
|
(foreach r *hmrec-test-results*
|
|
(if (not first) (write-line "," f))
|
|
(write-line r f)
|
|
(setq first nil))
|
|
(write-line "]" f)
|
|
(close f)
|
|
(princ (strcat "\n Ergebnisse: " out-json)))
|
|
(princ (strcat "\n FEHLER: Kann " out-json " nicht schreiben!")))))
|
|
)
|
|
|
|
|
|
;; ============================================================
|
|
;; C:TEST_HM_RECFORMAT - Hauptbefehl
|
|
;; ============================================================
|
|
(defun c:TEST_HM_RECFORMAT ( / json-datei daten ketten results-list res
|
|
anz-ok anz-fehler)
|
|
;; Debug-Datei nur bei eingeschaltetem Schalter: (dbg-schalter-on "hm_recformat")
|
|
(setq *hmrec-dbg*
|
|
(and (car (atoms-family 1 '("DBG-SCHALTER-OPEN")))
|
|
(dbg-schalter-open "hm_recformat" "hm_recformat.dbg" "DXFM_LOG")))
|
|
|
|
;; Benoetigte Feature-Module laden (Linienzug braucht Vario + Gefaelle)
|
|
(ssg-ensure "VarioFoerderer")
|
|
(ssg-ensure "Gefaellestrecke")
|
|
|
|
(if (null (car (atoms-family 1 '("VF-LINIENZUG-MODUS"))))
|
|
(progn
|
|
(princ "\n[TEST_HM_RECFORMAT] FEHLER: vf-linienzug-modus nicht geladen"
|
|
" (VarioFoerderer/Gefaellestrecke laden).")
|
|
(if *hmrec-dbg* (dbgclose))
|
|
(exit)))
|
|
|
|
(ssg-start "TEST_HM_RECFORMAT" '(("OSMODE") ("CECOLOR") ("ATTREQ") ("ATTDIA")))
|
|
(setvar "OSMODE" 0)
|
|
(setvar "ATTREQ" 0)
|
|
(setvar "ATTDIA" 0)
|
|
|
|
;; Block-Bibliothek (Bogen-/AS-/ES-Masse) initialisieren
|
|
(if (or (not *lib-initialized*) (null bogen-auf))
|
|
(init-bibliothek))
|
|
|
|
;; Bau-Dimension festhalten. Die Eingabedaten sind dimensionsfrei; welche
|
|
;; Blockvariante (_2D/_3D) verwendet wird, loest ssg-ils-dim-aktuell auf
|
|
;; (Override *ssg-ils-dim* -> Umgebungsvariable DXFM_DIM -> Default "3D").
|
|
(setq *hmrec-dimension* (ssg-ils-dim-aktuell))
|
|
(princ (strcat "\n Bau-Dimension: " *hmrec-dimension*
|
|
" (umschalten: TEST_HM_RECFORMAT_2D / TEST_HM_RECFORMAT_3D)"))
|
|
|
|
;; Testdaten laden
|
|
(setq json-datei (strcat (getenv "DXFMAKRO") "/tests/testdata/hm_recformat.json"))
|
|
(if (not (findfile json-datei))
|
|
(progn
|
|
(princ (strcat "\n[TEST_HM_RECFORMAT] FEHLER: " json-datei " nicht gefunden!"))
|
|
(ssg-end)
|
|
(if *hmrec-dbg* (dbgclose))
|
|
(exit)))
|
|
(setq daten (ssg-load-json json-datei))
|
|
(if (null daten)
|
|
(progn
|
|
(princ "\n[TEST_HM_RECFORMAT] FEHLER: Testdaten konnten nicht geladen werden.")
|
|
(ssg-end)
|
|
(if *hmrec-dbg* (dbgclose))
|
|
(exit)))
|
|
|
|
(setq ketten (hmrec:gruppiere daten))
|
|
(if (null ketten)
|
|
(progn
|
|
(princ "\n[TEST_HM_RECFORMAT] FEHLER: keine Kette gefunden - erwartet werden"
|
|
" Kopf-Objekte mit \"test_id\" und Eingaben mit \"typ\".")
|
|
(ssg-end)
|
|
(if *hmrec-dbg* (dbgclose))
|
|
(exit)))
|
|
|
|
(princ "\n\n================================================================")
|
|
(princ "\n TEST_HM_RECFORMAT - 5 Linienzuege der Anlage HundM (polylines.dxf)")
|
|
(princ (strcat "\n " (itoa (length daten)) " JSON-Objekte, "
|
|
(itoa (length ketten)) " Ketten"))
|
|
(princ "\n================================================================")
|
|
|
|
(setq anz-ok 0 anz-fehler 0)
|
|
(hmrec:stubs-an)
|
|
;; Stubs MUESSEN auch nach einem unerwarteten Fehler zurueckgenommen werden.
|
|
(setq results-list (vl-catch-all-apply 'hmrec:ketten-bauen (list ketten)))
|
|
(hmrec:stubs-aus)
|
|
(if (vl-catch-all-error-p results-list)
|
|
(progn
|
|
(princ (strcat "\n[TEST_HM_RECFORMAT] FEHLER in der Kettenschleife: "
|
|
(vl-catch-all-error-message results-list)))
|
|
(setq results-list '())))
|
|
|
|
(foreach res results-list
|
|
(if (vl-string-search "\"status\": \"executed\"" res)
|
|
(setq anz-ok (1+ anz-ok))
|
|
(setq anz-fehler (1+ anz-fehler))))
|
|
|
|
(princ "\n================================================================")
|
|
(princ (strcat "\n Ergebnis: " (itoa anz-ok) " OK, "
|
|
(itoa anz-fehler) " Fehler"))
|
|
(princ "\n================================================================")
|
|
|
|
(setq *hmrec-test-results* results-list)
|
|
|
|
(ssg-end)
|
|
(princ "\n TEST_HM_RECFORMAT abgeschlossen.")
|
|
(if *hmrec-dbg* (dbgclose))
|
|
(princ)
|
|
)
|
|
|
|
|
|
;; ============================================================
|
|
;; Dieselbe Anlage in einer bestimmten Dimension bauen
|
|
;; ============================================================
|
|
;; Die Eingabedaten (hm_recformat.json) sind dimensionsfrei - sie beschreiben die
|
|
;; Eingaben, mit denen die Ketten gebaut wurden. Ob daraus flache 2D-Symbole
|
|
;; oder 3D-Modelle werden, entscheidet allein die Blockvariante (_2D/_3D), die
|
|
;; ssg-ils-dim-aktuell aufloest. Unsere Bibliothek hat beide, also laesst sich
|
|
;; dieselbe Anlage ohne Datenaenderung in 2D ODER 3D aufbauen.
|
|
;; *hmrec-dim-override* wird in der Kettenschleife je Kette neu gesetzt
|
|
;; (siehe dort).
|
|
(defun hmrec:mit-dimension (dim / alt ergebnis)
|
|
(setq alt (if (boundp '*ssg-ils-dim*) *ssg-ils-dim*))
|
|
(setq *ssg-ils-dim* dim)
|
|
(setq *hmrec-dim-override* dim)
|
|
(princ (strcat "\n[TEST_HM_RECFORMAT] Dimension voruebergehend auf " dim
|
|
" gesetzt."))
|
|
(setq ergebnis (c:TEST_HM_RECFORMAT))
|
|
;; Override wieder auf den vorherigen Stand - sonst baut ein folgender Test
|
|
;; unbemerkt in der hier gewaehlten Dimension weiter.
|
|
(setq *ssg-ils-dim* alt)
|
|
(setq *hmrec-dim-override* nil)
|
|
(princ (strcat "\n[TEST_HM_RECFORMAT] Dimension zurueckgesetzt auf "
|
|
(if alt alt "Umgebung/Default") "."))
|
|
ergebnis
|
|
)
|
|
|
|
(defun c:TEST_HM_RECFORMAT_2D ( / ) (hmrec:mit-dimension "2D"))
|
|
(defun c:TEST_HM_RECFORMAT_3D ( / ) (hmrec:mit-dimension "3D"))
|