/usr/share/gnucash/scm/migrate-prefs.scm is in gnucash-common 1:2.6.15-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; migrate-prefs.scm
;;; Functions used to migrated user preferences from gconf
;;; to gsettings. Note that this module doesn't perform the
;;; migration itself: it merely prepares the environment to
;;; create the actual migration script.
;;;
;;; Copyright 2013 Geert Janssens <geert@kobaltwit.be>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 51 Franklin Street, Fifth Floor Fax: +1-617-542-2652
;; Boston, MA 02110-1301, USA gnu@gnu.org
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-module (migrate-prefs))
(use-modules (gnucash main))
(define gconf-dir "")
(define prefix-length 0)
(define migration-dir "")
(define (copy-one-file filename)
(let ((stats (stat filename))
(base-name "")
(slash-index 0)
(dest-name ""))
(gnc:debug "Processing file... " filename)
(if (eq? (stat:type stats) 'regular)
(begin
(set! base-name (string-drop filename prefix-length))
(set! slash-index (- (string-rindex base-name #\%) 1))
(if (> slash-index 0)
(begin
(set! dest-name (string-take base-name (- (string-rindex base-name #\%) 1)))
(set! dest-name (string-join (string-split dest-name #\/) "-"))
(set! dest-name (string-append migration-dir "/" dest-name ".xml"))
(gnc:debug "Copying " base-name " -> " dest-name)
(copy-file filename dest-name)
))))
(if (eq? (stat:type stats) 'directory)
(apply find copy-one-file (list filename))
)))
(define (directory-files dir)
(if (not (access? dir R_OK))
'()
(let* ((p (opendir dir))
(filelist (do ((file (readdir p) (readdir p))
(ls '()))
((eof-object? file) (closedir p) (reverse! ls))
(if (not (string-suffix? "." file))
(set! ls (cons file ls)))
)))
(sort filelist string<))))
(define (find proc . dirs)
(cond ((pair? dirs)
(for-each proc (map (lambda (x) (string-append (car dirs) "/" x))
(directory-files (car dirs)))))))
(define (finddepth proc . dirs)
(cond ((pair? dirs)
(apply finddepth proc (cdr dirs))
(for-each proc (map (lambda (x) (string-append (car dirs) "/" x))
(directory-files (car dirs)))))))
(define (migration-prepare-internal)
; cleanup first if a previous migration attempt failed to do so
(if (access? migration-dir (logior R_OK W_OK X_OK))
(begin
(gnc:msg "Clear previous migration tmp dir " migration-dir)
(migration-cleanup-internal)))
(gnc:warn "*** GnuCash switched to a new preferences system ***")
(gnc:warn "Attempt to migrate your preferences from the old to the new system")
(mkdir migration-dir)
(gnc:msg "Copy all gconf files to tmp dir " migration-dir)
(apply find copy-one-file (list gconf-dir))
; Indicate successful preparation
#t
)
(define (migration-prepare base-dir)
(set! gconf-dir (string-append base-dir "/.gconf/apps/gnucash"))
; Note: calling script should already have checked whether
; gconf-dir and its parent directories exist
(set! prefix-length (+ (string-length gconf-dir) 1))
(set! migration-dir (string-append base-dir "/.gnc-migration-tmp"))
(catch #t
migration-prepare-internal
(lambda (key . args)
(gnc:error "An error occurred while preparing to migrate preferences.")
(gnc:error "The error is: "
(symbol->string key) " - " (car (caddr args)) ".")
#f))
)
(define (rmtree args)
(define (zap f)
(let ((rm (if (eq? (stat:type (stat f)) 'directory) rmdir delete-file)))
(gnc:debug "deleting " f)
(catch #t
(lambda () (rm f))
(lambda args (format #t "couldn't delete ~A\n" f)))))
(apply finddepth zap args))
(define (migration-cleanup-internal)
(rmtree (list migration-dir))
(rmdir migration-dir)
; Indicate successful cleanup
#t)
(define (migration-cleanup base-dir)
(set! migration-dir (string-append base-dir "/.gnc-migration-tmp"))
(if (access? migration-dir (logior R_OK W_OK X_OK))
(begin
(gnc:msg "Delete tmp dir " migration-dir)
(catch #t
migration-cleanup-internal
(lambda (key . args)
(gnc:error "An error occurred while cleaning up after preferences migration.")
(gnc:error "The error is: "
(symbol->string key) " - " (car (caddr args)) ".")
#f))))
)
(export migration-prepare migration-cleanup)
|