Megatest

Check-in [3d39f8f19d]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Cherrypick forward 07ba2e and 3e5f, chicken 5 work
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | v1.80-chicken5-stuff
Files: files | file ages | folders
SHA1: 3d39f8f19d1a955d8fd69e7dc5fc112775702a9f
User & Date: matt on 2023-04-06 20:22:00
Other Links: branch diff | manifest | tags
Context
2023-04-06
20:22
Cherrypick forward 07ba2e and 3e5f, chicken 5 work Leaf check-in: 3d39f8f19d user: matt tags: v1.80-chicken5-stuff
20:00
cleanup - 57d44 check-in: 5dac6d2e49 user: matt tags: v1.80
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified Makefile from [c999b5b258] to [96b6788682].

︙︙
43
44
45
46
47
48
49

50
51
52
53
54
55
56

	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

megatest.scm : transport-mode.scm
dashboard.scm : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here
mofiles/portlogger.o : mofiles/dbmod.o


mofiles/dbfile.o     : \
       mofiles/debugprint.o mofiles/commonmod.o

configf.o : commonmod.import.o
mofiles/dbfile.o : mofiles/debugprint.o
mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o








>








43
44
45
46
47
48
49
50
51
52
53
54
55
56
57

	cp dashboard-transport-mode.scm.template dashboard-transport-mode.scm

megatest.scm : transport-mode.scm
dashboard.scm : dashboard-transport-mode.scm

# dbmod.import.o is just a hack here
mofiles/portlogger.o : mofiles/dbmod.o
mofiles/dbfile.o     : mofiles/debugprint.o mofiles/commonmod.o

mofiles/dbfile.o     : \
       mofiles/debugprint.o mofiles/commonmod.o

configf.o : commonmod.import.o
mofiles/dbfile.o : mofiles/debugprint.o
mofiles/rmtmod.o mofiles/dbmod.o : mofiles/dbfile.o
︙︙

Modified dbfile.scm from [133c3d1663] to [45dd6a06ff].

︙︙
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


(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*
	
  (import scheme

	  chicken

	  data-structures
	  extras
	  matchable
  
	  (prefix sqlite3 sqlite3:)
	  posix typed-records

	  srfi-18
	  srfi-1
	  srfi-69
	  stack
	  files
	  ports
	  




	  commonmod












	  debugprint

	  )














;; parameters
;;
(define dbfile:testsuite-name (make-parameter #f))

(define keep-age-param        (make-parameter 10))      ;; qif file age, if over move to attic
(define num-run-dbs           (make-parameter 10))      ;; number of db's in .mtdb
(define dbfile:sync-method    (make-parameter 'attach)) ;; 'attach or 'original








|
|
>
|
>


<

<
|

<
<
<
<


|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
>
|
>
>
>

>
>
>
>
>
>
>
>
>
>








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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82


(declare (unit dbfile))
(declare (uses debugprint))
(declare (uses commonmod))

(module dbfile
	*

(import scheme)
(cond-expand
 (chicken-4
  (import chicken
	  data-structures
	  extras

  

	  posix





	  files
	  ports
	  )
  (define current-process-milliseconds current-milliseconds)
  )
  (chicken-5
   (import chicken.base
	   chicken.condition
	   chicken.file
	   chicken.file.posix
	   chicken.format
	   chicken.io
	   chicken.pathname
	   chicken.port
	   chicken.process
	   chicken.process-context.posix
	   chicken.sort
	   chicken.string
	   chicken.time
	   chicken.time.posix

	   system-information
	   )
   (define file-move move-file)
   (define file-write-access? file-writable?)
   ))

  (import (prefix sqlite3 sqlite3:))
  (import typed-records)
  (import srfi-18)
  (import srfi-1)
  (import srfi-69)
  (import stack)
  (import commonmod)
  (import debugprint)
  (import matchable)
  
;; parameters
;;
(define dbfile:testsuite-name (make-parameter #f))

(define keep-age-param        (make-parameter 10))      ;; qif file age, if over move to attic
(define num-run-dbs           (make-parameter 10))      ;; number of db's in .mtdb
(define dbfile:sync-method    (make-parameter 'attach)) ;; 'attach or 'original
︙︙
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855

                   readonly-slave-dbs))) -6)
    (else
     ;; (dbfile:print-err "db:sync-tables: args are good")

     (let ((stmts       (make-hash-table)) ;; table-field => stmt
	   (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	   (numrecs     (make-hash-table))
	   (start-time  (current-milliseconds))
	   (tot-count   0))
       (for-each ;; table
	(lambda (tabledat)
	  (let* ((tablename        (car tabledat))
		 (fields           (cdr tabledat))
		 (has-last-update  (member "last_update" fields))
		 (use-last-update  (cond








|








867
868
869
870
871
872
873
874
875
876
877
878
879
880
881

                   readonly-slave-dbs))) -6)
    (else
     ;; (dbfile:print-err "db:sync-tables: args are good")

     (let ((stmts       (make-hash-table)) ;; table-field => stmt
	   (all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	   (numrecs     (make-hash-table))
	   (start-time  (current-process-milliseconds))
	   (tot-count   0))
       (for-each ;; table
	(lambda (tabledat)
	  (let* ((tablename        (car tabledat))
		 (fields           (cdr tabledat))
		 (has-last-update  (member "last_update" fields))
		 (use-last-update  (cond
︙︙
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999

                 (if (member "last_update" field-names)
                    (db:create-trigger db tablename))))
	     (append (list todb) slave-dbs)
           )
          )
        )
	tbls)
       (let* ((runtime      (- (current-milliseconds) start-time))
	      (should-print (or ;; (debug:debug-mode 12)
			     (common:low-noise-print 120 "db sync")
			     (> runtime 500)))) ;; low and high sync times treated as separate.
	 (for-each 
	  (lambda (dat)
	    (let ((tblname (car dat))
		  (count   (cdr dat)))








|








1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025

                 (if (member "last_update" field-names)
                    (db:create-trigger db tablename))))
	     (append (list todb) slave-dbs)
           )
          )
        )
	tbls)
       (let* ((runtime      (- (current-process-milliseconds) start-time))
	      (should-print (or ;; (debug:debug-mode 12)
			     (common:low-noise-print 120 "db sync")
			     (> runtime 500)))) ;; low and high sync times treated as separate.
	 (for-each 
	  (lambda (dat)
	    (let ((tblname (car dat))
		  (count   (cdr dat)))
︙︙

Modified dbmod.scm from [08e196df1c] to [d4f33e15c4].

︙︙
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

(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses debugprint))

(module dbmod
	*
	
(import scheme

	chicken

	data-structures
	extras













	(prefix sqlite3 sqlite3:)
	posix
	typed-records
	srfi-1
	srfi-18
	srfi-69

	commonmod
	dbfile
	debugprint
	)

;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
(define (dbmod:run-id->dbfname run-id)
  (conc (dbfile:run-id->dbnum run-id)".db"))

(define (dbmod:get-dbdir dbstruct)








|
>
|
>
|
|
>
|
>
>
>
>
>
>
>
>
>
>
>
|
<
|
|
|
|
<
|
|
|
<








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

(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses debugprint))

(module dbmod
	*
	
(import scheme)
(cond-expand
 (chicken-4
  (import chicken
	  data-structures
	  extras
	  posix
	  )
  (define current-process-milliseconds current-milliseconds)
  )
 (chicken-5
  (import chicken.base
	  chicken.file
	  chicken.sort
	  chicken.string
	  chicken.time
	  
	  )))

(import (prefix sqlite3 sqlite3:))

(import typed-records)
(import srfi-1)
(import srfi-18)
(import srfi-69)

(import commonmod)
(import dbfile)
(import debugprint)


;; NOTE: This returns only the name "1.db", "main.db", not the path
;;
(define (dbmod:run-id->dbfname run-id)
  (conc (dbfile:run-id->dbnum run-id)".db"))

(define (dbmod:get-dbdir dbstruct)
︙︙
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250

;;
(define (dbmod:sync-tables tbls last-update fromdb todb)
  (assert (sqlite3:database? fromdb) "FATAL: dbmod:sync-tables called with fromdb not a database" fromdb)
  (assert (sqlite3:database? todb) "FATAL: dbmod:sync-tables called with fromdb not a database" todb)
  (let ((stmts       (make-hash-table)) ;; table-field => stmt
	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-milliseconds))
	(tot-count   0))
    (for-each ;; table
     (lambda (tabledat)
       (let* ((tablename        (car tabledat))
	      (fields           (cdr tabledat))
	      (has-last-update  (member "last_update" fields))
	      (use-last-update  (dbmod:calc-use-last-update has-last-update fields last-update))








|








247
248
249
250
251
252
253
254
255
256
257
258
259
260
261

;;
(define (dbmod:sync-tables tbls last-update fromdb todb)
  (assert (sqlite3:database? fromdb) "FATAL: dbmod:sync-tables called with fromdb not a database" fromdb)
  (assert (sqlite3:database? todb) "FATAL: dbmod:sync-tables called with fromdb not a database" todb)
  (let ((stmts       (make-hash-table)) ;; table-field => stmt
	(all-stmts   '())              ;; ( ( stmt1 value1 ) ( stml2 value2 ))
	(numrecs     (make-hash-table))
	(start-time  (current-process-milliseconds))
	(tot-count   0))
    (for-each ;; table
     (lambda (tabledat)
       (let* ((tablename        (car tabledat))
	      (fields           (cdr tabledat))
	      (has-last-update  (member "last_update" fields))
	      (use-last-update  (dbmod:calc-use-last-update has-last-update fields last-update))
︙︙
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365

	    fromdats)
	   
	   (sqlite3:finalize! stmth)
           (if (member "last_update" field-names)
               (db:create-trigger db tablename)))
	 ))
     tbls)
    (let* ((runtime      (- (current-milliseconds) start-time))
	   (should-print (or ;; (debug:debug-mode 12)
			  (common:low-noise-print 120 "db sync")
			  (> runtime 500)))) ;; low and high sync times treated as separate.
      (for-each 
       (lambda (dat)
	 (let ((tblname (car dat))
	       (count   (cdr dat)))








|








362
363
364
365
366
367
368
369
370
371
372
373
374
375
376

	    fromdats)
	   
	   (sqlite3:finalize! stmth)
           (if (member "last_update" field-names)
               (db:create-trigger db tablename)))
	 ))
     tbls)
    (let* ((runtime      (- (current-process-milliseconds) start-time))
	   (should-print (or ;; (debug:debug-mode 12)
			  (common:low-noise-print 120 "db sync")
			  (> runtime 500)))) ;; low and high sync times treated as separate.
      (for-each 
       (lambda (dat)
	 (let ((tblname (car dat))
	       (count   (cdr dat)))
︙︙
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449

			    ","))
		  (stmt1 (conc "INSERT OR IGNORE INTO "todb table
			       " SELECT * FROM "fromdb table";"))
		  (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table" WHERE "todb table".id="fromdb table".id"
			       (if (member "last_update" fields)
				   (conc " AND "fromdb table".last_update > "todb table".last_update);")
				   ");")))
		  (start-ms (current-milliseconds)))
	     ;; (debug:print 0 *default-log-port* "stmt8="stmt8)
	     ;; (if (sqlite3:auto-committing? dbh)
	     ;; (begin
	     (mutex-lock! *db-transaction-mutex*)
	     (sqlite3:with-transaction
	      dbh
	      (lambda ()
		(debug:print-info 0 *default-log-port* "Sync from "fromdb table" to "todb table" using "stmt1)
		(sqlite3:execute dbh stmt1)    ;; get all new rows
		
		#;(if (member "last_update" fields)
		(sqlite3:execute dbh stmt8))    ;; get all updated rows
		;; (sqlite3:execute dbh stmt5)
		;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up
		;; (sqlite3:execute dbh stmt6)
		))
	     (debug:print 0 *default-log-port* "Synced table "table
			  " in "(- (current-milliseconds) start-ms)"ms") ;; )
	     (mutex-unlock! *db-transaction-mutex*)))
	     
	 ;; (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight."))))
	 table-names)
	(sqlite3:execute dbh "DETACH auxdb;"))))

;; FAILED ATTEMPTS








|

















|








428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460

			    ","))
		  (stmt1 (conc "INSERT OR IGNORE INTO "todb table
			       " SELECT * FROM "fromdb table";"))
		  (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table" WHERE "todb table".id="fromdb table".id"
			       (if (member "last_update" fields)
				   (conc " AND "fromdb table".last_update > "todb table".last_update);")
				   ");")))
		  (start-ms (current-process-milliseconds)))
	     ;; (debug:print 0 *default-log-port* "stmt8="stmt8)
	     ;; (if (sqlite3:auto-committing? dbh)
	     ;; (begin
	     (mutex-lock! *db-transaction-mutex*)
	     (sqlite3:with-transaction
	      dbh
	      (lambda ()
		(debug:print-info 0 *default-log-port* "Sync from "fromdb table" to "todb table" using "stmt1)
		(sqlite3:execute dbh stmt1)    ;; get all new rows
		
		#;(if (member "last_update" fields)
		(sqlite3:execute dbh stmt8))    ;; get all updated rows
		;; (sqlite3:execute dbh stmt5)
		;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up
		;; (sqlite3:execute dbh stmt6)
		))
	     (debug:print 0 *default-log-port* "Synced table "table
			  " in "(- (current-process-milliseconds) start-ms)"ms") ;; )
	     (mutex-unlock! *db-transaction-mutex*)))
	     
	 ;; (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight."))))
	 table-names)
	(sqlite3:execute dbh "DETACH auxdb;"))))

;; FAILED ATTEMPTS
︙︙
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538

		  ;; (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table " WHERE "todb table".id="fromdb table".id"
		  ;; 	       (if (member "last_update" fields)
		  ;; 		   (conc " AND "fromdb table".last_update > "todb table".last_update);")
		  ;; 		   ");")))
		  (stmt1    (conc "SELECT MAX(last_update) FROM "table";")) ;; use the highest last_update as your time reference
		  (stmt2    (conc "SELECT no-id-fields-str FROM "table" WHERE last_update>?;"))
		  (stmt3    (conc "UPDATE "table" SET ("no-id-fields-str") = ("questionmarks") WHERE id=?;"))
		  (start-ms (current-milliseconds)))
	     (debug:print 0 *default-log-port* "stmt3="stmt3)
	     (if (sqlite3:auto-committing? dbh1)
		 (begin
		   (sqlite3:with-transaction
		    dbh1
		    (lambda ()
		      (sqlite3:execute dbh1 stmt1)    ;; get all new rows

		      #;(if (member "last_update" fields)
			  (sqlite3:execute dbh1 stmt8))    ;; get all updated rows
		      ;; (sqlite3:execute dbh stmt5)
		      ;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up
		      ;; (sqlite3:execute dbh stmt6)
		      ))
		   (debug:print 0 *default-log-port* "Synced table "table
				" in "(- (current-milliseconds) start-ms)"ms"))
		 (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight."))))
	 table-names)
	(sqlite3:execute dbh1 "DETACH auxdb;"))))












|















|








519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549

		  ;; (stmt8 (conc "UPDATE "todb table" SET ("no-id-fields-str") = (SELECT "no-id-fields-str" FROM "fromdb table " WHERE "todb table".id="fromdb table".id"
		  ;; 	       (if (member "last_update" fields)
		  ;; 		   (conc " AND "fromdb table".last_update > "todb table".last_update);")
		  ;; 		   ");")))
		  (stmt1    (conc "SELECT MAX(last_update) FROM "table";")) ;; use the highest last_update as your time reference
		  (stmt2    (conc "SELECT no-id-fields-str FROM "table" WHERE last_update>?;"))
		  (stmt3    (conc "UPDATE "table" SET ("no-id-fields-str") = ("questionmarks") WHERE id=?;"))
		  (start-ms (current-process-milliseconds)))
	     (debug:print 0 *default-log-port* "stmt3="stmt3)
	     (if (sqlite3:auto-committing? dbh1)
		 (begin
		   (sqlite3:with-transaction
		    dbh1
		    (lambda ()
		      (sqlite3:execute dbh1 stmt1)    ;; get all new rows

		      #;(if (member "last_update" fields)
			  (sqlite3:execute dbh1 stmt8))    ;; get all updated rows
		      ;; (sqlite3:execute dbh stmt5)
		      ;; (sqlite3:execute dbh stmt4) ;; if it worked this would be better for incremental up
		      ;; (sqlite3:execute dbh stmt6)
		      ))
		   (debug:print 0 *default-log-port* "Synced table "table
				" in "(- (current-process-milliseconds) start-ms)"ms"))
		 (debug:print 0 *default-log-port* "Skipping sync of table "table" due to transaction in flight."))))
	 table-names)
	(sqlite3:execute dbh1 "DETACH auxdb;"))))
︙︙

Modified tcp-transportmod.scm from [2389278b99] to [c4cf69e693].

︙︙
21
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
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89

(declare (unit tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses portlogger))

(use address-info)

(module tcp-transportmod
	*
	
  (import scheme
	  (prefix sqlite3 sqlite3:)
	  chicken

	  data-structures

	  address-info
	  directory-utils
	  extras
	  files
	  hostinfo
	  matchable
	  md5
	  message-digest
	  ports
	  posix
	  regex


	  regex-case
	  s11n
	  srfi-1
	  srfi-18
	  srfi-4
	  srfi-69
	  stack
	  typed-records
	  tcp-server
	  tcp
	  


	  debugprint
	  commonmod
	  dbfile

	  dbmod
	  portlogger
	)























;;======================================================================
;; client
;;======================================================================

;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic

;; Used ONLY for client
;;
(defstruct tt-conn
  host
  port
  host-port
  dbfname
  server-id
  server-start
  pid
)

;; Used for BOTH clients and servers
(defstruct tt
  ;; client related
  (conns (make-hash-table)) ;; dbfname -> conn









<
<



|
|
|
>

<
|
<


|
<
<
<


|
>
>
|
|
|
|
<
<
|
|
<
|
|
>
>
|
<
|
>
|

|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>










|
|
|
|
|
|
|








21
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
68
69
70
71
72
73
74
75
76
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
103
104
105
106

(declare (unit tcp-transportmod))
(declare (uses debugprint))
(declare (uses commonmod))
(declare (uses dbfile))
(declare (uses dbmod))
(declare (uses portlogger))



(module tcp-transportmod
	*
	
(import scheme)
(cond-expand
 (chicken-4
  (import chicken
	  data-structures

	  hostinfo

	  extras
	  files
	  directory-utils



	  ports
	  posix
          portlogger
	  ))
 (chicken-5
  (import chicken.base
	  chicken.condition
	  chicken.file
	  chicken.file.posix


	  chicken.io
	  chicken.port

	  chicken.process
	  chicken.process-context
	  chicken.process-context.posix
	  chicken.sort
	  chicken.string

	  chicken.time
	  system-information
	  socket
	  portlogger
	  )
  (define unsetenv unset-environment-variable!)))
  
(import (prefix sqlite3 sqlite3:))
(import address-info)
(import matchable)
(import md5)
(import message-digest)
(import regex)
(import regex-case)
(import s11n)
(import srfi-1)
(import srfi-18)
(import srfi-4)
(import srfi-69)
(import stack)
(import typed-records)
(import tcp-server)
(import tcp6)
(import debugprint)
(import commonmod)
(import dbfile)
(import dbmod)

;;======================================================================
;; client
;;======================================================================

;; (define keep-age-param (make-parameter 10)) ;; qif file age, if over move to attic

;; Used ONLY for client
;;
(defstruct tt-conn
  (host #f)
  (port #f)
  (host-port #f)
  (dbfname #f)
  (server-id #f)
  (server-start #f)
  (pid #f)
)

;; Used for BOTH clients and servers
(defstruct tt
  ;; client related
  (conns (make-hash-table)) ;; dbfname -> conn
︙︙
690
691
692
693
694
695
696
697
698


699
700
701
702
703
704
705
706
707
708
709




710










711
712
713
714
715
716
717

  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list areapath
                                          (current-process-id)
					  (argv)))))))


(define (tt:get-best-guess-address hostname)


  (let ((res #f))
    (for-each 
     (lambda (adr)
       (if (not (eq? (u8vector-ref adr 0) 127))
	   (set! res adr)))
     ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
     (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
    (string-intersperse 
     (map number->string
	  (u8vector->list
	   (if res res (hostname->ip hostname)))) ".")))















(define (tt:get-servinfo-dir areapath)
  (let* ((spath (conc areapath"/.servinfo")))
    (if (not (file-exists? spath))
	(create-directory spath #t))
    spath))

;;======================================================================








<

>
>
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>








707
708
709
710
711
712
713

714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749

  (message-digest-string (md5-primitive) 
			 (with-output-to-string
			   (lambda ()
			     (write (list areapath
                                          (current-process-id)
					  (argv)))))))


(define (tt:get-best-guess-address hostname)
  (cond-expand
   (chicken-4
    (let ((res #f))
      (for-each 
       (lambda (adr)
	 (if (not (eq? (u8vector-ref adr 0) 127))
	     (set! res adr)))
       ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME
       (vector->list (hostinfo-addresses (hostname->hostinfo hostname))))
      (string-intersperse 
       (map number->string
	    (u8vector->list
	     (if res res (hostname->ip hostname)))) ".")))
   (chicken-5
    (let* ((get-first (lambda (str) ;; "1.2.3.4" => 1, but "127.1.2.3 => 0 so it sorts last
			(let* ((res (string->number (car (string-split str ".")))))
			  (if (eq? res 127)
			      0
			      res))))
	   (addresses (sort
		       (map address-info-host (address-infos hostname))
		       (lambda (a b)
			 (let* ((a-first (get-first a))
				(b-first (get-first b)))
			   (> a-first b-first))))))
      (car addresses)))))
    
  
(define (tt:get-servinfo-dir areapath)
  (let* ((spath (conc areapath"/.servinfo")))
    (if (not (file-exists? spath))
	(create-directory spath #t))
    spath))

;;======================================================================
︙︙

This page was generated in about 0.132s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00