;; ============================================================ ;; 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 ;; tests/testdata/object_data.md Abschnitt 8): ;; 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 - in exakter Frage-Reihenfolge ;; 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"))))) (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) (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*) (if (car (atoms-family 1 '("SSG-GUI-AN"))) (ssg-gui-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"))