本帖最后由 dcl1214 于 2025-9-12 11:40 编辑

为了让更多的lisp同仁可以学习在线更新方法，所以，才分享以下完整代码
温馨提示：
1 你可以将下面的代码放到你的服务器后台的
2 给你的客户只需要几句代码即可
3 如果希望做到vlx实时更新加载，请看我其他帖子（二进制流模式加载）

  1. (progn
  2.   (setq  config
  3.    (list
  4.      (cons "下载地址"
  5.      "http://大不了大不了大不了点康姆/download_post"
  6.      )
  7.      (cons "查询数据库地址"
  8.      "http://大不了大不了大不了点康姆/select"
  9.      )
  10.      (cons "数据库表名" "zxcadapp")
  11.      (cons "需要独立加载的文件" "cad/run.lsp")
  12.      (cons
  13.        "备注"
  14.        "①如果担心服务器遭洪水攻击可以通过入站规则设定②数据库的表名是随意更换的，你可以给每一个用户配一个表名③如果想限制某一个用户使用软件可以通过ngx设定"
  15.      )
  16.    )
  17.   )
  18.   (defun $pin-jie$
  19.    (strs fgf / a bars len str str str-last strs-car strs-n)
  20.     (if  (and strs
  21.        fgf
  22.        (= (type strs) 'list)
  23.        (setq strs (vl-remove nil strs))
  24.        (setq strs-car (CAR strs))
  25.        (= (type strs-car) 'STR)
  26.        (= (type fgf) 'str)
  27.   )
  28.       (progn
  29.   (setq strs (cdr strs))
  30.   (setq strs (reverse strs))
  31.   (setq strs-n nil)
  32.   (while (setq a (car strs))
  33.     (setq strs-n (cons a strs-n))
  34.     (setq strs-n (cons fgf strs-n))
  35.     (setq strs (cdr strs))
  36.   )
  37.   (setq strs-n (cons strs-car strs-n))
  38.   (setq str (vl-catch-all-apply 'apply (list 'strcat strs-n)))
  39.   (if (vl-catch-all-error-p str)
  40.     (progn
  41.       (setq
  42.         strs-n (mapcar
  43.            (function (lambda (a)
  44.            (if (and a (/= (type a) 'str))
  45.              (setq a (vl-prin1-to-string a))
  46.            )
  47.            a
  48.          )
  49.            )
  50.            strs-n
  51.          )
  52.       )
  53.       (setq str (vl-catch-all-apply 'apply (list 'strcat strs-n)))
  54.       (if  (vl-catch-all-error-p str)
  55.         (setq str nil)
  56.       )
  57.     )
  58.   )
  59.       )
  60.     )
  61.     str
  62.   )
  63.   (defun $make-file$ (file / a s f)
  64.     (if  file
  65.       (progn
  66.   (if (wcmatch file "[,*`/*,]")
  67.     (setq s ($zi-chuan-fen-ge$ file "/"))
  68.     (setq s ($zi-chuan-fen-ge$ file "\\"))
  69.   )
  70.   (setq old "")
  71.   (setq f nil)
  72.   (while (setq a (car s))
  73.     (if f
  74.       (setq f (strcat f "/" a))
  75.       (setq f a)
  76.     )
  77.     (if (findfile f)
  78.       ()
  79.       (vl-mkdir f)
  80.     )
  81.     (setq s (cdr s))
  82.   )
  83.       )
  84.     )
  85.     f
  86.   )
  87.   (defun $zi-chuan-fen-ge$ (str delim / lst i STRS len)
  88.     (if  (AND str
  89.        delim
  90.        (= (type str) 'str)
  91.        (= (type delim) 'str)
  92.        (> (strlen delim) 0)
  93.   )
  94.       (progn
  95.   (setq len (strlen delim))
  96.   (while (setq i (vl-string-search delim str))
  97.     (setq lst (cons (substr str 1 i) lst))
  98.     (setq str (substr str (+ 1 len i)))
  99.   )
  100.   (setq lst (cons str lst))
  101.   (setq strs (reverse lst))
  102.       )
  103.       (if str
  104.   (setq strs (list str))
  105.       )
  106.     )
  107.     strs
  108.   )
  109.   (defun $http-server$ (lst      /    $write-bin-stream$
  110.       array&str   content  dey      err-str
  111.       get&post    host  hs      jg
  112.       jg-read      jgs    objhttp      return-value
  113.       save-p      send-zt  status      str
  114.       value      value-text
  115.            )
  116.     (defun $Write-Bin-Stream$ (filename data / ADOStream result xzjg)
  117.       (IF DATA
  118.   (PROGN
  119.     (if (setq ADOStream (vl-catch-all-apply
  120.         'vlax-create-object
  121.         (list "ADODB.Stream")
  122.             )
  123.         )
  124.       (progn
  125.         (vl-catch-all-apply 'vl-file-delete (list filename))
  126.         (vl-catch-all-apply
  127.     'vlax-put-property
  128.     (list ADOStream 'type 1)
  129.         )
  130.         (vl-catch-all-apply
  131.     'vlax-invoke
  132.     (list ADOStream 'open)
  133.         )
  134.         (vl-catch-all-apply
  135.     'vlax-invoke-method
  136.     (list ADOStream 'write data)
  137.         )
  138.         (setq result (vl-catch-all-apply
  139.            'vlax-invoke
  140.            (list ADOStream 'savetofile filename 2)
  141.          )
  142.         )
  143.         (if (and ADOStream
  144.            (vlax-method-applicable-p ADOStream 'close)
  145.       )
  146.     (vl-catch-all-apply
  147.       'vlax-invoke-method
  148.       (list ADOStream 'close)
  149.     )
  150.     (print "stream close error")
  151.         )
  152.         (IF ADOStream
  153.     (vl-catch-all-apply
  154.       'vlax-release-object
  155.       (list ADOStream)
  156.     )
  157.         )
  158.         (if (vl-catch-all-error-p result)
  159.     (print (vl-catch-all-error-message result))
  160.     (IF (FINDFILE filename)
  161.       (progn
  162.         (if  (= (vl-file-size filename) 0)
  163.           (progn
  164.       (vl-catch-all-apply
  165.         'vl-file-delete
  166.         (list filename)
  167.       )
  168.       (setq xzjg nil)
  169.           )
  170.           (setq xzjg filename)
  171.         )
  172.       )
  173.     )
  174.         )
  175.       )
  176.     )
  177.   )
  178.       )
  179.       xzjg
  180.     )
  181.     (or  (setq host (cdr (assoc "IP" lst)))
  182.   (setq host (cdr (assoc "ip" lst)))
  183.     )
  184.     (if  (not host)
  185.       (print "没传递ip地址(ip带端口号和方法名)")
  186.     )
  187.     (setq GET&POST "POST")
  188.     (setq content (cdr (assoc "content" lst)))
  189.     (if  (not content)
  190.       (print "没传递content")
  191.     )
  192.     (setq array&str (cdr (assoc "返回格式" lst)))
  193.     (or array&str (setq array&str "POST"))
  194.     (setq hs (cdr (assoc "报文头" lst)))
  195.     (setq hs (cons (cons "Client-Auth" (getenv "ComputerName")) hs))
  196.     (setq hs (cons (cons "Response-Charset" "UTF8") hs))
  197.     (and
  198.       host
  199.       (progn
  200.   (SETQ str "")
  201.   (and
  202.     (setq  objHttp  (vl-catch-all-apply
  203.         (function
  204.           (lambda ()
  205.             (vlax-create-object
  206.         "winhttp.winhttprequest.5.1"
  207.             )
  208.           )
  209.         )
  210.       )
  211.     )
  212.     (PROGN
  213.       (setq return-value nil)
  214.       (if
  215.         (IF (vl-catch-all-error-p
  216.         (SETQ return-value
  217.          (vl-catch-all-apply
  218.            'vla-open
  219.            (list objHttp GET&POST host 0)
  220.          )
  221.         )
  222.       )
  223.     (progn (print (vl-catch-all-error-message return-value))
  224.            (vlax-release-object objHttp)
  225.            (setq objHttp nil)
  226.            (setq return-value nil)
  227.            nil
  228.     )
  229.     t
  230.         )
  231.          (PROGN
  232.      (if
  233.        (progn
  234.          (mapcar (function (lambda (a)
  235.            (if (and (car a) (cdr a))
  236.              (progn
  237.                (vl-catch-all-apply
  238.                  'vlax-invoke-method
  239.                  (list objHttp
  240.                  "setRequestHeader"
  241.                  (car a)
  242.                  (cdr a)
  243.                  )
  244.                )
  245.              )
  246.            )
  247.                )
  248.            )
  249.            hs
  250.          )
  251.          (or content (setq content ""))
  252.          (SETQ value
  253.           (vl-catch-all-apply
  254.             'vlax-invoke-method
  255.             (list objHttp "send" content)
  256.           )
  257.          )
  258.          (if (vl-catch-all-error-p value)
  259.            (progn
  260.        (setq
  261.          err-str (vl-catch-all-error-message value)
  262.        )
  263.        (print err-str)
  264.        (vlax-release-object objHttp)
  265.        (setq objHttp nil)
  266.        (setq send-zt nil)
  267.            )
  268.            (setq send-zt t)
  269.          )
  270.          (setq value nil)
  271.          send-zt
  272.        )
  273.         (PROGN
  274.           (setq dey 1)
  275.           (while (and dey (< dey 50000))
  276.       (cond
  277.         ((and  (setq status (vl-catch-all-apply
  278.                  'vlax-get-property
  279.                  (list objHttp "status")
  280.                )
  281.         )
  282.         (not (vl-catch-all-error-p status))
  283.         (= status 200)
  284.          )
  285.          (setq dey nil)
  286.         )
  287.         (t (repeat 200))
  288.       )
  289.       (if dey
  290.         (setq dey (1+ dey))
  291.       )
  292.           )
  293.           (if (= status 200)
  294.       (progn
  295.         (if
  296.           (VL-POSITION
  297.             array&str
  298.             (list "sz" "SZ" "数组")
  299.           )
  300.            (progn (setq jg
  301.              (vlax-get-property objHttp 'responsebody)
  302.             )
  303.             (setq value-text nil)
  304.            )
  305.            (PROGN
  306.              (and
  307.          (OR
  308.            (and
  309.              (setq value-text
  310.               (vl-catch-all-apply
  311.                 'vlax-get-property
  312.                 (list objHttp 'responseText)
  313.               )
  314.              )
  315.              (not (vl-catch-all-error-p value-text)
  316.              )
  317.              (setq status t)
  318.            )
  319.          )
  320.          (progn (setq jg value-text))
  321.              )
  322.              (IF (vl-catch-all-error-p value-text)
  323.          (SETQ value-text NIL)
  324.              )
  325.            )
  326.         )
  327.       )
  328.           )
  329.         )
  330.      )
  331.          )
  332.       )
  333.     )
  334.   )
  335.   (if objHttp
  336.     (vl-catch-all-error-p
  337.       (vl-catch-all-apply 'vlax-release-object (list objHttp))
  338.     )
  339.   )
  340.   (and jg
  341.        (= (type jg) 'str)
  342.        (setq jg-read (vl-catch-all-apply
  343.            'read
  344.            (list (STRCAT "(" jg ")"))
  345.          )
  346.        )
  347.        (not (vl-catch-all-error-p jg-read))
  348.        (= (TYPE (car jg-read)) 'LIST)
  349.        (setq jgs jg-read)
  350.   )
  351.   (cond
  352.     ((and
  353.        array&str
  354.        (VL-POSITION array&str (list "点表" "db" "DB"))
  355.      )
  356.      (setq jgs (cdar jg-read))
  357.     )
  358.     ((and
  359.        (= (type jg) 'VARIANT)
  360.        (setq save-p (cdr (assoc "保存路径" lst)))
  361.      )
  362.      (vl-catch-all-apply 'vl-file-delete (list save-p))
  363.      (IF (and (FINDFILE save-p) (vl-filename-extension save-p))
  364.        (print "有同名文件无法删除导致无法保存文件")
  365.        (SETQ JGs ($Write-Bin-Stream$ save-p JG))
  366.      )
  367.     )
  368.   )
  369.       )
  370.     )
  371.     JGs
  372.   )
  373.   (defun $cha-xun-wen-jian$ (ip tbn sql / data)
  374.     (or  sql
  375.   (and tbn
  376.        (SETQ SQL
  377.         (strcat
  378.           "SELECT * FROM " tbn
  379.           " WHERE CAST(版本 AS CHAR) = (SELECT CAST(版本 AS CHAR) FROM "
  380.           tbn
  381.           " ORDER BY CASE
  382.       WHEN 版本 REGEXP '^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+$' THEN
  383.         CAST(SUBSTRING_INDEX(版本, '.', 1) AS UNSIGNED) * 1000000 +
  384.         CAST(SUBSTRING_INDEX(SUBSTRING_INDEX(版本, '.', 2), '.', -1) AS UNSIGNED) * 10000 +
  385.         CAST(SUBSTRING_INDEX(SUBSTRING_INDEX(版本, '.', 3), '.', -1) AS UNSIGNED) * 100 +
  386.         CAST(SUBSTRING_INDEX(版本, '.', -1) AS UNSIGNED)
  387.       WHEN CAST(版本 AS CHAR) REGEXP '^[0-9]+$' THEN
  388.         CAST(版本 AS UNSIGNED)
  389.       ELSE ASCII(SUBSTRING_INDEX(版本, ' ', 1)) * 10000 +
  390.         ASCII(SUBSTRING_INDEX(SUBSTRING_INDEX(版本, ' ', 2), ' ', -1)) * 100 +
  391.         ASCII(SUBSTRING_INDEX(版本, ' ', -1)) END DESC  LIMIT 1)")
  392.        )
  393.   )
  394.     )
  395.     (if  ip
  396.       (setq
  397.   data ($http-server$
  398.          (list
  399.      (cons "IP" ip)
  400.      (cons "content" sql)
  401.      (cons "返回格式" "DB")
  402.      (CONS "报文头" (list (cons "why" "查询软件包")))
  403.          )
  404.        )
  405.       )
  406.     )
  407.     data
  408.   )
  409.   (DEFUN c:zxcadi
  410.       (config   /       a        ip       ip2
  411.        loc-file loc-files        n         web-file
  412.        wjs      zxcad-f  zxcadapp
  413.       )
  414.     (SETQ IP (cdr (assoc "下载地址" config)))
  415.     (setq ip2 (cdr (assoc "查询数据库地址" config)))
  416.     (if  (not (getenv "zxcad-f"))
  417.       (setenv
  418.   "zxcad-f"
  419.   (strcat (getenv "systemdrive") "\\Changli_harness_software")
  420.       )
  421.     )
  422.     (setq zxcadapp (cdr (assoc "数据库表名" config)))
  423.     (setq zxcad-f (getenv "zxcad-f"))
  424.     (setq zxcad-f (vl-string-translate "\\" "/" zxcad-f))
  425.     (setq wjs ($cha-xun-wen-jian$ ip2 zxcadapp nil))
  426.     (while (setq a (car wjs))
  427.       (setq size-web nil
  428.       size-loc nil
  429.       )
  430.       (setq n (cdr (assoc "名称" a)))
  431.       (setq web-file (cdr (assoc "路径" a)))
  432.       (and (setq size-str (cdr (assoc "字节数" a)))
  433.      (setq size-web (atoi size-str))
  434.       )
  435.       (setq loc-file (cdr (assoc "客户端路径" a)))
  436.       (setq loc-files ($zi-chuan-fen-ge$ loc-file "/"))
  437.       (setq loc-files (vl-remove "{app}" loc-files))
  438.       (setq loc-files (cons zxcad-f loc-files))
  439.       (setq loc-file ($pin-jie$ loc-files "/"))
  440.       (if (findfile loc-file)
  441.   (vl-file-delete loc-file)
  442.       )
  443.       ($make-file$ loc-file)
  444.       (setq loc-file (strcat loc-file "/" n))
  445.       (and loc-file
  446.      (findfile loc-file)
  447.      (setq size-loc (vl-file-size loc-file))
  448.       )
  449.       (if (and size-loc size-web (= size-loc size-web))
  450.   (print (strcat loc-file " 与服务器字节数相等不予下载更新"))
  451.   (progn
  452.     ($http-server$
  453.       (list
  454.         (cons "IP" IP)
  455.         (cons "content" web-file)
  456.         (cons "返回格式" "数组")
  457.         (cons "保存路径" loc-file)
  458.       )
  459.     )
  460.   )
  461.       )
  462.       (PRINT loc-file)
  463.       (setq wjs (cdr wjs))
  464.     )
  465.     (vl-catch-all-apply
  466.       'load
  467.       (list (findfile (strcat (getenv "zxcad-f") "\\startup.vlx"))
  468.       )
  469.     )
  470.     T
  471.   )
  472.   (IF
  473.     (c:zxcadi config)
  474.      ()
  475.      (PROGN
  476.        (setq web-file (cdr (assoc "需要独立加载的文件" config)))
  477.        (setq
  478.    lsp-f (vl-filename-mktemp
  479.      (STRCAT (GETENV "PUBLIC") "\\run.lsp")
  480.          )
  481.        )
  482.        (if web-file
  483.    ($http-server$
  484.      (list
  485.        (cons "IP" (cdr (assoc "下载地址" config)))
  486.        (cons "content" web-file)
  487.        (cons "返回格式" "数组")
  488.        (cons "保存路径" lsp-f)
  489.      )
  490.    )
  491.        )
  492.        (if (and lsp-f (findfile lsp-f))
  493.    (progn
  494.      (print lsp-f)
  495.      (setq load-zt (vl-catch-all-apply 'load (list lsp-f)))
  496.      (if (vl-catch-all-error-p load-zt)
  497.        (print (strcat "加载: " lsp-f "  失败"))
  498.      )
  499.    )
  500.        )
  501.        (vl-catch-all-apply 'vl-file-delete (list lsp-f))
  502.      )
  503.   )
  504.   (setq ts nil)
  505.   (setq lsp-f nil)
  506.   (setq load-zt nil)
  507.   (setq web-file nil)
  508.   (setq lsp-f nil)
  509.   (setq load-zt nil)
  510.   (setq $pin-jie$ nil)
  511.   (setq $make-file$ nil)
  512.   (setq $zi-chuan-fen-ge$ nil)
  513.   (setq $cha-xun-wen-jian$ nil)
  514.   (setq $http-server$ nil)
  515.   (setq c:zxcadi nil)
  516.   (setq config nil)
  517. )




网友答: 本帖最后由 kozmosovia 于 2025-9-12 10:37 编辑
dcl1214 发表于 2025-9-12 09:26
很多软件的更新都是一个单独的update.exe在执行的，独立的一个程序

外部更新EXE的执行关lisp啥事？还能执行完了自动找到运行的CAD并拦截中断用户正在画图的操作，自动启动执行lisp吗？要不能，那和画图时开个播放音乐的EXE有啥区别？有啥lisp技术在里面？
标题是更新lisp软件方法，难不成还需要把lisp编译成exe执行吗？搞笑呢吧


网友答: 要是lisp有异步就好了, 先天不足, 做这个挺累

网友答: 本帖最后由 dcl1214 于 2025-9-11 22:32 编辑
22693766 发表于 2025-9-11 22:27
要是lisp有异步就好了, 先天不足, 做这个挺累

支持异步的，看你怎么设计了，比如说，你支持一个wget，或者是curl
查询数据库的文件记录，只需要1秒，接下来交给curl，lisp发布的vlx文件，在cad不关闭的情况下，支持覆盖的，而且还支持不重启cad的情况下二次加载vlx


网友答:
dcl1214 发表于 2025-9-11 22:29
支持异步的，看你怎么设计了，比如说，你支持一个wget，或者是curl
查询数据库的文件记录，只需要1秒， ...

我找了好久都没找到lisp的异步方法,
比如访问网络, 如果网络慢就只能阻塞干等
我倒是看到猫老师用技巧实现假线程, 不知道实际操作咋样.

网友答: 本帖最后由 dcl1214 于 2025-9-11 22:47 编辑
22693766 发表于 2025-9-11 22:43
我找了好久都没找到lisp的异步方法,
比如访问网络, 如果网络慢就只能阻塞干等
我倒是看到猫老师用技巧 ...

curl支持断点续传呀，断点续传的时候，不影响你使用cad的，比如说vlx文件，因为cad的vlx一旦编译成了【独立空间】模式，该vlx是支持一边使用一边更新的
实在不行，就玩流模式的方法，实时加载的，而且没有任何文件痕迹


网友答: 一个面向过程的编程语言能支持异步，怕是对异步有误解

网友答: 有时间普及一下服务器的知识，知识盲区

网友答:
kozmosovia 发表于 2025-9-11 23:03
一个面向过程的编程语言能支持异步，怕是对异步有误解

很多软件的更新都是一个单独的update.exe在执行的，独立的一个程序

网友答: 本帖最后由 dcl1214 于 2025-9-12 11:40 编辑
kozmosovia 发表于 2025-9-12 10:33
外部更新EXE的执行关lisp啥事？还能执行完了自动找到运行的CAD并拦截中断用户正在画图的操作，自动启动执 ...

vlx支持一边更新一遍做图，不影响画图，也不影响更新，两个同时进行的
独立空间支持这种操作

正在画图的程序可以检查自己的vlx是否有字节数变动，如果有，卸载自己，然后更新自己（①可以调用update.vlx，传入参数就卸载了自己，也更新了自己②在线实时二进制流模式加载）
  • 上一篇：获取多段线顶点XY座标，并写入到表格
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025