Overview
Comment: | Additional tweaks for chicken 5. Needs sparse-vectors added |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | v1.70-refactor02-chicken5 | v1.70-defunct-try |
Files: | files | file ages | folders |
SHA1: |
3fcfe6ba9434a4107be95f91ef10f53c |
User & Date: | jmoon18 on 2020-01-09 13:09:47 |
Other Links: | branch diff | manifest | tags |
Context
2020-02-20
| ||
17:49 | Additional fixes for chicken 5 compatibility check-in: 675fffe4d9 user: jmoon tags: v1.70-refactor02-chicken5, v1.70-defunct-try | |
2020-01-09
| ||
13:09 | Additional tweaks for chicken 5. Needs sparse-vectors added check-in: 3fcfe6ba94 user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try | |
2020-01-08
| ||
14:43 | Updates post Matt's merge check-in: 4e27bc6a19 user: jmoon18 tags: v1.70-refactor02-chicken5, v1.70-defunct-try | |
14:41 | wip check-in: 652f6c9323 user: mrwellan tags: v1.70-captain-ulex, v1.70-defunct-try | |
Changes
Modified commonmod.scm from [ac993d8aa7] to [9ac021e7df].
︙ | ︙ | |||
22 23 24 25 26 27 28 | (declare (uses mtargs)) ;; (declare (uses stml2)) (declare (uses mtconfigf)) (declare (uses pkts)) (module commonmod * | | > > > > > > > > > > > > > > > > | | | > | > | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | (declare (uses mtargs)) ;; (declare (uses stml2)) (declare (uses mtconfigf)) (declare (uses pkts)) (module commonmod * (import scheme (chicken base) (chicken process) (chicken format) (chicken process-context) (chicken process-context posix) (chicken string) (chicken io) (chicken pretty-print) (chicken file) (chicken file posix) (chicken pathname) (chicken time) (chicken sort) (chicken condition) (chicken time posix) ) (import (prefix sqlite3 sqlite3:) typed-records srfi-18 srfi-1 (chicken file) format srfi-13 matchable srfi-69 (chicken port) (prefix base64 base64:) regex-case regex hostinfo srfi-4 (prefix dbi dbi:) stack md5 message-digest z3 directory-utils system-information ;;sparse-vectors ) (import pkts) (import (prefix mtconfigf configf:)) (import (prefix mtargs args:)) (include "common_records.scm") (include "megatest-fossil-hash.scm") |
︙ | ︙ | |||
235 236 237 238 239 240 241 | (get-environment-variable "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr verbose quiet)) (debug:check-verbosity *verbosity* debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not *verbosity*)(set! *verbosity* 1)) (if (or dmode ;; (args:get-arg "-debug") (not (get-environment-variable "MT_DEBUG_MODE"))) | | | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | (get-environment-variable "MT_DEBUG_MODE")))) (set! *verbosity* (debug:calc-verbosity debugstr verbose quiet)) (debug:check-verbosity *verbosity* debugstr) ;; if we were handed a bad verbosity rule then we will override it with 1 and continue (if (not *verbosity*)(set! *verbosity* 1)) (if (or dmode ;; (args:get-arg "-debug") (not (get-environment-variable "MT_DEBUG_MODE"))) (set-environment-variable! "MT_DEBUG_MODE" (if (list? *verbosity*) (string-intersperse (map conc *verbosity*) ",") (conc *verbosity*)))))) (define (debug:print n e . params) (if (debug:debug-mode n) (with-output-to-port (or e (current-error-port)) (lambda () |
︙ | ︙ | |||
594 595 596 597 598 599 600 | ;; (define (common:get-create-writeable-dir dirs) (if (null? dirs) #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) | | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 | ;; (define (common:get-create-writeable-dir dirs) (if (null? dirs) #f (let loop ((hed (car dirs)) (tal (cdr dirs))) (let ((res (or (and (directory? hed) (file-writable? hed) hed) (handle-exceptions exn (begin (debug:print-info 0 *default-log-port* "could not create " hed ", this might cause problems down the road.") #f) (create-directory hed #t))))) |
︙ | ︙ | |||
670 671 672 673 674 675 676 | ;; returns the directory or #f ;; (define (common:directory-writable? path-string) (handle-exceptions exn #f (if (and (directory-exists? path-string) | | | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 | ;; returns the directory or #f ;; (define (common:directory-writable? path-string) (handle-exceptions exn #f (if (and (directory-exists? path-string) (file-writable? path-string)) path-string #f))) ;;====================================================================== ;; T I M E A N D D A T E ;;====================================================================== ;; Convert strings like "5s 2h 3m" => 60x60x2 + 3x60 + 5 |
︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 | (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables. (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") (if (and (string? val) (string? key)) (handle-exceptions exn (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) | | | | 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 | (if (or (substring-index "!" key) (substring-index ":" key)) ;; variables containing : are for internal use and cannot be environment variables. (debug:print-error 4 *default-log-port* "skip setting internal use only variables containing \":\" or starting with \"!\"") (if (and (string? val) (string? key)) (handle-exceptions exn (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val) (set-environment-variable! key val)) (debug:print-error 0 *default-log-port* "bad value for setenv, key=" key ", value=" val)))) (define home (getenv "HOME")) (define user (getenv "USER")) ;; put any changed environment variables back to how they were - TODO - turn this into some sort of with- (define (common:set-vars-back all-vars) (for-each (lambda (vardat) (let ((var (car vardat)) (val (cdr vardat))) (if (not (equal? (get-environment-variable var) val)) (handle-exceptions exn (debug:print-error 0 *default-log-port* "Failed to set " var " to " val) (set-environment-variable! var val))))) all-vars)) ;; returns list of fd count, socket count (define (get-file-descriptor-count #!key (pid (current-process-id ))) (list (length (glob (conc "/proc/" pid "/fd/*"))) (length (filter identity (map socket? (glob (conc "/proc/" pid "/fd/*"))))) |
︙ | ︙ | |||
1658 1659 1660 1661 1662 1663 1664 |
| | | | > | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 | (import pathname-expand (chicken file)) ;; this plugs a hole in posix-extras in recent chicken versions > 4.9) #;(let-values (( (chicken-release-number chicken-major-version) (apply values (map string->number (take (string-split (chicken-version) ".") 2))))) (let ((resolve-pathname-broken? (or (> chicken-release-number 4) (and (eq? 4 chicken-release-number) (> chicken-major-version 9))))) (if resolve-pathname-broken? (define ##sys#expand-home-path pathname-expand)))) ;;(define (realpath x) (resolve-pathname (pathname-expand (or x "/dev/null")) )) (define (realpath x) (pathname-expand (or x "/dev/null")) ) (define (common:get-this-exe-fullpath #!key (argv (argv))) (let* ((this-script (cond ((and (> (length argv) 2) (string-match "^(.*/csi|csi)$" (car argv)) (string-match "^-(s|ss|sx|script)$" (cadr argv))) |
︙ | ︙ | |||
2003 2004 2005 2006 2007 2008 2009 | (begin (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1))) (let ((hhf (conc *toppath* "/.homehost"))) (if (common:file-exists? hhf) (with-input-from-file hhf read-line) | | | 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 | (begin (mutex-unlock! *homehost-mutex*) (debug:print 0 *default-log-port* "ERROR: ["(common:human-time)"] Failed to read .homehost file after trying five times. Giving up and exiting, message: " ((condition-property-accessor 'exn 'message) exn)) (exit 1))) (let ((hhf (conc *toppath* "/.homehost"))) (if (common:file-exists? hhf) (with-input-from-file hhf read-line) (if (file-writable? *toppath*) (begin (with-output-to-file hhf (lambda () (print bestadrs))) (begin (mutex-unlock! *homehost-mutex*) (car (common:get-homehost)))) |
︙ | ︙ | |||
2211 2212 2213 2214 2215 2216 2217 | ;; get values from cached info from dropping file in logs dir ;; e.g. key is host and dtype is normalized-load ;; (define (common:get-cached-info key dtype #!key (age 5)) (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log"))) (if (and (file-exists? fullpath) | | | 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 | ;; get values from cached info from dropping file in logs dir ;; e.g. key is host and dtype is normalized-load ;; (define (common:get-cached-info key dtype #!key (age 5)) (let* ((fullpath (conc *toppath* "/logs/" key "-" dtype ".log"))) (if (and (file-exists? fullpath) (file-readable? fullpath)) (handle-exceptions exn #f (debug:print 2 *default-log-port* "reading file " fullpath) (let ((real-age (- (current-seconds)(file-change-time fullpath)))) (if (< real-age age) (with-input-from-file fullpath read) |
︙ | ︙ | |||
2482 2483 2484 2485 2486 2487 2488 | (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) (if (common:low-noise-print 300 "disks not a dir " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) | | | | 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 | (lambda (disk-num) (let* ((dirpath (cadr (assoc disk-num disks))) (freespc (cond ((not (directory? dirpath)) (if (common:low-noise-print 300 "disks not a dir " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) ((not (file-writable? dirpath)) (if (common:low-noise-print 300 "disks not writeable " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 300 "disks not a proper path " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) (else (get-df dirpath)))) (free-inodes (cond ((not (directory? dirpath)) (if (common:low-noise-print 300 "disks not a dir " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a directory - ignoring it.")) -1) ((not (file-writable? dirpath)) (if (common:low-noise-print 300 "disks not writeable " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not writeable - ignoring it.")) -1) ((not (eq? (string-ref dirpath 0) #\/)) (if (common:low-noise-print 300 "disks not a proper path " disk-num) (debug:print 0 *default-log-port* "WARNING: disk " disk-num " at path \"" dirpath "\" is not a fully qualified path - ignoring it.")) -1) |
︙ | ︙ | |||
2679 2680 2681 2682 2683 2684 2685 | (for-each (lambda (p) (let* ((var (car p)) (val (cadr p)) (prv (get-environment-variable var))) (set! res (cons (list var prv) res)) (if val (safe-setenv var (->string val)) | | | 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 | (for-each (lambda (p) (let* ((var (car p)) (val (cadr p)) (prv (get-environment-variable var))) (set! res (cons (list var prv) res)) (if val (safe-setenv var (->string val)) (unset-environment-variable! var)))) lst) res) '())) ;; clear vars matching pattern, run proc, set vars back ;; if proc is a string run that string as a command with |
︙ | ︙ | |||
2703 2704 2705 2706 2707 2708 2709 | (if (string-match "^MT_.*" (car x)) #f x)) envvars)))) (define (common:with-orig-env proc) (let ((current-env (get-environment-variables))) | | | | | | | | 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 | (if (string-match "^MT_.*" (car x)) #f x)) envvars)))) (define (common:with-orig-env proc) (let ((current-env (get-environment-variables))) (for-each (lambda (x) (unset-environment-variable! (car x))) current-env) (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) *common:orig-env*) (let ((rv (cond ((string? proc)(system proc)) (proc (proc))))) (for-each (lambda (x) (unset-environment-variable! (car x))) *common:orig-env*) (for-each (lambda (x) (set-environment-variable! (car x) (cdr x))) current-env) rv))) (define (common:without-vars proc . var-patts) (let ((vars (make-hash-table))) (for-each (lambda (vardat) ;; each env var (for-each (lambda (var-patt) (if (string-match var-patt (car vardat)) (let ((var (car vardat)) (val (cdr vardat))) (hash-table-set! vars var val) (unset-environment-variable! var)))) var-patts)) (get-environment-variables)) (cond ((string? proc)(system proc)) (proc (proc))) (hash-table-for-each vars (lambda (var val) (set-environment-variable! var val))) vars)) ;;====================================================================== ;; C O L O R S ;;====================================================================== |
︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 | (for-each (lambda (pktsdir) ;; look at all (cond ((not (common:file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) | | | 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 | (for-each (lambda (pktsdir) ;; look at all (cond ((not (common:file-exists? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory " pktsdir " does not exist.")) ((not (directory? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not a directory.")) ((not (file-readable? pktsdir)) (debug:print 0 *default-log-port* "ERROR: packets directory path " pktsdir " is not readable.")) (else (debug:print-info 0 *default-log-port* "Loading packets found in " pktsdir) (let ((pkts (glob (conc pktsdir "/*.pkt")))) (for-each (lambda (pkt) (let* ((uuid (cadr (string-match ".*/([0-9a-f]+).pkt" pkt))) |
︙ | ︙ | |||
3286 3287 3288 3289 3290 3291 3292 | (map (lambda (env-pair) (let* ((env-var (car env-pair)) (new-val (let ((tmp (cdr env-pair))) (if (list? tmp) (car tmp) tmp))) (current-val (get-environment-variable env-var)) (restore-thunk (cond | | | | | | 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 | (map (lambda (env-pair) (let* ((env-var (car env-pair)) (new-val (let ((tmp (cdr env-pair))) (if (list? tmp) (car tmp) tmp))) (current-val (get-environment-variable env-var)) (restore-thunk (cond ((not current-val) (lambda () (unset-environment-variable! env-var))) ((not (string? new-val)) #f) ((eq? current-val new-val) #f) (else (lambda () (set-environment-variable! env-var current-val)))))) ;;(when (not (string? new-val)) ;; (debug:print 0 *default-log-port* " PROBLEM: not a string: "new-val"\n from env-alist:\n"delta-env-alist) ;; (pp delta-env-alist) ;; (exit 1)) (cond ((not new-val) ;; modify env here (unset-environment-variable! env-var)) ((string? new-val) (set-environment-variable! env-var new-val))) restore-thunk)) delta-env-alist)))) (let ((rv (thunk))) (for-each (lambda (x) (x)) restore-thunks) ;; restore env to original state rv))) ;;====================================================================== |
︙ | ︙ |
Modified ulex/ulex.scm from [5d18895bb2] to [1c9abf93c8].
︙ | ︙ | |||
77 78 79 80 81 82 83 | (udat-captain-port-set! udata port) (udat-captain-pid-set! udata pid) (if (ping udata (conc ipaddr ":" port)) udata (begin (remove-captain-pkt udata captn) (setup)))) | > | > | | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | (udat-captain-port-set! udata port) (udat-captain-pid-set! udata pid) (if (ping udata (conc ipaddr ":" port)) udata (begin (remove-captain-pkt udata captn) (setup)))) (begin (setup-as-captain udata) ;; this saves the thread to captain-thread and starts the thread (setup))) )) ;; connect to a specific dbfile (define (connect udata dbfname dbtype) udata) (define (ping udata host-port) (let ((cookie (make-cookie udata))) (send udata host-port 'ping "just pinging" (conc (current-seconds))) ;; (mailbox-rec )) ;;====================================================================== ;; network utilities ;;====================================================================== |
︙ | ︙ | |||
439 440 441 442 443 444 445 | (send udata host:port "version" qrykey val))) ((rucaptain) (send udata host:port "iamcaptain" qrykey (if (udat-my-cpkt-key udata) "yes" "no"))) (else ;; (send-ack udata host:port qrykey) | | | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | (send udata host:port "version" qrykey val))) ((rucaptain) (send udata host:port "iamcaptain" qrykey (if (udat-my-cpkt-key udata) "yes" "no"))) (else ;; (send-ack udata host:port qrykey) (add-to-work-queue udata (get-peer-dat udata host:port) handlerkey qrykey data)))) (else (print "BAD DATA? controldat=" controldat " data=" data)))) (loop state))))) ;; add a proc to the handler list (define (register-handler udata key proc) (hash-table-set! (udat-handlers udata) key proc)) |
︙ | ︙ |