mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
Merge branch 'maint'
* Bug726449 - Budget Barchart does not show up if running sum is selected * Add fixed EUR-LVL conversion rate to gnc_euro_rates * Update Latvian translation * Add Indian Konkani translation * Remove unused function yahoo-get-historical-quotes * Fix handling of kvps for address, entry, job, order and taxtable objects * Prevent older gnucash versions from loading data files with said kvps
This commit is contained in:
Geert Janssens
commit
e6c36983d4
14
configure.ac
14
configure.ac
@ -83,7 +83,7 @@ AC_DEFINE_UNQUOTED(GNUCASH_LATEST_STABLE_SERIES, "$GNUCASH_LATEST_STABLE_SERIES"
|
||||
[Most recent stable GnuCash series])
|
||||
|
||||
dnl Set of available languages.
|
||||
ALL_LINGUAS="ar bg ca cs da de el en_GB es_NI es eu fa fi fr he hu it ja ko lt lv nb ne nl pl pt_BR pt ro ru rw sk sv ta tr uk vi zh_CN zh_TW"
|
||||
ALL_LINGUAS="ar bg ca cs da de el en_GB es_NI es eu fa fi fr he hu it ja ko kok kok@latin lt lv nb ne nl pl pt_BR pt ro ru rw sk sv ta tr uk vi zh_CN zh_TW"
|
||||
|
||||
GETTEXT_PACKAGE=gnucash
|
||||
AC_SUBST(GETTEXT_PACKAGE)
|
||||
@ -436,7 +436,6 @@ AC_CHECK_FUNCS(gethostid link)
|
||||
|
||||
# - check minimum version
|
||||
# - determine GUILE_CFLAGS and GUILE_LIBS
|
||||
# - test if guile module (www main) is present on the system
|
||||
# Note: systems that install both guile 1.8 and guile 2 use different
|
||||
# names for the 1.8 and 2.0 autoconf macros to avoid conflicts.
|
||||
# So the tests below will check for known macro names in the order
|
||||
@ -447,17 +446,14 @@ gnc_have_guile_www=no
|
||||
PKG_CHECK_MODULES(GUILE,
|
||||
[guile-1.8 >= 1.8.5],
|
||||
[m4_ifdef([GUILE1_8_PROGS],
|
||||
[ GUILE1_8_PROGS
|
||||
GUILE1_8_MODULE_AVAILABLE(gnc_have_guile_www,[(www main)]) ],
|
||||
[ GUILE_PROGS
|
||||
GUILE_MODULE_AVAILABLE(gnc_have_guile_www,[(www main)]) ])
|
||||
[ GUILE1_8_PROGS ],
|
||||
[ GUILE_PROGS ])
|
||||
], [
|
||||
PKG_CHECK_MODULES(GUILE,
|
||||
[guile-2.0 >= 2.0.0],
|
||||
[m4_ifdef([GUILE_PROGS],
|
||||
[ GUILE_PROGS
|
||||
gnc_have_guile_2=yes
|
||||
GUILE_MODULE_AVAILABLE(gnc_have_guile_www,[(www main)]) ],
|
||||
gnc_have_guile_2=yes ],
|
||||
[ AC_MSG_ERROR([ guile 2 is found on your system, but appears
|
||||
to export different autoconf macros than what we expected. Please report this as a bug
|
||||
in GnuCash, so we can fix this for your platform.]) ])
|
||||
@ -470,7 +466,6 @@ PKG_CHECK_MODULES(GUILE,
|
||||
])
|
||||
|
||||
AM_CONDITIONAL(GNC_HAVE_GUILE_2, test "${gnc_have_guile_2}" = yes)
|
||||
AM_CONDITIONAL(GNC_HAVE_GUILE_WWW, test "${gnc_have_guile_www}" = yes)
|
||||
|
||||
|
||||
### --------------------------------------------------------------------------
|
||||
@ -1378,7 +1373,6 @@ AC_CONFIG_FILES(
|
||||
doc/examples/Makefile
|
||||
intl-scm/Makefile
|
||||
lib/Makefile
|
||||
lib/guile-www/Makefile
|
||||
lib/libc/Makefile
|
||||
lib/stf/Makefile
|
||||
packaging/Makefile
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
if GNUCASH_ENABLE_GUI
|
||||
SUBDIRS = libc guile-www stf
|
||||
SUBDIRS = libc stf
|
||||
else
|
||||
SUBDIRS = libc guile-www
|
||||
SUBDIRS = libc
|
||||
endif
|
||||
|
||||
EXTRA_DIST = README
|
||||
|
||||
@ -1,121 +0,0 @@
|
||||
2002-01-09 Rob Browning <rlb@defaultvalue.org>
|
||||
|
||||
* Makefile.am: handle conditional install inclusion of GUILE_WWW.
|
||||
|
||||
2001-12-08 Dave Peticolas <dave@krondo.com>
|
||||
|
||||
* Makefile.am (Repository): clean .scm-links
|
||||
|
||||
2001-11-28 Rob Browning <rlb@defaultvalue.org>
|
||||
|
||||
* .cvsignore: add .scm-links
|
||||
|
||||
* lib/guile-www/Makefile.am
|
||||
(.scm-links): create so we can run from gnucash build dir.
|
||||
|
||||
2001-02-04 Marius Vollmer <mvo@zagadka.ping.de>
|
||||
|
||||
* http.scm: Use (ice-9 rdelim) if `read-line' not defined. Thanks
|
||||
to Thien-Thi Nguyen.
|
||||
|
||||
2000-06-04 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
|
||||
|
||||
* main.scm (www:get): Pass url as single arg.
|
||||
(Thanks to Dale P. Smith.)
|
||||
|
||||
1998-07-27 Jim Blandy <jimb@red-bean.com>
|
||||
|
||||
* Test of EGCS repository access.
|
||||
|
||||
1997-12-24 Tim Pierce <twp@skepsis.com>
|
||||
|
||||
* cgi.scm (init-environment): Make server-software and
|
||||
server-protocol optional.
|
||||
|
||||
1997-12-22 Tim Pierce <twp@skepsis.com>
|
||||
|
||||
* cgi.scm (read-raw-form-data): Add `cgi-' to content-length.
|
||||
(parse-form): Change `url-decode' to `url:decode'.
|
||||
|
||||
Mon Oct 20 18:06:10 1997 Jim Blandy <jimb@totoro.red-bean.com>
|
||||
|
||||
* configure.in: Update version to 1.0b.
|
||||
configure: Regenerated.
|
||||
|
||||
* Makefile.in, aclocal.m4, configure: Regenerated w/automake 1.2c.
|
||||
|
||||
* url.scm (url:scheme, url:host, url:port, url:path): Move
|
||||
accessors up.
|
||||
(url:address): New accessor for "mailto:" URLs.
|
||||
(url:unknown): New accessor for unrecognized URL types.
|
||||
(url:user): New accessor for "ftp" URLs.
|
||||
(url:make, url:make-http, url:make-ftp, url:make-mailto): New
|
||||
constructors for URL objects.
|
||||
(url-regexp): Replaced by...
|
||||
(http-regexp, ftp-regexp, mailto-regexp): Separate regular
|
||||
expressions for different URL schemes.
|
||||
(url:parse): Use the above to handle ftp and mailto URLs, and also
|
||||
do something graceful with unrecognized garbage.
|
||||
(url:unparse): New function, for turning a parsed url into a
|
||||
string.
|
||||
|
||||
* http.scm (add-open-connection!, get-open-connection): Incomplete
|
||||
code replaced with dummy definitions, so we can give it to Mikael
|
||||
immediately.
|
||||
(http:request): Close the socket after we're done reading the
|
||||
body.
|
||||
|
||||
* http.scm (http:request): Reformatted for readability.
|
||||
|
||||
* http.scm (http:request): Don't expect a body in reply to a
|
||||
"HEAD" request, even though we do get a "content-length" header.
|
||||
|
||||
Tue Jun 17 17:27:04 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
|
||||
|
||||
* http.scm: (http:request): Force "/" onto the beginning of the
|
||||
"path" variable unconditionally. We must do this because of a
|
||||
stupid incompatibility between the URL RFC and HTTP RFC.
|
||||
|
||||
* http.scm: (parse-status-line): New function.
|
||||
(http:request): Use parse-status-line instead of
|
||||
separate-fields-discarding-char (which does not work when a status
|
||||
line contains more than two spaces).
|
||||
(separate-fields-discarding-char): Removed.
|
||||
|
||||
Tue Jun 17 01:45:59 1997 Tim Pierce <twp@twp.tezcat.com>
|
||||
|
||||
* http.scm (http:request): Change calling conventions to accept a
|
||||
method and a URL rather than a port and request string. Do some
|
||||
sanity checking on arguments.
|
||||
(http:get): Pass a single URL argument to http:request.
|
||||
(http:open): Permit port argument to be #f in addition to '().
|
||||
(display-with-crlf): Make port argument optional.
|
||||
(add-open-connection!): Braino fix (set! for setq).
|
||||
|
||||
* Makefile: New file. (Oops.)
|
||||
|
||||
Mon Jun 16 17:49:20 1997 Tim Pierce <twpierce@bio-5.bsd.uchicago.edu>
|
||||
|
||||
Release preparations.
|
||||
* Makefile.am, configure.in, install-sh, mkinstalldirs, missing:
|
||||
New files.
|
||||
* Makefile.in, configure, aclocal.m4: Generated, not re.
|
||||
* README: New file.
|
||||
|
||||
Sun Jun 15 00:50:22 1997 Tim Pierce <twp@twp.tezcat.com>
|
||||
|
||||
* http.scm: add some support for persistent connections.
|
||||
(http:connect): check get-open-connection before creating a new
|
||||
socket, and call add-open-connection! after creating one.
|
||||
(add-open-connection!): New function.
|
||||
(get-open-connection): New function.
|
||||
|
||||
Mon Jun 9 23:42:32 1997 Tim Pierce <twp@twp.tezcat.com>
|
||||
|
||||
New WWW module.
|
||||
* cgi.scm: New file.
|
||||
* http.scm: New file.
|
||||
* main.scm: New file.
|
||||
* url.scm: New file.
|
||||
* wwwcat: New file.
|
||||
|
||||
@ -1,39 +0,0 @@
|
||||
|
||||
if GNC_HAVE_GUILE_WWW
|
||||
|
||||
# Do nothing.
|
||||
|
||||
else # !GNC_HAVE_GUILE_WWW
|
||||
|
||||
gncscmdir = ${GNC_SHAREDIR}/guile-modules/www
|
||||
gncscm_DATA = cgi.scm http.scm main.scm url.scm
|
||||
|
||||
noinst_DATA = .scm-links
|
||||
|
||||
if GNUCASH_SEPARATE_BUILDDIR
|
||||
SCM_FILE_LINKS = ${gncscm_DATA}
|
||||
endif
|
||||
|
||||
.scm-links:
|
||||
$(RM) -rf www
|
||||
mkdir -p www
|
||||
if GNUCASH_SEPARATE_BUILDDIR
|
||||
for X in ${SCM_FILE_LINKS} ; do \
|
||||
$(LN_S) -f ${srcdir}/$$X . ; \
|
||||
done
|
||||
endif
|
||||
( cd www; for A in $(gncscm_DATA) ; do $(LN_S) -f ../$$A . ; done )
|
||||
if ! OS_WIN32
|
||||
# Windows knows no "ln -s" but uses "cp": must copy every time (see bug #566567).
|
||||
touch .scm-links
|
||||
endif
|
||||
|
||||
clean-local:
|
||||
$(RM) -rf www
|
||||
|
||||
CLEANFILES = .scm-links
|
||||
DISTCLEANFILES = ${SCM_FILE_LINKS}
|
||||
|
||||
endif # GNC_HAVE_GUILE_WWW (else clause)
|
||||
|
||||
EXTRA_DIST = README README.gnucash wwwcat cgi.scm http.scm main.scm url.scm
|
||||
@ -1,66 +0,0 @@
|
||||
This is an alpha release of the Guile WWW library, version 1.0.
|
||||
|
||||
Roadmap:
|
||||
|
||||
The (www http) library includes some support for navigating HTTP
|
||||
connections. http:open, http:request and http:get may be used for
|
||||
opening connections and making HTTP requests; http:make-message,
|
||||
http:message-body and http:message-header may be used to
|
||||
manipulate HTTP messages. Support is planned for the full
|
||||
HTTP/1.1 protocol, including cookies and persistent connections.
|
||||
|
||||
(www url) provides url:parse for parsing a URL into its component
|
||||
parts, and the selector functions url:scheme, url:host, url:port
|
||||
and url:path for selecting individual components of a parsed URL.
|
||||
For individual components that may have been URL-encoded in
|
||||
transit, url:decode translates a string into its raw (unencoded)
|
||||
form.
|
||||
|
||||
(www cgi) provides some functions helpful in writing CGI scripts
|
||||
painlessly. The focus is on scripts to process interactive forms.
|
||||
cgi:init reads any form data and initializes a CGI environment.
|
||||
cgi:form-data? determines whether any form data has been returned
|
||||
by a browser for processing. cgi-value returns the value
|
||||
associated with a form variable, and cgi-names and cgi-values
|
||||
return all of the names and values present in the current form.
|
||||
|
||||
(www main) provides www:get, which decodes a URL and invokes the
|
||||
appropriate protocol handler for retrieving the desired object.
|
||||
It is intended to be a generic interface useful for retriving data
|
||||
named by any URL.
|
||||
|
||||
wwwcat is an example script of how www:get and other functions
|
||||
might be used by a Guile application.
|
||||
|
||||
A generic guide to hacking on Guile software follows.
|
||||
|
||||
Tim Pierce
|
||||
twp@tezcat.com
|
||||
|
||||
Hacking It Yourself ==================================================
|
||||
|
||||
As distributed, the Guile WWW library needs only a Unix system to build
|
||||
and install. However, its makefiles, configuration scripts, and a few
|
||||
other files are automatically generated, not written by hand. If you
|
||||
want to make changes to the system (which we encourage!) you will find
|
||||
it helpful to have the tools we use to develop it. They are the
|
||||
following:
|
||||
|
||||
Autoconf 2.12 --- a system for automatically generating `configure'
|
||||
scripts from templates which list the non-portable features a
|
||||
program would like to use. Available in
|
||||
"ftp://prep.ai.mit.edu/pub/gnu".
|
||||
|
||||
Automake 1.1p --- a system for automatically generating Makefiles that
|
||||
conform to the (rather Byzantine) GNU coding standards. The
|
||||
nice thing is that it takes care of hairy targets like 'make
|
||||
dist' and 'make distclean', and automatically generates
|
||||
Makefile dependencies. Available in
|
||||
"ftp://ftp.cygnus.com/pub/tromey".
|
||||
|
||||
libtool 0.9d --- a system for managing the zillion hairy options needed
|
||||
on various systems to produce shared libraries. Available in
|
||||
"ftp://alpha.gnu.ai.mit.edu/gnu".
|
||||
|
||||
You are lost in a little maze of automatically generated files, all
|
||||
different.
|
||||
@ -1,8 +0,0 @@
|
||||
|
||||
This is a stripped down version of the guile-www CVS module. All of
|
||||
the automakery has been removed and it's been reconfigured to work
|
||||
with gnucash. In the long run, we'll probably switch to use whatever
|
||||
becomes the guile standard for www access.
|
||||
|
||||
This code is only used if we don't detect that you have a functional
|
||||
(www main) module via (use-modules (www main)) during configure.
|
||||
@ -1,185 +0,0 @@
|
||||
;;;; cgi.scm: Common Gateway Interface support for WWW scripts.
|
||||
|
||||
(define-module (www cgi)
|
||||
:use-module (www url))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; 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, 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 software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
(define form-variables '())
|
||||
|
||||
;;; CGI environment variables.
|
||||
;;; Should these all be public?
|
||||
|
||||
(define-public cgi-server-software-type #f)
|
||||
(define-public cgi-server-software-version #f)
|
||||
(define-public cgi-server-hostname #f)
|
||||
(define-public cgi-gateway-interface #f)
|
||||
(define-public cgi-server-protocol-name #f)
|
||||
(define-public cgi-server-protocol-version #f)
|
||||
(define-public cgi-server-port #f)
|
||||
(define-public cgi-request-method #f)
|
||||
(define-public cgi-path-info #f)
|
||||
(define-public cgi-path-translated #f)
|
||||
(define-public cgi-script-name #f)
|
||||
(define-public cgi-query-string #f)
|
||||
(define-public cgi-remote-host #f)
|
||||
(define-public cgi-remote-addr #f)
|
||||
(define-public cgi-authentication-type #f)
|
||||
(define-public cgi-remote-user #f)
|
||||
(define-public cgi-remote-ident #f)
|
||||
(define-public cgi-content-type #f)
|
||||
(define-public cgi-content-length #f)
|
||||
(define-public cgi-http-accept-types #f)
|
||||
(define-public cgi-http-user-agent #f)
|
||||
|
||||
|
||||
;;; CGI high-level interface
|
||||
;;;
|
||||
;;; A typical CGI program will first call (cgi:init) to initialize
|
||||
;;; the environment and read in any data returned from a form. Form
|
||||
;;; data can be extracted conveniently with these functions:
|
||||
;;;
|
||||
;;; (cgi:values NAME)
|
||||
;;; Fetch any values associated with NAME found in the form data.
|
||||
;;; Returned value is a list, even if it contains only one element.
|
||||
;;; (cgi:value NAME)
|
||||
;;; Fetch only the CAR from (cgi:values NAME). Convenient for when
|
||||
;;; you are certain that NAME is associated with only one value.
|
||||
|
||||
(define-public (cgi:init)
|
||||
(init-environment)
|
||||
(and cgi-content-length
|
||||
(parse-form (read-raw-form-data)))
|
||||
(and cgi-query-string
|
||||
(parse-form cgi-query-string)))
|
||||
|
||||
(define-public (cgi:values name)
|
||||
(assoc-ref form-variables name))
|
||||
|
||||
(define-public (cgi:value name)
|
||||
;; syntactic sugar for obtaining just one value from a particular key
|
||||
(let ((values (cgi:values name)))
|
||||
(and values (car values))))
|
||||
|
||||
(define-public (cgi:names) (map car form-variables))
|
||||
|
||||
(define-public (cgi:form-data?) (not (null? form-variables)))
|
||||
|
||||
|
||||
;;;; Internal functions.
|
||||
;;;;
|
||||
;;;; (parse-form DATA): parse DATA as raw form response data, adding
|
||||
;;;; values as necessary to `form-variables'.
|
||||
;;;; (read-raw-form-data): read in `content-length' bytes from stdin
|
||||
;;;; (init-environment): initialize CGI environment from Unix env vars.
|
||||
|
||||
(define (parse-form raw-data)
|
||||
;; get-name and get-value are used to parse individual `name=value' pairs.
|
||||
;; Values are URL-encoded, so url:decode must be called on each one.
|
||||
(define (get-name pair)
|
||||
(let ((p (string-index pair #\=)))
|
||||
(and p (substring pair 0 p))))
|
||||
(define (get-value pair)
|
||||
(let ((p (string-index pair #\=)))
|
||||
(and p (url:decode (substring pair (+ p 1))))))
|
||||
(for-each (lambda (pair)
|
||||
(let* ((name (get-name pair))
|
||||
(value (get-value pair))
|
||||
(old-value (cgi:values name)))
|
||||
(set! form-variables
|
||||
(assoc-set! form-variables
|
||||
name
|
||||
(cons value (or old-value '()))))))
|
||||
(separate-fields-discarding-char #\& raw-data)))
|
||||
|
||||
(define (read-raw-form-data)
|
||||
(and cgi-content-length (read-n-chars cgi-content-length)))
|
||||
|
||||
(define (init-environment)
|
||||
|
||||
;; SERVER_SOFTWARE format: name/version
|
||||
(let ((server-software (getenv "SERVER_SOFTWARE")))
|
||||
(if server-software
|
||||
(let ((slash (string-index server-software #\/)))
|
||||
(set! cgi-server-software-type (substring server-software 0 slash))
|
||||
(set! cgi-server-software-version (substring server-software (1+ slash))))))
|
||||
|
||||
(set! cgi-server-hostname (getenv "SERVER_NAME"))
|
||||
(set! cgi-gateway-interface (getenv "GATEWAY_INTERFACE"));"CGI/revision"
|
||||
|
||||
(let* ((server-protocol (getenv "SERVER_PROTOCOL")))
|
||||
(if server-protocol
|
||||
(let ((slash (string-index server-protocol #\/)))
|
||||
(set! cgi-server-protocol-name (substring server-protocol 0 slash))
|
||||
(set! cgi-server-protocol-version (substring server-protocol (1+ slash))))))
|
||||
|
||||
(let ((port (getenv "SERVER_PORT")))
|
||||
(set! cgi-server-port (and port (string->number port))))
|
||||
|
||||
(set! cgi-request-method (getenv "REQUEST_METHOD"))
|
||||
(set! cgi-path-info (getenv "PATH_INFO"))
|
||||
(set! cgi-path-translated (getenv "PATH_TRANSLATED"))
|
||||
(set! cgi-script-name (getenv "SCRIPT_NAME"))
|
||||
(set! cgi-remote-host (getenv "REMOTE_HOST"))
|
||||
(set! cgi-remote-addr (getenv "REMOTE_ADDR"))
|
||||
(set! cgi-authentication-type (getenv "AUTH_TYPE"))
|
||||
(set! cgi-remote-user (getenv "REMOTE_USER"))
|
||||
(set! cgi-remote-ident (getenv "REMOTE_IDENT"))
|
||||
(set! cgi-content-type (getenv "CONTENT_TYPE"))
|
||||
(set! cgi-query-string (getenv "QUERY_STRING"))
|
||||
|
||||
(and cgi-query-string
|
||||
(string-null? cgi-query-string)
|
||||
(set! cgi-query-string #f))
|
||||
|
||||
(let ((contlen (getenv "CONTENT_LENGTH")))
|
||||
(set! cgi-content-length (and contlen (string->number contlen))))
|
||||
|
||||
;; HTTP_ACCEPT is a list of MIME types separated by commas.
|
||||
(let ((types (getenv "HTTP_ACCEPT")))
|
||||
(set! cgi-http-accept-types
|
||||
(and types (separate-fields-discarding-char #\, types))))
|
||||
|
||||
;; HTTP_USER_AGENT format: software/version library/version.
|
||||
(set! cgi-http-user-agent (getenv "HTTP_USER_AGENT")))
|
||||
|
||||
|
||||
;;; System I/O and low-level stuff.
|
||||
|
||||
(define (read-n-chars num . port-arg)
|
||||
(let ((p (if (null? port-arg)
|
||||
(current-input-port)
|
||||
(car port-arg)))
|
||||
(s (make-string num)))
|
||||
(do ((i 0 (+ i 1))
|
||||
(ch (read-char p) (read-char p)))
|
||||
((or (>= i num) (eof-object? ch)) s)
|
||||
(string-set! s i ch))))
|
||||
|
||||
;; This is defined in #/ice-9/string-fun, but the interface is
|
||||
;; weird, the semantics perverse, and it doesn't work. We use
|
||||
;; a working copy here.
|
||||
(define (separate-fields-discarding-char ch str)
|
||||
(let loop ((fields '())
|
||||
(str str))
|
||||
(let ((pos (string-rindex str ch)))
|
||||
(if pos
|
||||
(loop (cons (substring str (+ 1 pos)) fields)
|
||||
(substring str 0 pos))
|
||||
(cons str fields)))))
|
||||
@ -1,302 +0,0 @@
|
||||
;;;; http.scm: HTTP client library for Guile.
|
||||
;;;;
|
||||
|
||||
(define-module (www http)
|
||||
:use-module (www url)
|
||||
:use-module (ice-9 regex))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; 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, 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 software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
;;; Compatibility
|
||||
|
||||
(or (defined? 'read-line)
|
||||
(use-modules (ice-9 rdelim)))
|
||||
|
||||
|
||||
;;; Variables that affect HTTP usage.
|
||||
|
||||
(define-public http:version "HTTP/1.0") ; bump up to 1.1 when ready
|
||||
(define-public http:user-agent "GuileHTTP 0.1")
|
||||
|
||||
;;; An HTTP message is represented by a vector:
|
||||
;;; #(VERSION STATUS-CODE STATUS-TEXT HEADERS BODY)
|
||||
;;;
|
||||
;;; Each of VERSION, STATUS-CODE, STATUS-TEXT are strings. HEADERS
|
||||
;;; is an alist of headers and their contents. BODY is a single string.
|
||||
|
||||
(define (http:make-message version statcode stattext headers body)
|
||||
(vector version statcode stattext headers body))
|
||||
|
||||
;;;; HTTP status predicates.
|
||||
;;;
|
||||
;;; (http:message-version MSG)
|
||||
;;; Returns the HTTP version in use in HTTP message MSG.
|
||||
;;;
|
||||
;;; (http:message-status-code MSG)
|
||||
;;; Returns the status code returned in HTTP message MSG.
|
||||
;;;
|
||||
;;; (http:message-status-text MSG)
|
||||
;;; Returns the text of the status line from HTTP message MSG.
|
||||
;;;
|
||||
;;; (http:message-status-ok? STATUS)
|
||||
;;; Returns #t if status code STATUS indicates a successful request,
|
||||
;;; #f otherwise.
|
||||
|
||||
(define-public (http:message-version msg) (vector-ref msg 0))
|
||||
(define-public (http:message-status-code msg) (vector-ref msg 1))
|
||||
(define-public (http:message-status-text msg) (vector-ref msg 2))
|
||||
(define-public (http:message-status-ok? msg)
|
||||
(http:status-ok? (http:status-code msg)))
|
||||
(define-public (http:status-ok? status)
|
||||
(char=? #\2 (string-ref status 0)))
|
||||
|
||||
(define-public (http:message-body msg) (vector-ref msg 4))
|
||||
|
||||
;;; HTTP response headers functions
|
||||
;;;
|
||||
;;; An HTTP message header is represented here by a pair. The CAR is a
|
||||
;;; symbol representing the header name, and the CDR is a string
|
||||
;;; containing the header text. E.g.:
|
||||
;;;
|
||||
;;; '((date . "Thu, 29 May 1997 23:48:27 GMT")
|
||||
;;; (server . "NCSA/1.5.1")
|
||||
;;; (last-modified . "Tue, 06 May 1997 18:32:03 GMT")
|
||||
;;; (content-type . "text/html")
|
||||
;;; (content-length . "8097"))
|
||||
;;;
|
||||
;;; Note: these symbols are all lowercase, although the original headers
|
||||
;;; were mixed-case. Clients using this library should keep this in
|
||||
;;; mind, since Guile symbols are case-sensitive.
|
||||
;;;
|
||||
;;; FIXME: should headers with known semantics be parsed automatically?
|
||||
;;; I.e. should the Content-Length header automatically get string->number?
|
||||
;;; Should Date and Last-Modified headers be run through strptime?
|
||||
;;; It is advantageous to keep headers in a uniform format, but it may
|
||||
;;; be convenient to parse headers that have unambiguous meanings.
|
||||
;;;
|
||||
;;; (http:message-headers MSG)
|
||||
;;; Returns a list of the headers from HTTP message MSG.
|
||||
;;; (http:message-header HEADER MSG)
|
||||
;;; Return the header field named HEADER from HTTP message MSG, or
|
||||
;;; #f if no such header is present in the message.
|
||||
|
||||
(define-public (http:message-headers msg) (vector-ref msg 3))
|
||||
(define-public (http:message-header header msg)
|
||||
(http:fetch-header header (http:message-headers msg)))
|
||||
|
||||
(define (http:fetch-header header header-alist)
|
||||
(assq-ref header-alist header))
|
||||
|
||||
(define header-regex (make-regexp ": *"))
|
||||
|
||||
(define (http:header-parse hd)
|
||||
(let ((match (regexp-exec header-regex hd)))
|
||||
(cons (string->symbol
|
||||
(apply string
|
||||
(map char-downcase
|
||||
(string->list (match:prefix match)))))
|
||||
(match:suffix match))))
|
||||
|
||||
(define (parse-status-line statline)
|
||||
(let* ((first (string-index statline #\space))
|
||||
(second (string-index statline #\space (1+ first))))
|
||||
(list (substring statline 0 first)
|
||||
(substring statline (1+ first) second)
|
||||
(substring statline (1+ second)))))
|
||||
|
||||
|
||||
;;; HTTP connection management functions.
|
||||
;;;
|
||||
;;; Open connections are cached on hostname in the connection-table.
|
||||
;;; If an HTTP connection is already open to a particular host and TCP port,
|
||||
;;; looking up the hostname and port number in connection-table will yield
|
||||
;;; a Scheme port that may be used to communicate with that server.
|
||||
|
||||
(define connection-table '())
|
||||
|
||||
;; FIXME: you can only re-use a connection if the server sends the
|
||||
;; Keep-Alive header, I think. With these definitions, we were trying to
|
||||
;; send more requests on connections the server assumed were dead.
|
||||
;; (define (add-open-connection! host tcp-port port)
|
||||
;; (set! connection-table
|
||||
;; (assoc-set! connection-table (cons host tcp-port) port)))
|
||||
;; (define (get-open-connection host tcp-port)
|
||||
;; (assoc-ref connection-table (cons host tcp-port)))
|
||||
|
||||
(define (add-open-connection! host tcp-port port)
|
||||
#f)
|
||||
(define (get-open-connection host tcp-port)
|
||||
#f)
|
||||
|
||||
|
||||
;;; HTTP methods.
|
||||
;;;
|
||||
;;; Common methods: GET, POST etc.
|
||||
|
||||
(define-public (http:get url)
|
||||
;; FIXME: if http:open returns an old connection that has been
|
||||
;; closed remotely, this will fail.
|
||||
(http:request "GET" url))
|
||||
|
||||
;;; Connection-oriented functions:
|
||||
;;;
|
||||
;;; (http:open HOST [PORT])
|
||||
;;; Return an HTTP connection to HOST on TCP port PORT (default 80).
|
||||
;;; If an open connection already exists, use it; otherwise, create
|
||||
;;; a new socket.
|
||||
|
||||
(define-public (http:open host . args)
|
||||
(let ((port (cond ((null? args) 80)
|
||||
((not (car args)) 80)
|
||||
(else (car args)))))
|
||||
(or (get-open-connection host port)
|
||||
(let* ((tcp (vector-ref (getproto "tcp") 2))
|
||||
(addr (car (vector-ref (gethost host) 4)))
|
||||
(sock (socket AF_INET SOCK_STREAM tcp)))
|
||||
(connect sock AF_INET addr port)
|
||||
(add-open-connection! host port sock)
|
||||
sock))))
|
||||
|
||||
;;; (http:request METHOD URL [HEADERS [BODY]])
|
||||
;;; Submit an HTTP request.
|
||||
;;; URL is a structure returned by url:parse.
|
||||
;;; METHOD is the name of some HTTP method, e.g. "GET" or "POST".
|
||||
;;; The optional HEADERS and BODY arguments are lists of strings
|
||||
;;; which describe HTTP messages. The `Content-Length' header
|
||||
;;; is calculated automatically and should not be supplied.
|
||||
;;;
|
||||
;;; Example usage:
|
||||
;;; (http:request "get" parsed-url
|
||||
;;; (list "User-Agent: GuileHTTP 0.1"
|
||||
;;; "Content-Type: text/plain"))
|
||||
;;; (http:request "post" parsed-url
|
||||
;;; (list "User-Agent: GuileHTTP 0.1"
|
||||
;;; "Content-Type: unknown/x-www-form-urlencoded")
|
||||
;;; (list "search=Gosper"
|
||||
;;; "case=no"
|
||||
;;; "max_hits=50"))
|
||||
|
||||
(define-public (http:request method url . args)
|
||||
(let ((host (url:host url))
|
||||
(tcp-port (or (url:port url) 80))
|
||||
(path (string-append "/" (or (url:path url) ""))))
|
||||
(let ((sock (http:open host tcp-port))
|
||||
(request (string-append method " " path " " http:version))
|
||||
(headers (if (pair? args) (car args) '()))
|
||||
(body (if (and (pair? args) (pair? (cdr args)))
|
||||
(cadr args)
|
||||
'())))
|
||||
(let* ((content-length
|
||||
(apply +
|
||||
(map (lambda (line)
|
||||
(+ 2 (string-length line))) ; + 2 for CRLF
|
||||
body)))
|
||||
(headers (if (positive? content-length)
|
||||
(cons (string-append "Content-Length: "
|
||||
(number->string content-length))
|
||||
headers)
|
||||
headers)))
|
||||
|
||||
(with-output-to-port sock
|
||||
(lambda ()
|
||||
(display-with-crlf request)
|
||||
(for-each display-with-crlf headers)
|
||||
(display "\r\n")
|
||||
(for-each display-with-crlf body)))
|
||||
|
||||
;; parse and add status line
|
||||
;; also cons up a list of response headers
|
||||
(let* ((response-status-line (sans-trailing-whitespace
|
||||
(read-line sock 'trim)))
|
||||
(response-headers
|
||||
(let make-header-list ((ln (sans-trailing-whitespace
|
||||
(read-line sock 'trim)))
|
||||
(hlist '()))
|
||||
(if (= 0 (string-length ln))
|
||||
hlist
|
||||
(make-header-list (sans-trailing-whitespace
|
||||
(read-line sock 'trim))
|
||||
(cons (http:header-parse ln)
|
||||
hlist)))))
|
||||
(response-status-fields
|
||||
(parse-status-line response-status-line))
|
||||
(response-version (car response-status-fields))
|
||||
(response-code (cadr response-status-fields))
|
||||
(response-text (caddr response-status-fields)))
|
||||
|
||||
;; signal error if HTTP status is invalid
|
||||
;; (or (http:status-ok? response-code)
|
||||
;; (error 'http-status "HTTP server returned bad status"
|
||||
;; response-status-line))
|
||||
;; Get message body: if Content-Length header was supplied, read
|
||||
;; that many chars. Otherwise, read until EOF
|
||||
|
||||
(let ((content-length (http:fetch-header
|
||||
"content-length"
|
||||
response-headers)))
|
||||
(let ((response-body
|
||||
(if (and content-length
|
||||
(not (string-ci=? method "HEAD")))
|
||||
(read-n-chars (string->number content-length) sock)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(while (not (eof-object? (peek-char sock)))
|
||||
(display (read-char sock))))))))
|
||||
|
||||
;; FIXME: what about keepalives?
|
||||
(close-port sock)
|
||||
|
||||
(http:make-message response-version
|
||||
response-code
|
||||
response-text
|
||||
response-headers
|
||||
response-body))))))))
|
||||
|
||||
|
||||
|
||||
;;;; System interface cruft & string funcs
|
||||
|
||||
(define (read-n-chars num . port-arg)
|
||||
(let ((p (if (null? port-arg)
|
||||
(current-input-port)
|
||||
(car port-arg)))
|
||||
(s (make-string num)))
|
||||
(do ((i 0 (+ i 1))
|
||||
(ch (read-char p) (read-char p)))
|
||||
((or (>= i num) (eof-object? ch)) s)
|
||||
(string-set! s i ch))))
|
||||
|
||||
(define (display-with-crlf line . p)
|
||||
(apply display line p)
|
||||
(apply display "\r\n" p))
|
||||
|
||||
;;; (sans-trailing-whitespace STR)
|
||||
;;; These are defined in module #/ice-9/string-fun, so this code
|
||||
;;; will prob. be discarded when the module system and boot-9
|
||||
;;; settle down.
|
||||
|
||||
(define (sans-trailing-whitespace s)
|
||||
(let ((st 0)
|
||||
(end (string-length s)))
|
||||
(while (and (< 0 end)
|
||||
(char-whitespace? (string-ref s (1- end))))
|
||||
(set! end (1- end)))
|
||||
(if (< end st)
|
||||
""
|
||||
(substring s st end))))
|
||||
@ -1,49 +0,0 @@
|
||||
;;;; www/main.scm: general WWW navigation aids.
|
||||
|
||||
(define-module (www main)
|
||||
:use-module (www http)
|
||||
:use-module (www url))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; 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, 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 software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
(define dispatch-table
|
||||
(acons 'http http:get '()))
|
||||
|
||||
;;; (www:get URL)
|
||||
;;; parse a URL into portions, open a connection, and retrieve
|
||||
;;; selected document
|
||||
|
||||
(define-public (www:set-protocol-handler! proto handler)
|
||||
(set! dispatch-table
|
||||
(assq-set! dispatch-table proto handler)))
|
||||
|
||||
(define-public (www:get url-str)
|
||||
(let ((url (url:parse url-str)))
|
||||
;; get handler for this protocol
|
||||
(case (url:scheme url)
|
||||
((http) (let ((msg (http:get url)))
|
||||
(http:message-body msg)))
|
||||
(else
|
||||
(let ((handle (assq-ref dispatch-table (url:scheme url))))
|
||||
(if handle
|
||||
(handle (url:host url)
|
||||
(url:port url)
|
||||
(url:path url))
|
||||
(error "unknown URL scheme" (url:scheme url))))))))
|
||||
|
||||
@ -1,152 +0,0 @@
|
||||
;;;; url.scm: URL manipulation tools.
|
||||
|
||||
(define-module (www url)
|
||||
:use-module (ice-9 regex))
|
||||
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; 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, 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 software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
;;;; TODO:
|
||||
;;;; * support `user:password@' strings where appropriate in URLs.
|
||||
;;;; * make URL parsing smarter. This is good for most TCP/IP-based
|
||||
;;;; URL schemes, but parsing is actually specific to each URL scheme.
|
||||
;;;; * fill out url:encode, include facilities for URL-scheme-specific
|
||||
;;;; encoding methods (e.g. a url-scheme-reserved-char-alist)
|
||||
|
||||
;; `url:scheme' is an unfortunate term, but it is the technical
|
||||
;; name for that portion of the URL according to RFC 1738. Sigh.
|
||||
|
||||
(define-public (url:scheme url) (vector-ref url 0))
|
||||
(define-public (url:address url) (vector-ref url 1))
|
||||
(define-public (url:unknown url) (vector-ref url 1))
|
||||
(define-public (url:user url) (vector-ref url 1))
|
||||
(define-public (url:host url) (vector-ref url 2))
|
||||
(define-public (url:port url) (vector-ref url 3))
|
||||
(define-public (url:path url) (vector-ref url 4))
|
||||
|
||||
(define-public (url:make scheme . args)
|
||||
(apply vector scheme args))
|
||||
(define-public (url:make-http host port path)
|
||||
(vector 'http #f host port path))
|
||||
(define-public (url:make-ftp user host port path)
|
||||
(vector 'ftp user host port path))
|
||||
(define-public (url:make-mailto address)
|
||||
(vector 'mailto address))
|
||||
|
||||
(define http-regexp (make-regexp "^http://([^:/]+)(:([0-9]+))?(/(.*))?$"))
|
||||
(define ftp-regexp
|
||||
(make-regexp "^ftp://(([^@:/]+)@)?([^:/]+)(:([0-9]+))?(/(.*))?$"))
|
||||
(define mailto-regexp (make-regexp "^mailto:(.*)$"))
|
||||
|
||||
(define-public (url:parse url)
|
||||
(cond
|
||||
((regexp-exec http-regexp url)
|
||||
=> (lambda (m)
|
||||
(url:make-http (match:substring m 1)
|
||||
(cond ((match:substring m 3) => string->number)
|
||||
(else #f))
|
||||
(match:substring m 5))))
|
||||
|
||||
((regexp-exec ftp-regexp url)
|
||||
=> (lambda (m)
|
||||
(url:make-ftp (match:substring m 2)
|
||||
(match:substring m 3)
|
||||
(cond ((match:substring m 5) => string->number)
|
||||
(else #f))
|
||||
(match:substring m 7))))
|
||||
|
||||
((regexp-exec mailto-regexp url)
|
||||
=> (lambda (m)
|
||||
(url:make-mailto (match:substring m 1))))
|
||||
|
||||
(else
|
||||
(url:make 'unknown url))))
|
||||
|
||||
|
||||
(define-public (url:unparse url)
|
||||
(define (pathy scheme username host port path)
|
||||
(string-append (symbol->string scheme)
|
||||
"://" host
|
||||
(if port (string-append ":" (number->string port))
|
||||
"")
|
||||
(if path (string-append "/" path)
|
||||
"")))
|
||||
(case (url:scheme url)
|
||||
((http) (pathy 'http #f
|
||||
(url:host url)
|
||||
(url:port url)
|
||||
(url:path url)))
|
||||
((ftp) (pathy 'ftp
|
||||
(url:user url)
|
||||
(url:host url)
|
||||
(url:port url)
|
||||
(url:path url)))
|
||||
((mailto) (string-append "mailto:" (url:address url)))
|
||||
((unknown) (url:unknown url))))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; (url-decode STR)
|
||||
;; Turn + into space, and hex-encoded %XX strings into their
|
||||
;; eight-bit characters. Is a regexp faster than character
|
||||
;; scanning? Does it incur more overhead (which may be more
|
||||
;; important for code that frequently gets restarted)?
|
||||
|
||||
(define-public (url:decode str)
|
||||
(regexp-substitute/global #f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str
|
||||
'pre
|
||||
(lambda (m)
|
||||
(cond ((string=? "+" (match:substring m 0)) " ")
|
||||
(else (integer->char
|
||||
(string->number
|
||||
(match:substring m 1)
|
||||
16)))))
|
||||
'post))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; (url-encode STR)
|
||||
;; The inverse of url-decode. Can't be done easily with
|
||||
;; a regexp: we would have to construct a regular expression
|
||||
;; like "[\277-\377]", for example, and Guile strings don't
|
||||
;; let you interpolate character literals. Pity.
|
||||
;; URL-encode any characters in STR that are not safe: these
|
||||
;; include any character not in the SAFE-CHARS list and any
|
||||
;; character that *is* in the RESERVED-CHARS list argument.
|
||||
|
||||
(define-public (url:encode str reserved-chars)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(for-each (lambda (ch)
|
||||
(if (and (safe-char? ch)
|
||||
(not (memv ch reserved-chars)))
|
||||
(display ch)
|
||||
(begin
|
||||
(display #\%)
|
||||
(display (number->string (char->integer ch) 16)))))
|
||||
(string->list str)))))
|
||||
|
||||
(define safe-chars
|
||||
'(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\, #\; #\/ #\? #\: #\@ #\& #\=))
|
||||
|
||||
(define (safe-char? ch)
|
||||
;; ``Thus, only alphanumerics, the special characters "$-_.+!*'(),", and
|
||||
;; reserved characters used for their reserved purposes may be used
|
||||
;; unencoded within a URL.'' RFC 1738, #2.2.
|
||||
(or (char-alphabetic? ch)
|
||||
(char-numeric? ch)
|
||||
(memv ch safe-chars)))
|
||||
@ -1,28 +0,0 @@
|
||||
#!/usr/local/opt/guile-cvs/bin/guile -s
|
||||
!#
|
||||
|
||||
;;;; wwwcat: a trivial `cat' program for WWW resources.
|
||||
;;;;
|
||||
;;;; Copyright (C) 1997 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; 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, 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 software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
(use-modules (www main))
|
||||
|
||||
(if (program-arguments)
|
||||
(display (www:get (list-ref (program-arguments) 1)))
|
||||
(display "wwwget: no document specified" (current-error-port)))
|
||||
22226
po/kok@latin.po
Normal file
22226
po/kok@latin.po
Normal file
File diff suppressed because it is too large
Load Diff
@ -64,6 +64,7 @@ static gnc_euro_rate_struct gnc_euro_rates[] =
|
||||
{ "LFR", 40.3399 }, /* luxembourg franc */
|
||||
{ "LIT", 1936.27 }, /* italian lira */
|
||||
{ "LUF", 40.3399 }, /* luxembourg franc */
|
||||
{ "LVL", .702804 }, /* latvian lats */
|
||||
{ "MTL", .429300 }, /* maltese lira */
|
||||
{ "NLG", 2.20371 }, /* netherland gulden */
|
||||
{ "PTA", 166.386 }, /* spanish peseta */
|
||||
|
||||
@ -69,6 +69,7 @@ xmlNodePtr
|
||||
gnc_address_to_dom_tree (const char *tag, GncAddress *addr)
|
||||
{
|
||||
xmlNodePtr ret;
|
||||
kvp_frame *kf;
|
||||
|
||||
ret = xmlNewNode(NULL, BAD_CAST tag);
|
||||
xmlSetProp(ret, BAD_CAST "version", BAD_CAST address_version_string);
|
||||
@ -84,6 +85,16 @@ gnc_address_to_dom_tree (const char *tag, GncAddress *addr)
|
||||
maybe_add_string (ret, addr_fax_string, gncAddressGetFax (addr));
|
||||
maybe_add_string (ret, addr_email_string, gncAddressGetEmail (addr));
|
||||
|
||||
kf = qof_instance_get_slots (QOF_INSTANCE(addr));
|
||||
if (kf)
|
||||
{
|
||||
xmlNodePtr kvpnode = kvp_frame_to_dom_tree(addr_slots_string, kf);
|
||||
if (kvpnode)
|
||||
{
|
||||
xmlAddChild(ret, kvpnode);
|
||||
}
|
||||
}
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
@ -175,7 +186,10 @@ address_email_handler (xmlNodePtr node, gpointer addr_pdata)
|
||||
static gboolean
|
||||
address_slots_handler (xmlNodePtr node, gpointer addr_pdata)
|
||||
{
|
||||
return TRUE;
|
||||
struct address_pdata *pdata = addr_pdata;
|
||||
|
||||
return dom_tree_to_kvp_frame_given
|
||||
(node, xaccAccountGetSlots (pdata->address));
|
||||
}
|
||||
|
||||
static struct dom_tree_handler address_handlers_v2[] =
|
||||
|
||||
@ -115,6 +115,7 @@ entry_dom_tree_create (GncEntry *entry)
|
||||
GncTaxTable *taxtable;
|
||||
GncOrder *order;
|
||||
GncInvoice *invoice;
|
||||
kvp_frame *kf;
|
||||
|
||||
ret = xmlNewNode(NULL, BAD_CAST gnc_entry_string);
|
||||
xmlSetProp(ret, BAD_CAST "version", BAD_CAST entry_version_string);
|
||||
@ -211,6 +212,16 @@ entry_dom_tree_create (GncEntry *entry)
|
||||
xmlAddChild (ret, guid_to_dom_tree (entry_order_string,
|
||||
qof_instance_get_guid(QOF_INSTANCE (order))));
|
||||
|
||||
kf = qof_instance_get_slots (QOF_INSTANCE(entry));
|
||||
if (kf)
|
||||
{
|
||||
xmlNodePtr kvpnode = kvp_frame_to_dom_tree(entry_slots_string, kf);
|
||||
if (kvpnode)
|
||||
{
|
||||
xmlAddChild(ret, kvpnode);
|
||||
}
|
||||
}
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
@ -661,7 +672,10 @@ entry_price_handler (xmlNodePtr node, gpointer entry_pdata)
|
||||
static gboolean
|
||||
entry_slots_handler (xmlNodePtr node, gpointer entry_pdata)
|
||||
{
|
||||
return TRUE;
|
||||
struct entry_pdata *pdata = entry_pdata;
|
||||
|
||||
return dom_tree_to_kvp_frame_given
|
||||
(node, xaccAccountGetSlots (pdata->entry));
|
||||
}
|
||||
|
||||
static struct dom_tree_handler entry_handlers_v2[] =
|
||||
|
||||
@ -66,6 +66,7 @@ static xmlNodePtr
|
||||
job_dom_tree_create (GncJob *job)
|
||||
{
|
||||
xmlNodePtr ret;
|
||||
kvp_frame *kf;
|
||||
|
||||
ret = xmlNewNode(NULL, BAD_CAST gnc_job_string);
|
||||
xmlSetProp(ret, BAD_CAST "version", BAD_CAST job_version_string);
|
||||
@ -87,6 +88,16 @@ job_dom_tree_create (GncJob *job)
|
||||
xmlAddChild(ret, int_to_dom_tree(job_active_string,
|
||||
gncJobGetActive (job)));
|
||||
|
||||
kf = qof_instance_get_slots (QOF_INSTANCE(job));
|
||||
if (kf)
|
||||
{
|
||||
xmlNodePtr kvpnode = kvp_frame_to_dom_tree(job_slots_string, kf);
|
||||
if (kvpnode)
|
||||
{
|
||||
xmlAddChild(ret, kvpnode);
|
||||
}
|
||||
}
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
@ -193,7 +204,10 @@ job_active_handler (xmlNodePtr node, gpointer job_pdata)
|
||||
static gboolean
|
||||
job_slots_handler (xmlNodePtr node, gpointer job_pdata)
|
||||
{
|
||||
return TRUE;
|
||||
struct job_pdata *pdata = job_pdata;
|
||||
|
||||
return dom_tree_to_kvp_frame_given
|
||||
(node, xaccAccountGetSlots (pdata->job));
|
||||
}
|
||||
|
||||
static struct dom_tree_handler job_handlers_v2[] =
|
||||
|
||||
@ -76,6 +76,7 @@ order_dom_tree_create (GncOrder *order)
|
||||
{
|
||||
xmlNodePtr ret;
|
||||
Timespec ts;
|
||||
kvp_frame *kf;
|
||||
|
||||
ret = xmlNewNode(NULL, BAD_CAST gnc_order_string);
|
||||
xmlSetProp(ret, BAD_CAST "version", BAD_CAST order_version_string);
|
||||
@ -102,6 +103,16 @@ order_dom_tree_create (GncOrder *order)
|
||||
xmlAddChild(ret, int_to_dom_tree(order_active_string,
|
||||
gncOrderGetActive (order)));
|
||||
|
||||
kf = qof_instance_get_slots (QOF_INSTANCE(order));
|
||||
if (kf)
|
||||
{
|
||||
xmlNodePtr kvpnode = kvp_frame_to_dom_tree(order_slots_string, kf);
|
||||
if (kvpnode)
|
||||
{
|
||||
xmlAddChild(ret, kvpnode);
|
||||
}
|
||||
}
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
@ -234,7 +245,10 @@ order_active_handler (xmlNodePtr node, gpointer order_pdata)
|
||||
static gboolean
|
||||
order_slots_handler (xmlNodePtr node, gpointer order_pdata)
|
||||
{
|
||||
return TRUE;
|
||||
struct order_pdata *pdata = order_pdata;
|
||||
|
||||
return dom_tree_to_kvp_frame_given
|
||||
(node, xaccAccountGetSlots (pdata->order));
|
||||
}
|
||||
|
||||
static struct dom_tree_handler order_handlers_v2[] =
|
||||
|
||||
@ -104,6 +104,7 @@ taxtable_dom_tree_create (GncTaxTable *table)
|
||||
{
|
||||
xmlNodePtr ret, entries;
|
||||
GList *list;
|
||||
kvp_frame *kf;
|
||||
|
||||
ret = xmlNewNode(NULL, BAD_CAST gnc_taxtable_string);
|
||||
xmlSetProp(ret, BAD_CAST "version", BAD_CAST taxtable_version_string);
|
||||
@ -130,6 +131,16 @@ taxtable_dom_tree_create (GncTaxTable *table)
|
||||
xmlAddChild(entries, ttentry_dom_tree_create (entry));
|
||||
}
|
||||
|
||||
kf = qof_instance_get_slots (QOF_INSTANCE(table));
|
||||
if (kf)
|
||||
{
|
||||
xmlNodePtr kvpnode = kvp_frame_to_dom_tree(taxtable_slots_string, kf);
|
||||
if (kvpnode)
|
||||
{
|
||||
xmlAddChild(ret, kvpnode);
|
||||
}
|
||||
}
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
@ -368,7 +379,10 @@ taxtable_entries_handler (xmlNodePtr node, gpointer taxtable_pdata)
|
||||
static gboolean
|
||||
taxtable_slots_handler (xmlNodePtr node, gpointer taxtable_pdata)
|
||||
{
|
||||
return TRUE;
|
||||
struct taxtable_pdata *pdata = taxtable_pdata;
|
||||
|
||||
return dom_tree_to_kvp_frame_given
|
||||
(node, xaccAccountGetSlots (pdata->table));
|
||||
}
|
||||
|
||||
static struct dom_tree_handler taxtable_handlers_v2[] =
|
||||
|
||||
@ -43,6 +43,7 @@ static gncFeature known_features[] =
|
||||
{
|
||||
{ GNC_FEATURE_CREDIT_NOTES, "Customer and vendor credit notes (requires at least GnuCash 2.5.0)" },
|
||||
{ GNC_FEATURE_NUM_FIELD_SOURCE, "User specifies source of 'num' field'; either transaction number or split action (requires at least GnuCash 2.5.0)" },
|
||||
{ GNC_FEATURE_KVP_EXTRA_DATA, "Extra data for addresses, jobs or invoice entries (requires at least GnuCash 2.6.4)" },
|
||||
{ NULL },
|
||||
};
|
||||
|
||||
|
||||
@ -36,11 +36,14 @@
|
||||
#ifndef GNC_FEATURES_H
|
||||
#define GNC_FEATURES_H
|
||||
|
||||
#include "libqof/qof/qof.h"
|
||||
|
||||
/** @name Defined features
|
||||
@{
|
||||
*/
|
||||
#define GNC_FEATURE_CREDIT_NOTES "Credit Notes"
|
||||
#define GNC_FEATURE_NUM_FIELD_SOURCE "Number Field Source"
|
||||
#define GNC_FEATURE_KVP_EXTRA_DATA "Extra data in addresses, jobs or invoice entries"
|
||||
|
||||
/** @} */
|
||||
|
||||
|
||||
@ -32,6 +32,7 @@
|
||||
#include "gncAddress.h"
|
||||
#include "gncAddressP.h"
|
||||
#include "gncCustomerP.h"
|
||||
#include "gnc-features.h"
|
||||
|
||||
struct _gncAddress
|
||||
{
|
||||
@ -492,6 +493,10 @@ static void address_free (QofInstance *inst)
|
||||
|
||||
void gncAddressCommitEdit (GncAddress *addr)
|
||||
{
|
||||
/* GnuCash 2.6.3 and earlier didn't handle address kvp's... */
|
||||
if (!kvp_frame_is_empty (addr->inst.kvp_data))
|
||||
gnc_features_set_used (qof_instance_get_book (QOF_INSTANCE (addr)), GNC_FEATURE_KVP_EXTRA_DATA);
|
||||
|
||||
if (!qof_commit_edit (QOF_INSTANCE(addr))) return;
|
||||
qof_commit_edit_part2 (&addr->inst, gncAddressOnError,
|
||||
gncAddressOnDone, address_free);
|
||||
|
||||
@ -33,6 +33,7 @@
|
||||
|
||||
#include "gncEntry.h"
|
||||
#include "gncEntryP.h"
|
||||
#include "gnc-features.h"
|
||||
#include "gncInvoice.h"
|
||||
#include "gncOrder.h"
|
||||
|
||||
@ -1505,6 +1506,10 @@ static void entry_free (QofInstance *inst)
|
||||
|
||||
void gncEntryCommitEdit (GncEntry *entry)
|
||||
{
|
||||
/* GnuCash 2.6.3 and earlier didn't handle entry kvp's... */
|
||||
if (!kvp_frame_is_empty (entry->inst.kvp_data))
|
||||
gnc_features_set_used (qof_instance_get_book (QOF_INSTANCE (entry)), GNC_FEATURE_KVP_EXTRA_DATA);
|
||||
|
||||
if (!qof_commit_edit (QOF_INSTANCE(entry))) return;
|
||||
qof_commit_edit_part2 (&entry->inst, gncEntryOnError,
|
||||
gncEntryOnDone, entry_free);
|
||||
|
||||
@ -31,6 +31,7 @@
|
||||
#include <glib.h>
|
||||
#include <string.h>
|
||||
|
||||
#include "gnc-features.h"
|
||||
#include "gncInvoice.h"
|
||||
#include "gncJob.h"
|
||||
#include "gncJobP.h"
|
||||
@ -366,6 +367,10 @@ static void gncJobOnDone (QofInstance *qof) { }
|
||||
|
||||
void gncJobCommitEdit (GncJob *job)
|
||||
{
|
||||
/* GnuCash 2.6.3 and earlier didn't handle job kvp's... */
|
||||
if (!kvp_frame_is_empty (job->inst.kvp_data))
|
||||
gnc_features_set_used (qof_instance_get_book (QOF_INSTANCE (job)), GNC_FEATURE_KVP_EXTRA_DATA);
|
||||
|
||||
if (!qof_commit_edit (QOF_INSTANCE(job))) return;
|
||||
qof_commit_edit_part2 (&job->inst, gncJobOnError,
|
||||
gncJobOnDone, job_free);
|
||||
|
||||
@ -30,6 +30,7 @@
|
||||
|
||||
#include <glib.h>
|
||||
|
||||
#include "gnc-features.h"
|
||||
#include "gncTaxTableP.h"
|
||||
|
||||
struct _gncTaxTable
|
||||
@ -649,6 +650,10 @@ static void table_free (QofInstance *inst)
|
||||
|
||||
void gncTaxTableCommitEdit (GncTaxTable *table)
|
||||
{
|
||||
/* GnuCash 2.6.3 and earlier didn't handle taxtable kvp's... */
|
||||
if (!kvp_frame_is_empty (table->inst.kvp_data))
|
||||
gnc_features_set_used (qof_instance_get_book (QOF_INSTANCE (table)), GNC_FEATURE_KVP_EXTRA_DATA);
|
||||
|
||||
if (!qof_commit_edit (QOF_INSTANCE(table))) return;
|
||||
qof_commit_edit_part2 (&table->inst, gncTaxTableOnError,
|
||||
gncTaxTableOnDone, table_free);
|
||||
|
||||
@ -139,7 +139,7 @@
|
||||
( "Loti" "loti" "sente" "ISO4217" "LSL" "426" 100 100 "M" )
|
||||
( "Lithuanian Litas" "litas" "centas" "ISO4217" "LTL" "440" 100 100 "Lt" )
|
||||
( "Luxembourg Franc" "frang" "centime" "ISO4217" "LUF" "442" 100 100 "Flux" ) ;; 2002-01-01 "EUR" 40.3399
|
||||
( "Latvian Lats" "lats" "santīms" "ISO4217" "LVL" "428" 100 100 "Ls" )
|
||||
( "Latvian Lats" "lats" "santīms" "ISO4217" "LVL" "428" 100 100 "Ls" ) ;; Valid from 2. may 2009. till 31. december 2013, now "EUR" 0.702804
|
||||
( "Libyan Dinar" "dinar" "dirham" "ISO4217" "LYD" "434" 1000 1000 "ل.د" )
|
||||
( "Moroccan Dirham" "dirham" "centime" "ISO4217" "MAD" "504" 100 100 "د.م" )
|
||||
( "Moldovan Leu" "leu" "ban" "ISO4217" "MDL" "498" 100 100 "" )
|
||||
|
||||
@ -135,6 +135,24 @@
|
||||
(define gnc:html-barchart-subtitle
|
||||
(record-accessor <html-barchart> 'subtitle))
|
||||
|
||||
;; Note: Due to Bug726449 the input string's non-printable control
|
||||
;; characters must translated to HTML format tags BEFORE
|
||||
;; or WHEN calling this function.
|
||||
;; AND:
|
||||
;; To ensure that the generated subtitle doesn't contain any
|
||||
;; unescaped quotes or backslashes, all strings must be freed
|
||||
;; from those by calling jqplot-escape-string.
|
||||
;; Otherwise we're opening the gates again for bug 721768.
|
||||
;;
|
||||
;; Example: "\n" must be translated to "<br /> to introduce
|
||||
;; a line break into the chart subtitle.
|
||||
;;
|
||||
;; Example call:
|
||||
;; (gnc:html-barchart-set-subtitle! chart
|
||||
;; (string-append "Bgt:"
|
||||
;; (jqplot-escape-string (number->string bgt-sum))
|
||||
;; "<br /> Act:" ;; line break in the chart sub-title
|
||||
;; (jqplot-escape-string (number->string act-sum))))
|
||||
(define gnc:html-barchart-set-subtitle!
|
||||
(record-modifier <html-barchart> 'subtitle))
|
||||
|
||||
@ -452,9 +470,9 @@
|
||||
|
||||
(if subtitle
|
||||
(begin
|
||||
(push " options.title += \" (")
|
||||
(push (jqplot-escape-string subtitle))
|
||||
(push ")\";\n")))
|
||||
(push " options.title += \" <br />")
|
||||
(push subtitle)
|
||||
(push "\";\n")))
|
||||
|
||||
(if (and (string? x-label) (> (string-length x-label) 0))
|
||||
(begin
|
||||
|
||||
@ -34,6 +34,10 @@
|
||||
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
;; included since Bug726449
|
||||
(use-modules (ice-9 regex)) ;; for regexp-substitute/global, used by jpqplot
|
||||
(load-from-path "html-jqplot.scm") ;; for jqplot-escape-string
|
||||
|
||||
(define reportname (N_ "Budget Barchart"))
|
||||
|
||||
(define optname-accounts (N_ "Accounts"))
|
||||
@ -153,7 +157,10 @@
|
||||
(gnc:html-barchart-set-row-labels! chart date-list)
|
||||
(if running-sum
|
||||
(gnc:html-barchart-set-subtitle! chart
|
||||
(string-append "Bgt:" (number->string bgt-sum) "\n Act:" (number->string act-sum))))
|
||||
(string-append "Bgt:"
|
||||
(jqplot-escape-string (number->string bgt-sum))
|
||||
"<br /> Act:"
|
||||
(jqplot-escape-string (number->string act-sum)))))
|
||||
)
|
||||
|
||||
;; Reutrn newly created chart
|
||||
|
||||
@ -35,6 +35,10 @@
|
||||
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
;; included since Bug726449
|
||||
(use-modules (ice-9 regex)) ;; for regexp-substitute/global, used by jpqplot
|
||||
(load-from-path "html-jqplot.scm") ;; for jqplot-escape-string
|
||||
|
||||
;; The option names are defined here to 1. save typing and 2. avoid
|
||||
;; spelling errors. The *reportnames* are defined here (and not only
|
||||
;; once at the very end) because I need them to define the "other"
|
||||
@ -454,8 +458,8 @@ developing over time"))
|
||||
(if do-intervals?
|
||||
(_ "%s to %s")
|
||||
(_ "Balances %s to %s"))
|
||||
(gnc-print-date from-date-tp)
|
||||
(gnc-print-date to-date-tp)))
|
||||
(jqplot-escape-string (gnc-print-date from-date-tp))
|
||||
(jqplot-escape-string (gnc-print-date to-date-tp))))
|
||||
(gnc:html-barchart-set-width! chart width)
|
||||
(gnc:html-barchart-set-height! chart height)
|
||||
|
||||
|
||||
@ -37,6 +37,10 @@
|
||||
|
||||
(gnc:module-load "gnucash/report/report-system" 0)
|
||||
|
||||
;; included since Bug726449
|
||||
(use-modules (ice-9 regex)) ;; for regexp-substitute/global, used by jpqplot
|
||||
(load-from-path "html-jqplot.scm") ;; for jqplot-escape-string
|
||||
|
||||
(define reportname (N_ "Income/Expense Chart"))
|
||||
|
||||
(define optname-from-date (N_ "Start Date"))
|
||||
@ -313,8 +317,8 @@
|
||||
(gnc:html-barchart-set-subtitle!
|
||||
chart (sprintf #f
|
||||
(_ "%s to %s")
|
||||
(gnc-print-date from-date-tp)
|
||||
(gnc-print-date to-date-tp)))
|
||||
(jqplot-escape-string (gnc-print-date from-date-tp))
|
||||
(jqplot-escape-string (gnc-print-date to-date-tp))))
|
||||
(gnc:html-barchart-set-width! chart width)
|
||||
(gnc:html-barchart-set-height! chart height)
|
||||
(gnc:html-barchart-set-row-labels! chart date-string-list)
|
||||
|
||||
@ -31,7 +31,7 @@
|
||||
(let ((chart (gnc:make-html-barchart))
|
||||
(text (gnc:make-html-text (gnc:html-markup-p "[bar goes here]"))))
|
||||
(gnc:html-barchart-set-title! chart "Bar Chart Title")
|
||||
(gnc:html-barchart-set-subtitle! chart "Bar Chart SubTitle")
|
||||
(gnc:html-barchart-set-subtitle! chart (jqplot-escape-string "Bar Chart SubTitle"))
|
||||
(gnc:html-barchart-append-row! chart '(25 45 30))
|
||||
(gnc:html-barchart-append-row! chart '(75 55 70))
|
||||
(gnc:html-barchart-set-width! chart 320)
|
||||
|
||||
@ -22,7 +22,6 @@
|
||||
|
||||
(define-module (gnucash price-quotes))
|
||||
|
||||
(export yahoo-get-historical-quotes)
|
||||
(export gnc:book-add-quotes) ;; called from gnome/dialog-price-edit-db.c
|
||||
(export gnc:price-quotes-install-sources)
|
||||
|
||||
@ -33,16 +32,6 @@
|
||||
(gnc:module-load "gnucash/gnome-utils" 0) ;; for gnucash-ui-is-running
|
||||
(gnc:module-load "gnucash/app-utils" 0)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Yahoo-based Historical Quotes
|
||||
;;
|
||||
|
||||
(use-modules (www main))
|
||||
(use-modules (srfi srfi-1))
|
||||
|
||||
;; (use-modules (srfi srfi-19)) when available (see below).
|
||||
|
||||
(define (item-list->hash! lst hash
|
||||
getkey getval
|
||||
hashref hashset
|
||||
@ -72,171 +61,6 @@
|
||||
(for-each handle-item lst)
|
||||
hash)
|
||||
|
||||
(define (yahoo-get-historical-quotes symbol
|
||||
start-year start-month start-day
|
||||
end-year end-month end-day)
|
||||
;; symbol must be a string naming the item of interest
|
||||
;; (i.e. "LNUX"), and all the other arguments must be integers.
|
||||
;; Abbreviated 2 digit years are not allowed, and months and days
|
||||
;; are numbered starting with 1.
|
||||
;;
|
||||
;; This function returns a list of alists containing the quote data,
|
||||
;; or #f on failure. Each alist will look like this:
|
||||
;;
|
||||
;; ((date . "21-Dec-1999")
|
||||
;; (open . 108.5)
|
||||
;; (high . 110.12)
|
||||
;; (low . 108.06)
|
||||
;; (close . 110.12)
|
||||
;; (volume . 4775500))
|
||||
;;
|
||||
;; Note that the dates are left as strings, but the years will
|
||||
;; always be 4 digits. The dates are left as strings for now
|
||||
;; because without additional timezone information, it is impossible
|
||||
;; to perform the conversion to UTC here. Further, it's not at all
|
||||
;; clear which UTC instant each price should represent...
|
||||
;;
|
||||
;; NOTE: right now, we can't handle dates before 1970. That's
|
||||
;; because to properly handle the fact that yahoo returns lame-ass 2
|
||||
;; digit years, we need to be able to compare the dates it returns
|
||||
;; using (+ year 1900) and (+ year 2000) to see which one is within
|
||||
;; the star-end range requested (at least that's one of the easiest
|
||||
;; ways to handle the problem). The most straightforward way to do
|
||||
;; this is via mktime, but it can't handle anything before the
|
||||
;; epoch. However, I believe SRFI-19 can
|
||||
;; (http://srfi.schemers.org/srfi-19/srfi-19.html), so as soon as we
|
||||
;; have a working implementation in guile, we can switch to that and
|
||||
;; handle essentially arbitrary ranges.
|
||||
;;
|
||||
;; For now we'll leave in the mktime based conversion code
|
||||
;; (commented out) so it'll be easy to switch later, but we'll
|
||||
;; actually use a simpler (and more broken) approach -- any 2 digit
|
||||
;; date >= 70 gets 1900 added, and any 2 digit date < 70 gets 2000
|
||||
;; added.
|
||||
|
||||
; (define (str->month month-str)
|
||||
; (cond
|
||||
; ((string-ci=? "Jan" month-str) 1)
|
||||
; ((string-ci=? "Feb" month-str) 2)
|
||||
; ((string-ci=? "Mar" month-str) 3)
|
||||
; ((string-ci=? "Apr" month-str) 4)
|
||||
; ((string-ci=? "May" month-str) 5)
|
||||
; ((string-ci=? "Jun" month-str) 6)
|
||||
; ((string-ci=? "Jul" month-str) 7)
|
||||
; ((string-ci=? "Aug" month-str) 8)
|
||||
; ((string-ci=? "Sep" month-str) 9)
|
||||
; ((string-ci=? "Oct" month-str) 10)
|
||||
; ((string-ci=? "Nov" month-str) 11)
|
||||
; ((string-ci=? "Dec" month-str) 12)
|
||||
; (else #f)))
|
||||
|
||||
; (define (ymd->secs year month day)
|
||||
; (let ((timevec (localtime 0)))
|
||||
; (display (list 'foo year month day)) (newline)
|
||||
; (set-tm:sec timevec 59)
|
||||
; (set-tm:min timevec 59)
|
||||
; (set-tm:hour timevec 23)
|
||||
; (set-tm:mday timevec day)
|
||||
; (set-tm:mon timevec (- month 1))
|
||||
; (set-tm:year timevec (- year 1900))
|
||||
; (set-tm:wday timevec -1)
|
||||
; (set-tm:yday timevec -1)
|
||||
; (set-tm:isdst timevec -1)
|
||||
; (display timevec) (newline)
|
||||
; (car (mktime timevec))))
|
||||
|
||||
; (define (fix-lame-ass-date-if-needed! quote)
|
||||
; (let* ((date-str (vector-ref quote 0))
|
||||
; (date-list (and date-str (string-split date-str #\-)))
|
||||
; (year-str (and date-list (caddr date-list))))
|
||||
; (if (= (string-length year-str) 2)
|
||||
; (let* ((day (string->number (car date-list)))
|
||||
; (month (str->month (cadr date-list)))
|
||||
; (year (string->number year-str))
|
||||
; (start-secs (ymd->secs start-year start-month start-day))
|
||||
; (end-secs (ymd->secs end-year end-month end-day))
|
||||
; (guess-1900 (ymd->secs (+ year 1900) month day)))
|
||||
|
||||
; (if (and (>= guess-1900 start-secs)
|
||||
; (<= guess-1900 end-secs))
|
||||
; (vector-set! quote 0 (string-append (car date-list) "-"
|
||||
; (cadr date-list) "-"
|
||||
; (number->string
|
||||
; (+ year 1900))))
|
||||
; (let ((guess-2000 (ymd->secs (+ year 2000) month day)))
|
||||
|
||||
; (if (and (>= guess-2000 start-secs)
|
||||
; (<= guess-2000 end-secs))
|
||||
; (vector-set! quote 0 (string-append (car date-list) "-"
|
||||
; (cadr date-list) "-"
|
||||
; (number->string
|
||||
; (+ year 2000))))
|
||||
; (vector-set! quote 0 #f))))))))
|
||||
|
||||
(define (fix-lame-ass-date-if-needed! quote-data)
|
||||
(let* ((date-str (assq-ref quote-data 'date))
|
||||
(date-list (and date-str (string-split date-str #\-)))
|
||||
(year-str (and date-list (caddr date-list))))
|
||||
|
||||
(if (= (string-length year-str) 2)
|
||||
(let* ((day (car date-list))
|
||||
(month (cadr date-list))
|
||||
(year (string->number year-str)))
|
||||
(assq-set!
|
||||
quote-data
|
||||
'date
|
||||
(string-append (car date-list) "-"
|
||||
(cadr date-list) "-"
|
||||
(number->string
|
||||
(+ year (if (>= year 70)
|
||||
1900
|
||||
2000)))))))))
|
||||
|
||||
(define (quote-line->quote-alist line)
|
||||
(let ((fields (string-split line #\,)))
|
||||
(cond
|
||||
((= 6 (length fields))
|
||||
(map
|
||||
(lambda (name value) (cons name value))
|
||||
'(date open high low close volume)
|
||||
(cons (car fields) (map string->number (cdr fields)))))
|
||||
((zero? (string-length line))
|
||||
'ignore)
|
||||
(else
|
||||
#f))))
|
||||
|
||||
(define (csv-str->quotes str)
|
||||
(let ((lines (string-split str #\newline)))
|
||||
(if (string=? (car lines) "Date,Open,High,Low,Close,Volume")
|
||||
(let ((result (map quote-line->quote-alist (cdr lines))))
|
||||
(if (any not result)
|
||||
#f
|
||||
(begin
|
||||
(set! result
|
||||
(filter (lambda (x) (not (eq? 'ignore x))) result))
|
||||
(for-each fix-lame-ass-date-if-needed! result)
|
||||
result)))
|
||||
#f)))
|
||||
|
||||
(if (< start-year 1970)
|
||||
#f
|
||||
(let* ((request (string-append
|
||||
"http://chart.yahoo.com/table.csv?"
|
||||
"s=" symbol
|
||||
"&a=" (number->string start-month)
|
||||
"&b=" (number->string start-day)
|
||||
"&c=" (number->string start-year)
|
||||
"&d=" (number->string end-month)
|
||||
"&e=" (number->string end-day)
|
||||
"&f=" (number->string end-year)
|
||||
"&g=d&q=q&y=0"))
|
||||
(result (www:get request)))
|
||||
|
||||
(if result
|
||||
(or (csv-str->quotes result)
|
||||
result)
|
||||
#f))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define gnc:*finance-quote-check*
|
||||
|
||||
Loading…
Reference in New Issue
Block a user