Lisp通过Msxml2.XMLHTTP组件访问Sqlite.exe

admin1

(defun $http-local2$ (lst   /   $get-vaule-loc$
     $merge$   $open-loc$ $send-loc$ array|str|db
     content   fun   get&post   host
     hs   ip   jg   jgs
     objhttp   por   return-value
     status   str   zx:debug   $URLencode$
     )
     ;|
($http-local2$
(list
(cons "IP" ip)
(cons "端口" (vl-registry-read "HKEY_CURRENT_USER\\ZXCAD\\Server_Client\\loc" "port"))
(cons "接口" "Update")
(cons "数据库路径" db-path)
(cons "报文头" "Client-Auth")
(cons "报文体" (getenv "ComputerName"))
(cons "Sql" (LIST sql-create-sjy))
(cons "http方法" "POST")
(cons "返回格式" nil)
)
)
|;
(defun zx:debug (str)
          ;中线CAD调试开关，主要是客户返回问题了，我们通知客户将zx-debug的值调整1的时候开始奔命的打印命令行，通过打印命令行来推断问题原因
(if  (and str
   (= (getenv "zx-debug") "1")
   (or (and str (= (type str) 'str))
     (setq str (vl-princ-to-string str))
   )
  )
(print str)
)
t          ;永远返回t，因为在调用的地方可能会导致其他代码无法运行，比如说有if语句里面加上了debug调试，如果这里返回了nil直接导致上一级的if条件无法满足了
)
(defun $merge$ (strlst bar / bars len str str-bar str-last)
          ;拼接子串，列表转子串
(if  (and strlst
   bar
   (= (type strlst) 'list)
   (setq strlst (vl-remove nil strlst))
   (= (type (CAR strlst)) 'STR)
   (= (type bar) 'str)
  )
(progn
  (setq str-last (last strlst))
  (setq str-bar
   (mapcar
     (function (lambda (a)
       (or (and a (= (type a) 'str)) (setq a ""))
       (strcat a bar)
       )
     )
     (reverse (cdr (reverse strlst)))
   )
  )
  (setq str (apply 'strcat str-bar))
  (setq str (strcat str str-last))
)
)
str
)
(defun $URLencode$ (str / SC url)
          ;($URLencode$ "213j 213 2 3 %20")
(if  (or
   (and (setq SC
     (vl-catch-all-apply
      'vlax-get-or-create-object
      (list
       "MSScriptControl.ScriptControl"
      )
     )
   )
   (not (vl-catch-all-error-p SC))
   )
   (and (setq SC
     (vl-catch-all-apply
      'vlax-get-or-create-object
      (list
       "Aec32BitAppServer.AecScriptControl.1"
      )
     )
   )
   (not (vl-catch-all-error-p SC))
   )
   (and (setq SC
     (vl-catch-all-apply
      'vlax-get-or-create-object
      (list
       "ScriptControl"
      )
     )
   )
   (not (vl-catch-all-error-p SC))
   )
   (and (setq SC
     (vl-catch-all-apply
      'vlax-get-or-create-object
      (list
       "{e8540e26-d20e-483f-9fd5-a5a3553a7556}"
      )
     )
   )
   (not (vl-catch-all-error-p SC))
   )
   (and (setq SC
     (vl-catch-all-apply
      'vlax-get-or-create-object
      (list
       "{0e59f1d5-1fbe-11d0-8ff2-00a0d10038bc}"
      )
     )
   )
   (not (vl-catch-all-error-p SC))
   )
  )
(progn
  (vl-catch-all-apply
   'vlax-put
   (list SC 'Language "JScript")
  )
  (setq url (vl-catch-all-apply
     'vlax-invoke
     (list SC 'run "encodeURI" str)
     )
  )
)
)
(if  sc
(progn (vlax-release-object sc) (setq sc nil))
)
(IF  (vl-catch-all-error-p url)  ;如果出错
(setq url nil)
)
(if  url
url
str
)
)
(defun $open-loc$ (objHttp GET&POST host / return-value)
(SETQ return-value
   (vl-catch-all-apply
   'vla-open
   (list objHttp GET&POST host 0)
   )
)
(IF  (vl-catch-all-error-p return-value)
(progn (print (vl-catch-all-error-message return-value))
   nil
)
t
)
)
(defun $send-loc$
   (objHttp Headers content / value err-str seng-zt gsm)
(zx:debug "send-loc -6")
(mapcar (function (lambda (a)
      (vl-catch-all-apply
       'vlax-invoke-method
       (list  objHttp
        "setRequestHeader"
        (car a)
        (cdr a)
       )
      )
     )
   )
   Headers
)
          ;发送报文头
(or content (setq content ""))
(SETQ value
   (vl-catch-all-apply
   'vlax-invoke-method
   (list objHttp "send" content)
   )
)          ;发送报文体
(zx:debug "send-loc -8")
(if  (vl-catch-all-error-p value)
(progn
  (print)
  (princ (setq err-str (vl-catch-all-error-message value)))
  (cond
   ((AND  err-str
    (WCMATCH
     err-str
     "[,*无法与服务器建立连接*,*系统无法找到指定的资源*,]"
    )
   )
   (ALERT
   (strcat
   err-str
   "\n\n本机Sqlite服务器可能没有启动，也有可能是端口号错误\n\n文件在：C:\\Changli_harness_software\\SERVER\\LOC\\sqlite_zx.exe\n\n\n温馨提示：\n\n如果exe是启动状态，依然无法连接，请从任务管理器中结束历史进程，然后再启动本程序"
   )
   )
   )
   (t nil)
  )
  (vl-catch-all-apply 'vlax-release-object (list objHttp))
          ;释放对象
  (setq objHttp nil)
  (exit)
  (zx:debug "send-loc -10")
  (setq seng-zt nil)    ;如果在发送的过程中出现了意外就将zt做空
)
(setq seng-zt t)
)
(setq value nil)
(zx:debug "send-loc -11")
seng-zt
)
(defun $get-vaule-loc$ (objHttp array|str|db   /
       array-value    chrs   jg
       status str  tbl   value-body
       value-text txt
       )
(if
(and array|str|db (wcmatch array|str|db "[,sz,SZ,数组,]"))
(setq jg (vlax-get-property objHttp 'responsebody))
(progn
   (and
   (setq value-text
     (vlax-get-property objHttp 'responseText)
   )
          ;直接让系统ado组件返回text格式
   (setq status t)
   (setq jg value-text)
   )
)
)
jg
)
(IF (AND (cdr (assoc "IP" lst))
   (cdr (assoc "接口" lst))
)
(PROGN
(zx:debug "http-loc -0")
(and (SETQ IP (cdr (assoc "IP" lst)))
   (or (SETQ POR (cdr (assoc "端口" lst)))
   (setq por
     (vl-registry-read
      "HKEY_CURRENT_USER\\ZXCAD\\Server_Client\\loc"
      "port"
     )
   )
   )
   (SETQ FUN (cdr (assoc "接口" lst)))
   (SETQ host (STRCAT IP ":" POR "/" FUN))
)
(zx:debug "http-loc -1")
(setq GET&POST (cdr (assoc "http方法" lst)))
(setq array|str|db (cdr (assoc "返回格式" lst)))
(setq hs (cdr (assoc "报文头" lst)))
(if (and hs (= (type hs) 'str))
  (setq hs nil)
)          ;老的方法是一个字串，新的方法在下面自动拼接的
(if (not (assoc "Client-Auth" hs))
  (setq hs (cons (cons "Client-Auth" (getenv "ComputerName")) hs))
)
(if (not (assoc "Response-Charset" hs))
  (setq hs (cons (cons "Response-Charset" "UTF8") hs))
)
(if (assoc "数据库路径" lst)
  (if (not (assoc "DB-Path" hs))
   (setq
   hs
   (cons (cons "DB-Path" (cdr (assoc "数据库路径" lst))) hs)
   )
  )
)
(if (not (assoc "company" hs))
  (if (getenv "ZX-GSM")    ;客户公司代号，每个客户可以给一个代号
   (setq hs (cons (cons "company" (getenv "ZX-GSM")) hs))
  )
)          ;将客户代号给发送到服务器上去方便服务器做判断，或者是限制cad使用
(if (cdr (assoc "公钥地址" lst))
  (if (not (assoc "PublicKey-Path" hs))
   (setq  hs
     (cons (cons "PublicKey-Path" (cdr (assoc "公钥地址" lst)))
     hs
     )
   )
  )
)
(if (cdr (assoc "加解密" lst))  ;这里的值可以是 1 2
  (if (not (assoc "is-Encrypt" hs))
   (setq  hs
     (cons (cons "is-Encrypt" (cdr (assoc "加解密" lst))) hs)
   )
  )
)
(OR (AND GET&POST
   (WCMATCH (STRCASE GET&POST) "[,GET,POST,]")
   (SETQ GET&POST (STRCASE GET&POST))
   )
   (SETQ GET&POST "POST")
)
(or (setq content (cdr (assoc "Sql" lst)))
   (setq content (cdr (assoc "SQL" lst)))
   (setq content (cdr (assoc "SQL语句" lst)))
   (setq content (cdr (assoc "content" lst)))
   (setq content (cdr (assoc "报文体" lst)))
)
(and content
   (= (type content) 'list)
   (set  'content
    ($merge$
     (mapcar (function (lambda (a)
         (if (and a (> (strlen a) 0))
          a
         )
         )
       )
       content
     )
     ";"
    )
   )        ;防止传入的SQL为多条语句的list格式，处理为用 ; 隔开的str格式
)
(SETQ str "")
(zx:debug "http-loc -2")
(or
  (setq objHttp (vlax-create-object "Msxml2.XMLHTTP"))
          ;用这个的时候，服务器收到的中文路径不会乱码
  (setq objHttp (vlax-create-object "Msxml2.ServerXMLHTTP"))
          ;用这个的时候，服务器端收到的中文路径会乱码
)
(IF objHttp
  (PROGN
   (zx:debug "http-loc -3")
   (setq return-value nil)
   (if (member GET&POST (list "get" "GET"))
   (setq host ($URLencode$ host))
          ;下载文件一般都是get，防止get的时候有中文文件名，所以，get方法必需转码一下
   )
   (if ($open-loc$ objHttp GET&POST host) ;开启
   (PROGN
   (zx:debug "http-loc -4")
   (if ($send-loc$ objHttp hs content) ;发送
    (PROGN
     (zx:debug "http-loc -5")
     (while
     (not
     (eq (vlax-get-property objHttp "readyState") 4)
          ;Response-Charset,readyState
     )
     (repeat 500)
     )
     (if
     (not (= (vlax-get-property objHttp "readyState") 4))
          ;如果不等于4
     (progn (vlax-release-object objHttp) ;释放对象
       (setq objHttp nil)
     )
     )
     (if (= (vlax-get-property objHttp "readyState") 4)
     (IF
     (setq jg ($get-vaule-loc$ objHttp array|str|db))
          ;这里只是处理从xml组件里面获取数组还是子串格式，子串格式在下面会再次处理
     (SETQ status T)
     )
     )
    )
   )
   )
   )
   (zx:debug "http-loc -6")
  )
  (PROGN (ALERT
     "操作系统安装有问题！\n\n无法创建对象\"Msxml2.XMLHTTP\""
   )
   (setq status nil)
  )
)
(if objHttp
  (progn (vl-catch-all-error-p
     (vl-catch-all-apply 'vlax-release-object (list objHttp))
          ;防止前面没有释放对象
   )
   (setq objHttp nil)
  )
)
(zx:debug "http-loc -7")
(if (not status)
  (setq jg nil)
)
(cond
  ((and jg
   (= (type jg) 'str)
   array|str|db
   (wcmatch array|str|db "[,db,DB,]")
   )        ;如果上级要求返回点表格式，这里单独处理一下
   (setq
   jgs
   (vl-catch-all-apply
   'eval
   (list
    (vl-catch-all-apply 'read (list (strcat "'(" jg ")")))
   )
   )
   )
   (if (vl-catch-all-error-p jgs)
   (progn (vl-catch-all-error-message jgs)
     (setq jgs nil)
     (blsc jg "变量值.lsp")
   )
   (setq jg (cdr jgs))
   )
   (if (not jg)      ;上面代码没有读取到jg值
   (if
   (and jgs
     (CAR jgs)
     (assoc "Error" (CAR jgs))
     (cdr (assoc "Error" (CAR jgs)))
     (wcmatch (cdr (assoc "Error" (CAR jgs))) "[,*失败*,]")
   )
   (blsc jgs "变量值.lsp")  ;将数据库的所有返回打印到外部txt
   )
   )
   (IF (AND (= (TYPE jgs) 'LIST)
     (= (TYPE (CAR jgs)) 'LIST)
     (= (TYPE (CAR (CAR jgs))) 'LIST)
     (= (TYPE (CAR (CAR (CAR jgs)))) 'STR)
   )
   ()
   (SETQ jg NIL)
   )
  )
  (t nil)
)
(zx:debug "http-loc -8")
)
(PRINT "$http-local$ 参数不满足")
)
(setq objHttp nil)
jg
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;以下是示例;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          ;test接口示例
(setq data
(cdr
   (vl-catch-all-apply
   (function
   (lambda ()
   (read
     (strcat
     "("
     ($http-local2$
     (list
     (cons "IP" "http://127.0.0.1")
     (cons
       "端口"
       (vl-registry-read
       "HKEY_CURRENT_USER\\ZXCAD\\Server_Client\\loc"
       "port"
       )
     )
     (cons "接口" "Test")
          ;(cons "数据库路径" "C:\\Changli_harness_software\\SERVER\\zxcad.db") ;db数据库的文件夹路径，不是db的路径
     (cons "报文头" "Client-Auth")
     (cons "报文体" (getenv "ComputerName"))
     (cons "Sql" "")  ;这里写你的sql语句
     (cons "http方法" "get")
     (cons "返回格式" nil)
     )
     )
     ")"
     )
   )
   )
   )
   )
)
)
          ;建表语句示例
($http-local2$
(list
(cons "IP" "http://127.0.0.1")
(cons
"端口"
(vl-registry-read
  "HKEY_CURRENT_USER\\ZXCAD\\Server_Client\\loc"
  "port"
)
)
(cons "接口" "Update")
(cons
"数据库路径"
"C:\\Users\\Administrator\\Desktop\\2022-1-8-22-36-17-317.db"
)
(cons "报文头" "Client-Auth")
(cons "报文体" (getenv "ComputerName"))
(cons
"Sql"
(LIST
  "CREATE TABLE if not exists 测试(`UID` INTEGER PRIMARY KEY NOT NULL,`块名` text,`位置` text,`孔位` text,`E1` text,`E2` text,`选项` text,unique(块名,位置,孔位,E1,E2,选项));"
)
)
(cons "http方法" "POST")
(cons "返回格式" nil)
)
)
          ;查询数据示例
(setq data
(cdr
   (vl-catch-all-apply
   (function
   (lambda ()
   (read
     (strcat
     "("
     ($http-local2$
     (list
     (cons "IP" "http://127.0.0.1")
     (cons
       "端口"
       (vl-registry-read
       "HKEY_CURRENT_USER\\ZXCAD\\Server_Client\\loc"
       "port"
       )
     )
     (cons "接口" "Query")
     (cons
       "数据库路径"
       "C:\\Users\\Administrator\\Desktop\\2022-1-8-22-36-17-317.db"
     )
     (cons "报文头" "Client-Auth")
     (cons "报文体" (getenv "ComputerName"))
     (cons "Sql"
       (LIST "select * from jxb limit 1,100")
     )
     (cons "http方法" "POST")
     (cons "返回格式" nil)
     )
     )
     ")"
     )
   )
   )
   )
   )
)
)