From rklochkov at common-lisp.net  Tue May  8 08:59:09 2012
From: rklochkov at common-lisp.net (CVS User rklochkov)
Date: Tue, 08 May 2012 01:59:09 -0700
Subject: [cl-dbf-cvs] CVS cl-dbf/dbfview
Message-ID: <E1SRgGD-0001QH-C5@common-lisp.net>

Update of /project/cl-dbf/cvsroot/cl-dbf/dbfview
In directory tiger.common-lisp.net:/tmp/cvs-serv5460/dbfview

Log Message:
Directory /project/cl-dbf/cvsroot/cl-dbf/dbfview added to the repository






From rklochkov at common-lisp.net  Tue May  8 09:00:12 2012
From: rklochkov at common-lisp.net (CVS User rklochkov)
Date: Tue, 08 May 2012 02:00:12 -0700
Subject: [cl-dbf-cvs] CVS cl-dbf
Message-ID: <E1SRgHE-0001z8-24@common-lisp.net>

Update of /project/cl-dbf/cvsroot/cl-dbf
In directory tiger.common-lisp.net:/tmp/cvs-serv5720

Modified Files:
	package.lisp src.lisp 
Log Message:
Changed export list
Added GUI example: dbfview


--- /project/cl-dbf/cvsroot/cl-dbf/package.lisp	2011/05/07 18:28:43	1.1.1.1
+++ /project/cl-dbf/cvsroot/cl-dbf/package.lisp	2012/05/08 09:00:11	1.2
@@ -1,4 +1,13 @@
 (defpackage #:cl-dbf
   (:use #:cl #:binary-data #:com.gigamonkeys.binary-data.common-datatypes)
-  (:export #:read))
+  (:export 
+   #:records-count
+   #:read-record
+   #:fields
+   #:with-db
+   #:name
+   #:dbopen
+   #:code-page
+   #:goto-bof
+   #:goto-record))
 
--- /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2011/05/08 13:48:23	1.2
+++ /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2012/05/08 09:00:12	1.3
@@ -131,6 +131,10 @@
 (defun goto-bof (driver)
   (file-position (slot-value driver 'stream) (header-size driver)))
 
+(defun goto-record (driver n)
+  (file-position (slot-value driver 'stream) 
+                 (+ (header-size driver) (* n (record-size driver)))))
+
 (defun external-format (driver)
   (case (code-page driver)
     (2    '(:code-page :id 850))




From rklochkov at common-lisp.net  Tue May  8 09:00:12 2012
From: rklochkov at common-lisp.net (CVS User rklochkov)
Date: Tue, 08 May 2012 02:00:12 -0700
Subject: [cl-dbf-cvs] CVS cl-dbf/dbfview
Message-ID: <E1SRgHE-0001zP-FF@common-lisp.net>

Update of /project/cl-dbf/cvsroot/cl-dbf/dbfview
In directory tiger.common-lisp.net:/tmp/cvs-serv5720/dbfview

Added Files:
	dbfview.asd package.lisp src.lisp 
Log Message:
Changed export list
Added GUI example: dbfview



--- /project/cl-dbf/cvsroot/cl-dbf/dbfview/dbfview.asd	2012/05/08 09:00:12	NONE
+++ /project/cl-dbf/cvsroot/cl-dbf/dbfview/dbfview.asd	2012/05/08 09:00:12	1.1
(defpackage #:dbfview-system
  (:use #:cl #:asdf))
(in-package #:dbfview-system)

(defsystem dbfview
  :description "DBF Viewer"
  :author "Roman Klochkov <kalimehtar at mail.ru>"
  :version "0.1"
  :license "BSD"
  :depends-on (cl-dbf gtk-cffi-ext)
  :components
  ((:file package)
   (:file src :depends-on (package))))--- /project/cl-dbf/cvsroot/cl-dbf/dbfview/package.lisp	2012/05/08 09:00:12	NONE
+++ /project/cl-dbf/cvsroot/cl-dbf/dbfview/package.lisp	2012/05/08 09:00:12	1.1
(defpackage #:dbfview
  (:use #:cl)
  (:export #:run))--- /project/cl-dbf/cvsroot/cl-dbf/dbfview/src.lisp	2012/05/08 09:00:12	NONE
+++ /project/cl-dbf/cvsroot/cl-dbf/dbfview/src.lisp	2012/05/08 09:00:12	1.1
(in-package #:dbfview)

(defclass lisp-model-dbf (gtk-cffi-ext:lisp-model-list)
  ((db :initarg :db)))

(defmethod gtk-cffi-ext:get-value ((lisp-model lisp-model-dbf) iter n value)
  (let ((db (slot-value lisp-model 'db)))
    (cl-dbf:goto-record db (gtk-cffi-ext:iter->index iter))
    (gtk-cffi-ext:set-value value (cl-dbf:read-record db) n)))

(defmethod gtk-cffi-ext:lisp-model-length ((lisp-model lisp-model-dbf))
  (cl-dbf:records-count (slot-value lisp-model 'db)))

(defvar *codepages* #(("Auto" 0)
                      ("850" 2)
                      ("1251" 3)
                      ("852" #x64)
                      ("865" #x65)
                      ("866" #x66)
                      ("1250" #xC8)
                      ("1251" #xC9)
                      ("437" #xFF)))

(defun codepage ()
  (second (aref *codepages* 
                (multiple-value-bind (iter found) 
                    (gtk-cffi:active-iter (gtk-cffi:object-by-id :codepage))
                  (if found
                      (gtk-cffi-ext:iter->index iter)
                      0)))))

(defun fill-tree-view (tree-view filename)
  (let* ((s (open filename :direction :io 
                  :element-type 'unsigned-byte
                  :if-exists :overwrite))
         (db (cl-dbf:dbopen s))
         (impl (make-instance 'lisp-model-dbf
                              :columns (loop
                                          :for i :in (cl-dbf:fields db)
                                          :collect :string)
                              :db db)))
    (tg:finalize impl (lambda () (close s)))
    (setf (gtk-cffi:columns tree-view)
          (mapcar #'cl-dbf:name (cl-dbf:fields db)))
    (let ((codepage (codepage)))
      (unless (= 0 codepage)
        (setf (cl-dbf:code-page db) codepage)))
    (setf (gtk-cffi:model tree-view)
          (make-instance 'gtk-cffi-ext:lisp-model 
                         :implementation impl))))

(defun fill-tree-view-array (tree-view filename)
  "Use this instead of FILL-TREE-VIEW if you don't want keep DBF file open"
  (cl-dbf:with-db db filename
    (setf (gtk-cffi:columns tree-view)
          (mapcar #'cl-dbf:name (cl-dbf:fields db)))
    (let* ((empty-rec (loop
                         :for i 
                         :in (cl-dbf:fields db)
                         :collect ""))
           (arr (make-array (cl-dbf:records-count db) 
                            :initial-element empty-rec)))
      (let ((codepage (codepage)))
        (unless (= 0 codepage)
          (setf (cl-dbf:code-page db) codepage)))
      (gtk-cffi-ext:with-progress (:parent (gtk-cffi:object-by-id :window))
        (loop 
           :for i :from 0 to (- (length arr) 1)
           :do (progn
                 (setf (aref arr i) (cl-dbf:read-record db))
                 (when (= (mod i 1000) 0)
                   (gtk-cffi-ext:set-progress (/ i (length arr)))))))
      (setf (gtk-cffi:model tree-view)
            (make-instance 'gtk-cffi-ext:lisp-model 
                           :implementation
                           (make-instance 'gtk-cffi-ext:lisp-model-array 
                                          :columns (loop
                                                      :for i 
                                                      :in (cl-dbf:fields db)
                                                      :collect :string)
                                          :array arr))))))
                       
    

(defun open-file (widget)
  (declare (ignore widget))
  (let ((window (gtk-cffi:object-by-id :window)))
    (let ((open-dialog (make-instance 'gtk-cffi:file-chooser-dialog
                                      :action :open 
                                      :dialog-parent window))
          (filter (make-instance 'gtk-cffi:file-filter)))
      (gtk-cffi:add-pattern filter "*.dbf")
      (gtk-cffi:add-pattern filter "*.DBF")
      (setf (gtk-cffi:filter open-dialog) filter)
      (when (eq (gtk-cffi:run open-dialog) :accept)
        (let ((filename (gtk-cffi:filename open-dialog)))
          (gtk-cffi:destroy open-dialog)
          (fill-tree-view (gtk-cffi:object-by-id :view) 
                          filename))))))
  

(defun combo-box-model ()
  (make-instance 'gtk-cffi-ext:lisp-model 
                 :implementation
                 (make-instance 
                  'gtk-cffi-ext:lisp-model-array 
                  :columns '(:string :int)
                  :array *codepages*)))

(defun debug-press ()
  (let ((combo (gtk-cffi:object-by-id :codepage)))
    (format t "~A~%"
            (second (aref *codepages* 
                          (gtk-cffi-ext:iter->index 
                           (gtk-cffi:active-iter combo)))))))

;    (gtk-cffi-ext:iter->aref (gtk-cffi-ext:implementation 
;                              (gtk-cffi:model combo))
;                             (gtk-cffi:active-iter combo)))))
    

(defun run ()
  (gtk-cffi:gtk-init)
  (let (window)
    (setf window
          (gtk-cffi:gtk-model
            'gtk-cffi:window
            :id :window
            :width 800 :height 800
            :signals '(:destroy :gtk-main-quit)
            ('gtk-cffi:v-box
             :expand nil
             ('gtk-cffi:menu-bar
              ('gtk-cffi:menu-item 
               :label "File"
               :submenu
               (gtk-cffi:gtk-model 
                 'gtk-cffi:menu
                 ('gtk-cffi:menu-item :label "Open"
                             :signals (list :activate #'open-file))
                 ('gtk-cffi:menu-item :label "Quit"
                             :signals (list :activate
                                            (lambda (widget)
                                              (declare (ignore widget))
                                              (gtk-cffi:destroy window)))))))
             ('gtk-cffi:h-box
              ('gtk-cffi:label :text "Codepage:")
              ('gtk-cffi:combo-box 
               :id :codepage
               :model (combo-box-model)
               :active 0
               ('gtk-cffi:cell-renderer-text
                :attributes '((:text 0)))))
              ;('gtk-cffi:button :label "Debug" :signals 
              ;                  (list :clicked
              ;                        (lambda (widget)
              ;                          (declare (ignore widget))
              ;                          (debug-press)))))
             :expand t
             ('gtk-cffi:scrolled-window
              ('gtk-cffi:tree-view :id :view))
             :expand nil
             ('gtk-cffi:statusbar))))
    (gtk-cffi:show window)
    (gtk-cffi:gtk-main)))
    



From rklochkov at common-lisp.net  Thu May 31 02:45:18 2012
From: rklochkov at common-lisp.net (CVS User rklochkov)
Date: Wed, 30 May 2012 19:45:18 -0700
Subject: [cl-dbf-cvs] CVS cl-dbf
Message-ID: <E1SZvO2-00018T-8r@common-lisp.net>

Update of /project/cl-dbf/cvsroot/cl-dbf
In directory tiger.common-lisp.net:/tmp/cvs-serv2814

Modified Files:
	src.lisp 
Log Message:
Fixed read-record. Thanks to Rafael J. Alc??ntara P??rez


--- /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2012/05/08 09:00:12	1.3
+++ /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2012/05/31 02:45:17	1.4
@@ -147,6 +147,7 @@
     (t '(:code-page :id 437))))
 
 (defmethod read-record ((driver dbase3-header))
+  "Return record value as list and move to the next record"
   (with-slots (stream) driver
     (case (read-byte stream)
       (32 (loop 
@@ -158,7 +159,10 @@
                (flexi-streams:octets-to-string 
                 s 
                 :external-format (external-format driver)))))
-      (t nil))))
+      (t (file-position stream
+                        (+ (file-position stream)
+                           (1- (record-size driver))))
+         nil))))
 
 (defmacro with-db (db filespec &body body)
   (let ((stream (gensym)))