Работа с xml

Автор: | Дата: 17 Май 2013 · 9 коммент. 

Чем дальше, тем больше AutoCAD и продукты на его основе "завязываются" на xml. Понятно почему: удобный вариант хранения сколь угодно сложной структуры, парсер гарантированно встроен в систему ну и теде.

Достаточно давно я разработал набор функций, которые позволяют нормально работать с xml-документом. Как выяснилось в процессе работы, в основном стоит задача чтения данных (благо заполняю я xml-файлы либо в Notepad++, либо в Microsoft XML Notepad, либо в MS Visual Studio). Но - функции есть, и предоставлю я их целиком.

Предупреждаю сразу: пост получился очень длинный, набор функций, как всегда, в самом конце :)

P.S. Функции не переименовывал. Кому охота - код открыт, используйте наздоровье :)
P.P.S. Аналог всего этого дела был в свое время опубликован у меня на блогспоте, так что не удивляйтесь возможным повторам :).

Сначала "нарисуем" какой-нибудь достаточно простой xml-файлик:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
<?xml version="1.0" encoding="utf-8"?>
<Acad>
  <Sysvar>
<!-- Принудительно устанавливаемые системные переменные -->
    <Item name="angbase" value="0" />
    <Item name="blipmode" value="0" />
    <Item name="cecolor" value="bylayer" />
    <Item name="celtype" value="bylayer" />
    <Item name="celweight" value="-1" />
    <Item name="clayer" value="0" />
    <Item name="demandload" value="3" />
    <Item name="filedia" value="1"/>
  </Sysvar>
  <SupportPath>
    <!--
   Данные о добавляемых путях поддержки. Вынесено в отдельную ветку, т.к. надо не просто назначать, а проверять наличие путей
   -->
    <Item>\\server\settings\template</Item>
    <Item>\\server\settings\support</Item>
  </SupportPath>
</Acad>

и сохраним его, например, в c:\test.xml (ну так, чтобы было с чем поковыряться ;))

К сожалению, подсветка кода сработала немного некорректно, но это не особо важно. Важно другое:
1. Если такой файл создавать "руками", то надо отследить, чтобы сохранялся он именно в указанной кодировке, т.е. UTF-8. Лично я постоянно использую именно эту кодировку, пока (тьфу-тьфу) проблем не было.
2. Каждый тэг должен быть закрыт.

Теперь начнем работать внутри vlide. Прежде всего надо создать указатель на документ - показать лиспу, с чем мы собираемся работать. А что мы с этим будем делать - вопрос отдельный :)

В процессе работы достаточно широко используются некоторые библиотечные функции:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
(defun _kpblc-error-catch (protected-function
                           on-error-function
                           /
                           catch_error_result
                           )
                          ;|
*** Функция взята из книжной версии ruCAD'a без каких бы то ни было переделок,
*** кроме переименования.
*    Оболочка отлова ошибок.
*    Параметры вызова:
* protected-function  - "защищаемая" функция
* on-error-function - функция, выполняемая в случае ошибки
|;
  (setq catch_error_result (vl-catch-all-apply protected-function))
  (if (and (vl-catch-all-error-p catch_error_result)
           on-error-function
           ) ;_ end of and
    (apply on-error-function
           (list (vl-catch-all-error-message catch_error_result))
           ) ;_ end of apply
    catch_error_result
    ) ;_ end of if
  ) ;_ end of defun

(defun _kpblc-error-print (func-name msg / res)
                          ;|
*    Функция вывода сообщения об ошибке для (_kpblc-error-catch)
*    Параметры вызова:
* func-name имя функции, в которой возникла ошибка
* msg   сообщение об ошибке
|;
  (princ (setq res (strcat "\n ** "
                           (vl-string-trim "][ :\n<>"
                                           (vl-string-subst
                                             ""
                                             "error"
                                             (strcase (_kpblc-conv-value-to-string func-name) t)
                                             ) ;_ end of vl-string-subst
                                           ) ;_ end of vl-string-trim
                           " ERROR #"
                           (if msg
                             (strcat
                               (_kpblc-conv-value-to-string (getvar "errno"))
                               ": "
                               (_kpblc-conv-value-to-string msg)
                               ) ;_ end of strcat
                             ": undefined"
                             ) ;_ end of if
                           ) ;_ end of strcat
               ) ;_ end of setq
         ) ;_ end of princ
  (_kpblc-log res nil)
  (princ)
  ) ;_ end of defun

(defun _kpblc-conv-value-to-string (value /)
                                   ;|
*    конвертация значения в строку.
|;
  (cond
    ((= (type value) 'str) value)
    ((= (type value) 'int) (itoa value))
    ((and (= (type value) 'real) (equal value (_kpblc-eval-value-round value 1.) 1e-6))
     (itoa (fix value))
     )
    ((= (type value) 'real) (rtos value 2 14))
    ((not value) "")
    (t (vl-princ-to-string value))
    ) ;_ end of cond
  ) ;_ end of defun

(defun _kpblc-eval-value-round (value to)
  ;|
;; http://forum.dwg.ru/showthread.php?p=301275
*    Выполняет округление числа до указанной точности
*    Примеры вызова:
(_kpblc-eval-value-round 16.365 0.01) ; 16.37
|;
  (if (zerop to)
    value
    (* (atoi (rtos (/ (float value) to) 2 0)) to)
    ) ;_ end of if
  ) ;_ end of defun

(defun _kpblc-property-get (obj property / res)
                           ;|
*    Получение значения свойства объекта
|;
  (vl-catch-all-apply
    (function
      (lambda ()
        (if (and obj
                 (vlax-property-available-p
                   (setq obj (_kpblc-conv-ent-to-vla obj))
                   property
                   ) ;_ end of vlax-property-available-p
                 ) ;_ end of and
          (setq res (vlax-get-property obj property))
          ) ;_ end of if
        ) ;_ end of lambda
      ) ;_ end of function
    ) ;_ end of vl-catch-all-apply
  res
  ) ;_ end of defun

(defun _kpblc-conv-ent-to-ename (ent_value /)
                                ;|
*    Функция преобразования полученного значения в ename
*    Параметры вызова:
* ent_value значение, которое надо преобразовать в примитив. Может
*     быть именем примитива, vla-указателем или просто
*     списком.
*     Если не принадлежит ни одному из указанных типов,
*     возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-ename (entlast))
(_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
|;
  ;; "_kpblc-conv-ent-to-ename")
  (cond
    ((= (type ent_value) 'vla-object)
     (vlax-vla-object->ename ent_value)
     )
    ((= (type ent_value) 'ename) ent_value)
    ;((= (type ent_value) 'str) (handent ent_value))
    ((= (type ent_value) 'list) (cdr (assoc -1 ent_value)))
    (t nil)
    ) ;_ end of cond
  ) ;_ end of defun

(defun _kpblc-conv-ent-to-vla (ent_value / res)
                              ;|
*    Функция преобразования полученного значения в vla-указатель.
*    Параметры вызова:
* ent_value значение, которое надо преобразовать в указатель. Может
*     быть именем примитива, vla-указателем или просто
*     списком.
*     Если не принадлежит ни одному из указанных типов,
*     возвращается nil
*    Примеры вызова:
(_kpblc-conv-ent-to-vla (entlast))
(_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
|;
  (cond
    ((= (type ent_value) 'vla-object) ent_value)
    ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
    ((setq res (_kpblc-conv-ent-to-ename ent_value))
     (vlax-ename->vla-object res)
     )
    ) ;_ end of cond
  ) ;_ end of defun

Теперь погнали работать с xml. Получаем указатель на документ xml.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
(defun _kpblc-xml-doc-get (file / doc)
                          ;|
*    Получение указателя на xml-DOMDocument
*    Параметры вызова:
  file  xml-файл. Валидность не проверяется
|;
  (if (findfile file)
    (_kpblc-error-catch
      (function
        (lambda ()
          (setq doc (vlax-get-or-create-object "MSXML2.DOMDocument.3.0"))
          (vlax-put-property doc 'async :vlax-false)
          (vlax-invoke-method doc 'load file)
          ) ;_ end of lambda
        ) ;_ end of function
      '(lambda (x)
         (_kpblc-error-print "_kpblc-xml-doc-get" x)
         (setq doc nil)
         ) ;_ end of lambda
      ) ;_ end of _kpblc-error-catch
    ) ;_ end of if
  doc
  ) ;_ end of defun

Почему используется именно "MSXML2.DOMDocument.3.0"? Это единственное средство, которое я обнаружил в Windows 2000 и выше и в AutoCAD 2008 и выше. На более древних версиях ОС либо AutoCAD, возможно, понадобится другой парсер - не пробовал, не знаю :(

Запустим функцию получения указателя на xml-документ:

1
2
_$ (setq xml_doc (_kpblc-xml-doc-get "c:\\test.xml"))
#<VLA-OBJECT IXMLDOMDocument2 0000000009a27d20>

Если выполнить дамп объекта и подключить MSDN, то выяснится масса интереснейших подробностей. Нас же интересует прежде всего получение "основного" узла (в валидных xml-файлах может быть только один "основной" узел; в противном случае парсер говорит, что файл некорректный и сваливается "в никуда")

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
(defun _kpblc-xml-node-get-main (obj / res)
                                ;|
*    Получение главного (верхнего) узла xml-дерева. Валидность xml-файла не
* проверяется
*    Параметры вызова:
  obj указатель на объект XML-документа
*    Примеры вызова:
(setq obj (_kpblc-xml-doc-get (findfile (strcat (_kpblc-dir-path-and-splash(_kpblc-dir-get-root-xml))"tables.xml"))))
(_kpblc-xml-node-get-main obj)
|;
  (_kpblc-error-catch
    (function
      (lambda ()
        (setq res (car (_kpblc-xml-conv-nodes-to-list
                         (_kpblc-property-get
                           obj
                           'childnodes
                           ) ;_ end of _kpblc-property-get
                         ) ;_ end of _kpblc-xml-conv-nodes-to-list
                       ) ;_ end of car
              ) ;_ end of setq
        ) ;_ end of lambda
      ) ;_ end of function
    '(lambda (x)
       (_kpblc-error-print "_kpblc-xml-node-get-main" x)
       (setq res nil)
       ) ;_ end of lambda
    ) ;_ end of _kpblc-error-catch
  res
  ) ;_ end of defun

В коде используется еще одна служебная функция: _kpblc-xml-conv-nodes-to-list. Она проста до безобразия:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
(defun _kpblc-xml-conv-nodes-to-list (nodes / i res)
                                     ;|
*    Преобразование указателя на коллекцию Nodes xml-объекта в список.
*    Исключаются описания не узлов (комментарии, DATA-узлы и т.п.)
*    Параметры вызова:
  nodes указатель на коллекцию узлов xml-документа
|;
  (_kpblc-error-catch
    (function
      (lambda ()
        (setq i 0)
        (while (< i (_kpblc-property-get nodes 'length))
          (setq res (cons (vlax-get-property nodes 'item i) res)
                i   (1+ i)
                ) ;_ end of setq
          ) ;_ end of while
        (setq res (vl-remove-if-not
                    (function
                      (lambda (x)
                        (member (_kpblc-property-get x 'nodetype) '(1 2))
                        ) ;_ end of lambda
                      ) ;_ end of function
                    (reverse res)
                    ) ;_ end of vl-remove-if-not
              ) ;_ end of setq
        ) ;_ end of lambda
      ) ;_ end of function
    '(lambda (x)
       (_kpblc-error-print "_kpblc-xml-conv-nodes-to-list" x)
       (setq res nil)
       ) ;_ end of lambda
    ) ;_ end of _kpblc-error-catch
  res
  ) ;_ end of defun

и фактически весьма сильно напоминает функцию преобразования vla-указателя на коллекцию в список ее элементов.

Получим и указатель на основной узел xml-документа:

1
2
_$ (setq main (_kpblc-xml-node-get-main xml_doc))
#<VLA-OBJECT IXMLDOMElement 0000000009a2a300>

Теперь, получив указатель на "основной", или "родительский" узел, можно получить указатели и на его подчиненные узлы:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
(defun _kpblc-xml-nodes-get-child (parent / node childs res)
                                  ;|
*    Получение подчиненных элементов xml-дерева
*    Параметры вызова
  parent  указатель на узел, для которого получаем Child
    nil недопустим
*    Примеры вызова:
(setq obj (_kpblc-xml-get-document (findfile (strcat (_kpblc-dir-path-and-splash(_kpblc-dir-get-root-xml))"tables.xml"))))
(_kpblc-xml-get-nodes-child (_kpblc-xml-node-get-main obj))
|;
  (if (and parent
           (vlax-method-applicable-p parent 'haschildnodes)
           (equal (vlax-invoke-method parent 'haschildnodes)
                  :vlax-true
                  ) ;_ end of equal
           (setq childs (_kpblc-property-get parent 'childnodes))
           ) ;_ end of and
    (_kpblc-xml-conv-nodes-to-list childs)
    ) ;_ end of if
  ) ;_ end of defun

Дальше начинаем работать с узлами: попробуем получить указатель на узел, имея в распоряжении только его tag:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
(defun _kpblc-xml-nodes-get-child-by-tag (parent tag)
                                         ;|
*    Получение списка подчиненных узлов, у которых тэг совпадает с указанным
*    Параметры вызова:
  parent  указатель на "родительский" узел
  tag маска имени тэга. nil -> "*"
|;
  (setq tag (if tag
              (strcase tag)
              "*"
              ) ;_ end of if
        ) ;_ end of setq
  (vl-remove-if-not
    (function
      (lambda (x)
        (wcmatch
          (strcase (_kpblc-conv-value-to-string (_kpblc-property-get x 'tagname))
                   ) ;_ end of strcase
          tag
          ) ;_ end of wcmatch
        ) ;_ end of lambda
      ) ;_ end of function
    (_kpblc-xml-nodes-get-child parent)
    ) ;_ end of vl-remove-if-not
  ) ;_ end of defun
1
2
3
4
5
6
7
8
9
Теперь, если в коде нам вдруг понадобится получить указатель на все подузлы элемента Sysvar, мы можем сделать нечто наподобие:
[cc lang="cadlisp"](vl-load-com)

(defun test (/ xml_doc main)
  (setq xml_doc      (_kpblc-xml-doc-get "c:\\test.xml")
        main         (_kpblc-xml-node-get-main xml_doc)
        node_sysvars (_kpblc-xml-nodes-get-child-by-tag main "Sysvars")
        ) ;_ end of setq
  ) ;_ end of defun

Дальше, казалось бы, все просто: получаем указатели на подузлы и... И?..

Для узла, оказывается, надо еще уметь получать его атрибуты:

1
2
3
4
5
6
7
8
9
10
11
12
13
(defun _kpblc-xml-attributes-get-by-node (node)
          ;(defun _kpblc-xml-get-attrbitutes (node)
                                         ;|
*    Получение атрибутов узла XML-дерева.
*    Параметры вызова:
  node  проверяемый узел
|;
  (if (vlax-property-available-p node 'attributes)
    (_kpblc-xml-conv-nodes-to-list
      (_kpblc-property-get node 'attributes)
      ) ;_ end of _kpblc-xml-conv-nodes-to-list
    ) ;_ end of if
  ) ;_ end of defun

и их значения, не забывая про сами тэги атрибутов:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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
(defun _kpblc-xml-attribute-get-name-and-value (xml-attribute)
                                               ;|
*    Получение списка точечной пары имени и значения атрибута
*    Параметры вызова:
  xml-attribute указатель на xml-атрибут документа. Допустимые
    значения:
      vla-object  указатель на 1 атрибут / узел дерева
      list    список атрибутов
      nil   ничего не делается
*    Пример вызова:
|;
  (cond
    ((and xml-attribute
          (= (type xml-attribute) 'vla-object)
          (vlax-property-available-p xml-attribute 'nodename)
          (not (_kpblc-property-get xml-attribute 'attributes))
          ) ;_ end of and
     (cons (strcase (_kpblc-property-get xml-attribute 'nodename) t)
           ((lambda (/ _res)
              (setq _res (vlax-variant-value (_kpblc-property-get xml-attribute 'nodevalue)))
              (foreach item '(("@qute;" . """)
                              ("&quot;" . """)
                              ("&amp;" . "&")
                              ("&#10;" . "\r")
                              ("&#13;" . "\n")
                              )
                (setq _res (_kpblc-string-replace _res (car item) (cdr item)))
                ) ;_ end of foreach
              _res
              ) ;_ end of lambda
            )
           ) ;_ end of cons
     )
    ((and xml-attribute
          (= (type xml-attribute) 'vla-object)
          (vlax-property-available-p xml-attribute 'nodename)
          (_kpblc-property-get xml-attribute 'attributes)
          ) ;_ end of and
     (mapcar (function _kpblc-xml-attribute-get-name-and-value)
             (_kpblc-xml-attributes-get-by-node xml-attribute)
             ) ;_ end of mapcar
     )
    ((and xml-attribute (listp xml-attribute))
     (mapcar (function _kpblc-xml-attribute-get-name-and-value) xml-attribute)
     )
    ) ;_ end of cond
  ) ;_ end of defun

Теперь, имея в своем распоряжении все это богатство, начинаем уже более серьезную работу:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
(vl-load-com)

(defun test (/ xml_doc main)
  (setq xml_doc      (_kpblc-xml-doc-get "c:\\test.xml")
        main         (_kpblc-xml-node-get-main xml_doc)
        node_sysvars (mapcar
                       (function _kpblc-xml-attribute-get-name-and-value)
                       (_kpblc-xml-nodes-get-child
                         (car
                           (_kpblc-xml-nodes-get-child-by-tag main "Sysvar")
                           ) ;_ end of car
                         ) ;_ end of _kpblc-xml-nodes-get-child
                       ) ;_ end of mapcar
        ) ;_ end of setq
  ) ;_ end of defun

Если мы посмотрим на значение node_sysvars, мы увидим очень интересную вещь:

1
2
3
4
5
6
7
8
9
'((("name" . "angbase") ("value" . "0"))
  (("name" . "blipmode") ("value" . "0"))
  (("name" . "cecolor") ("value" . "bylayer"))
  (("name" . "celtype") ("value" . "bylayer"))
  (("name" . "celweight") ("value" . "-1"))
  (("name" . "clayer") ("value" . "0"))
  (("name" . "demandload") ("value" . "3"))
  (("name" . "filedia") ("value" . "1"))
  )

Т.е. мало того, что у нас системные переменные получены прямо так, как мы хотели, так еще и устанавливаемые значения в строковом представлении! В принципе, ничего страшного - и не такие задачки решали! :)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
(defun _kpblc-sysvar-set (var value)
                         ;|
*    Установка системных переменных. Замена стандартному (setvar) для безошибочной обработки

|;
  (if (getvar var)
    (if (and (= value "") (wcmatch (strcase var t) "dim*"))
      (setvar var ".")
      (vl-catch-all-apply
        (function
          (lambda (/ tmp)
            (setq tmp (getvar var)
                  tmp (cond
                        ((or (= (type value) (type tmp))
                             (and (member value (list 'int 'real))
                                  (member tmp (list 'int 'real))
                                  ) ;_ end of and
                             ) ;_ end of or
                         value
                         )
                        ((= (type tmp) 'int) (_kpblc-conv-value-to-int value))
                        ((= (type tmp) 'real) (_kpblc-conv-value-to-real value))
                        ((= (type tmp) 'str) (_kpblc-conv-value-to-string value))
                        ((= (type tmp) 'list)
                         (mapcar (function atof)
                                 (_kpblc-conv-string-to-list (vl-string-trim "()" (_kpblc-conv-value-to-string value)) ",")
                                 ) ;_ end of mapcar
                         )
                        ) ;_ end of cond
                  ) ;_ end of setq
            (setvar var tmp)
            ) ;_ end of lambda
          ) ;_ end of function
        ) ;_ end of vl-catch-all-apply
      ) ;_ end of if
    ) ;_ end of if
  (getvar var)
  ) ;_ end of defun

Аналогичным образом можно получить и перечень добавляемых путей поддержки (ну или что вы там нафантазируете :))

Прежде чем предоставлять полный архив, хочу предупредить вот о чем:

  1. После окончания работы с xml-документом надо очищать коннекты к нему. Очистка выполняется принудительно, через vlax-release-object
  2. Нередко достаточно организовать коннект только к xml-документу и его основному узлу, а все остальное вычислять по мере надобности
  3. Осторожно работаем с объемными xml-узлами, содержащими внутри несколько сотен, а то и тысям подчиненных узлов. Время получения нужного узла может измеряться уже секундами - в некоторых случаях подобное может оказаться критичным. Тот же assoc в аналогичных условиях может сработать почти моментально
  4. Иногда имеет смысл хранить объект коннекта к xml-документу во внедокументной переменной (см. функции vl-bb-set и vl-bb-ref)

В общем и целом, весь архив функций, необходимых и достаточных (естественно, с моей точки зрения) для полноценной и эффективной работы с xml-файлами, лежит в архиве
Если что-то забыл или не работает - пожалуйста, пишите либо в комментах, либо в почту.
---
Весь набор, объединенный в один лисп: lisru-xml-collection

Размещено в Код LISP, Новости, Функции LISP · Метки: , , ,



Комментарии

Есть 9 коммент. к “Работа с xml”
  1. Кулик Алексей aka kpblc пишет:
    19 Май 2013 в 21:21

    Если надо, могу выложить также "все лиспы в одном" и компилированные версии.

  2. Михаил пишет:
    17 Декабрь 2014 в 10:15

    В функции _kpblc-error-print используется функция _kpblc-log, описания которой я что-то никак не найду. Можно опубликовать?
    Заранее благодарен.

  3. Кулик Алексей aka kpblc пишет:
    17 Декабрь 2014 в 12:26

    Да ее можно исключить абсолютно безболезненно: фактически в лог-файл пишется информация об ошибке. Основная задача там - определить имя лог-файла. Потом создается для него каталог, проверяется длина файла (анализировать многометровый файл по меньшей мере неинтересно ;)), и выполняется запись. Код точно нужен? Там много функций используется...

  4. Михаил пишет:
    17 Декабрь 2014 в 13:34

    Спасибо. Понял. Исключу.

  5. Юрий пишет:
    17 Февраль 2020 в 12:41

    При попытке использовать _kpblc-xml-attribute-get-name-and-value выходит ошибка: no function definition: _KPBLC-STRING-REPLACE-NOREG
    В вашем lisp файле я так и не нашел определение этой функции. Это ошибка или просто забыли выложить?

    1
     
  6. Кулик Алексей aka kpblc пишет:
    17 Февраль 2020 в 15:05

    Возможно, забыл.

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    (defun _kpblc-string-replace-noreg (str old new / base lst pos res)
                                       ;|
    *    Функция замены вхождений подстроки на новую. Регистронезависима
    *    Параметры вызова:
      str  исходная строка
      old  старая строка
      new  новая строка
    *    Позволяет менять аналогичные строки: "str" -> "'_str'"
    *    Примеры вызова:
    (_kpblc-string-replace-noreg "pik-industry-cad" "PIK-IND" "##")           ; "##ustry-cad"
    (_kpblc-string-replace-noreg "test string test string string" "TEST" "$") ; "$ string $ string string"
    |;
      (setq pos 1)
      (foreach item (setq base (_kpblc-conv-string-to-list (strcase str) (strcase old))
                          base (mapcar (function (lambda (x) (cons x (strlen x)))) base)
                          ) ;_ end of setq
        (setq res (cons (substr str pos (cdr item)) res)
              pos (+ pos (cdr item) (strlen old))
              ) ;_ end of setq
        ) ;_ end of foreach
      (_kpblc-conv-list-to-string (reverse res) new)
      ) ;_ end of defun

    На всякий случай:

    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    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
    (defun _kpblc-conv-string-to-list (string separator / i)
                                      ;|
    *    Функция разбора строки. Возвращает список
    *    Параметры вызова:
      string      ; разбираемая строка
      separator   ; символ, используемый в качестве разделителя частей
    *    Примеры вызова:
    (_kpblc-conv-string-to-list "1;2;3;4;5;6" ";")  ;-> '(1 2 3 4 5 6)
    (_kpblc-conv-string-to-list "1;2" ";")          ;-> '(1 2)
    (_kpblc-conv-string-to-list "1,2" ",")          ;-> '(1 2)
    (_kpblc-conv-string-to-list "1.2" ".")          ;-> '(1 2)
    |;
      (cond ((= string "") nil)
            ((vl-string-search separator string)
             ((lambda (/ pos res)
                (while (setq pos (vl-string-search separator string))
                  (setq res    (cons (substr string 1 pos) res)
                        string (substr string (+ (strlen separator) 1 pos))
                        ) ;_ end of setq
                  ) ;_ end of while
                (reverse (cons string res))
                ) ;_ end of lambda
              )
             )
            ((and (not (member separator '("`" "#" "@" "." "*" "?" "~" "[" "]" "-" ",")))
                  (wcmatch (strcase string) (strcat "*" (strcase separator) "*"))
                  ) ;_ end of and
             ((lambda (/ pos res _str prev)
                (setq pos  1
                      prev 1
                      _str (substr string pos)
                      ) ;_ end of setq
                (while (<= pos (1+ (- (strlen string) (strlen separator))))
                  (if (wcmatch (strcase (substr string pos (strlen separator))) (strcase separator))
                    (setq res    (cons (substr string 1 (1- pos)) res)
                          string (substr string (+ (strlen separator) pos))
                          pos    0
                          ) ;_ end of setq
                    ) ;_ end of if
                  (setq pos (1+ pos))
                  ) ;_ end of while
                (if (< (strlen string) (strlen separator))
                  (setq res (cons string res))
                  ) ;_ end of if
                (if (or (not res) (= _str string))
                  (setq res (list string))
                  (reverse res)
                  ) ;_ end of if
                ) ;_ end of lambda
              )
             )
            (t (list string))
            ) ;_ end of cond
      ) ;_ end of defun
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    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
    (defun _kpblc-conv-list-to-string (lst sep) ;|
    *    Преобразование списка в строку
    *    Параметры вызова:
      lst  ; обрабатываемй список
      sep  ; разделитель. nil -> " "
    |;
      (if (and lst
               (setq lst (mapcar (function _kpblc-conv-value-to-string) lst))
               (setq sep (if sep
                           sep
                           " "
                           ) ;_ end of if
                     ) ;_ end of setq
               ) ;_ end of and
        (strcat (car lst)
                (apply (function strcat) (mapcar (function (lambda (x) (strcat sep x))) (cdr lst)))
                ) ;_ end of strcat
        ""
        ) ;_ end of if
      ) ;_ end of defun

    (defun _kpblc-conv-value-to-string (value /) ;|
    *    конвертация значения в строку.
    |;
      (cond ((= (type value) 'str) value)
            ((= (type value) 'int) (itoa value))
            ((and (= (type value) 'real)
                  (equal value (_kpblc-eval-value-round value 1.) 1e-6)
                  (equal value (fix value) 1e-6)
                  ) ;_ end of and
             (itoa (fix value))
             )
            ((and (= (type value) 'real)
                  (equal value (_kpblc-eval-value-round value 1.) 1e-6)
                  (not (equal value (fix value) 1e-6))
                  ) ;_ end of and
             (rtos value 2)
             )
            ((= (type value) 'real) (rtos value 2 14))
            ((not value) "")
            (t (vl-princ-to-string value))
            ) ;_ end of cond
      ) ;_ end of defun

    (defun _kpblc-eval-value-round
           (value to) ;|
    ;; http://forum.dwg.ru/showthread.php?p=301275
    *    Выполняет округление числа до указанной точности
    *    Примеры вызова:
    (_kpblc-eval-value-round 16.365 0.01) ; 16.37
    |;
      (if (zerop to)
        value
        (cond ((and value (listp value)) (mapcar (function (lambda (x) (_kpblc-eval-value-round x to))) value))
              (value
               (if (or (= (type to) 'int) (equal (fix to) to))
                 (* (atoi (rtos (/ (float value) to) 2 0)) to)
                 (* (fix (/ (float value) to)) to)
                 ) ;_ end of if
               )
              ) ;_ end of cond
        ) ;_ end of if
      ) ;_ end of defun

    Вроде бы ничего не упустил.

  7. Владимир пишет:
    20 Декабрь 2022 в 13:02

    Еще бы файл xml, желательно сложной структуры.

  8. Владимир пишет:
    20 Декабрь 2022 в 13:09

    Виноват, файл есть, но уж слишком простой..
    Хочется тоакой, чтобы проиллюстрировал безграничные возможности программ..
    Ну или почти безграничные!

  9. Кулик Алексей aka kpblc пишет:
    20 Декабрь 2022 в 13:41

    Ну взять любой xlsx или docx, распаковать его, взять оттуда любой xml - и вперед.

Поделитесь своим мнением


Я не робот.