forked from zhef/cl-eshop
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathxls.lisp
152 lines (135 loc) · 7.63 KB
/
xls.lisp
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
152
;;;; xls.lisp
;;;;
;;;; This file is part of the cl-eshop project, released under GNU Affero General Public License, Version 3.0
;;;; See file COPYING for details.
;;;;
;;;; Author: Glukhov Michail aka Rigidus <[email protected]>
(in-package #:eshop)
(defclass nko ()
((folder :initarg :folder :initform nil :accessor folder)
(xls2csv :initarg :xls2csv :initform nil :accessor xls2csv)))
(defmethod initialize-instance :after ((obn nko) &key)
(unless (file-exists-p (xls2csv obn))
(error "xls2csv not found"))
(unless (directory-exists-p (folder obn))
(error "folder not found")))
(defparameter px (make-instance 'nko
:folder (format nil "~aDropbox/xls" (user-homedir-pathname))
:xls2csv "/usr/bin/xls2csv"))
(defmethod ƒ ((isg string) (obn nko))
(let ((bin))
(values
(mapcar #'(lambda (y) (string-trim '(#\Space #\Tab) y))
(mapcar #'(lambda (y) (regex-replace-all "\\s+" y " "))
(mapcar #'(lambda (y) (string-trim '(#\Space #\Tab #\") y))
(let ((inp) (sv) (ac) (rs))
(loop :for cr :across isg do
(if (null inp)
(cond ((equal #\" cr) (setf inp t))
((equal #\, cr) (push "" rs)))
(cond ((and (null sv) (equal #\" cr)) (setf sv t))
((and sv (equal #\" cr)) (progn (setf sv nil)
(push #\" ac)))
((and sv (equal #\, cr)) (progn (setf sv nil)
(setf inp nil)
(push (coerce (reverse ac) 'string) rs)
(setf ac nil)))
((equal #\Return cr) nil)
(t (push cr ac)))))
(when ac
(if (and inp (null sv))
(setf bin t))
(push (coerce (reverse ac) 'string) rs))
(reverse rs)))))
bin)))
(defmethod ƒ ((prm list) (obn nko))
(let* ((line (getf prm :line))
(optgroups (getf prm :optgroups))
(fields (getf prm :fields))
(flt)
(rs)
(mx (max (length line) (length optgroups) (length fields)))
(cur-optgroup)
(cur-options))
(loop :for i :from 0 :to (- mx 1) :do
(let ((val (if (nth i line) (nth i line) ""))
(optgroup (if (nth i optgroups) (nth i optgroups) ""))
(field (if (nth i fields) (nth i fields) "")))
(cond ((equal i 0) (setf (getf flt :articul)
;; (handler-case
(parse-integer val)
;; (SB-INT:SIMPLE-PARSE-ERROR (se) (setf *tmp* line)))
))
((equal i 1) (setf (getf flt :realname) val))
(t (progn (unless (equal 0 (length optgroup))
(unless (null cur-optgroup)
(push (list :optgroup_name cur-optgroup :options (reverse cur-options)) rs))
(setf cur-optgroup optgroup)
(setf cur-options nil))
(push (list :name field :value val) cur-options))))))
(push (list :optgroup_name cur-optgroup :options (reverse cur-options)) rs)
(append flt (list :result-options (reverse rs)))))
(defmethod ƒ ((ifl pathname) (obn nko))
(let ((rs) (otp))
(setf otp (with-output-to-string (*standard-output*)
(let* ((proc (sb-ext:run-program
(xls2csv obn)
(list "-q3" (format nil "~a" ifl)) :wait nil :output :stream))
(optgroups)
(fields))
(with-open-stream (in (sb-ext:process-output proc))
(loop :for i from 1 do
(tagbody loop-body
(handler-case
(let ((ist (read-line in)))
(tagbody dec
(multiple-value-bind (line esf)
(ƒ ist px)
(when esf
(setf ist (concatenate 'string ist (read-line in)))
(incf i)
(go dec))
(unless (null line)
(cond ((null optgroups) (setf optgroups line))
((null fields) (setf fields line))
(t (handler-case
(let ((val (ƒ (list :line line
:optgroups optgroups
:fields fields)
px)))
(print "")
(print val)
(push val rs))
(SB-INT:SIMPLE-PARSE-ERROR () nil))))))))
(END-OF-FILE () (return i)))))))))
rs))
(defmethod ƒ ((jct nko) (obn nko))
(format t "~%Processing DTD: {...")
(let ((cnt 0))
(loop :for file :in (directory (format nil "~a/*.xls" (folder obn))) :do
(format t "~%~a. Processing file: ~a" (incf cnt) file)
(loop :for item :in (ƒ file px) :do
(let* ((articul (getf item :articul))
(realname (getf item :realname))
(optgroups (loop :for optgroup :in (getf item :result-options) :collect
(make-instance 'optgroup
:name (getf optgroup :optgroup_name)
:options (loop :for option :in (getf optgroup :options) :collect
(make-instance 'option
:name (getf option :name)
:value (getf option :value))))))
(product (gethash (format nil "~a" articul) *storage*)))
(if (null product)
(format nil "warn: product ~a (articul ~a) not found, ignore (file: ~a)" realname articul file)
(progn
(setf (optgroups product) optgroups)
;; Если есть значимое realname - перезаписать в продукте
(if (not (string= "" (string-trim '(#\Space #\Tab #\Newline)
(format nil "~@[~a~]" realname))))
(setf (realname product) realname)))))))
(format t "~%...} successfully processed ~a files" cnt)
;;создаем новый yml файл
(create-yml-file)))
(defun dtd ()
(ƒ px px))
(export 'dtd)