IntenseFinance/gnucash
3
0
Fork 0
mirror of https://github.com/Gnucash/gnucash.git synced 2026-07-29 15:53:45 -05:00
Code Issues Packages Projects Releases Wiki Activity

2001-04-17 Rob Browning <rlb@cs.utexas.edu>

Browse Source 
* src/scm/utilities.scm (string-split): used to be string-split-on
	in qif-utils.scm

	* src/scm/qif-import/qif-utils.scm: move string-split-on to
	utilities.scm as string-split to better match string-join.

	* src/scm/qif-import/qif-to-gnc.scm (qif-import:qif-to-gnc):
	string-split-on -> string-split.

	* src/scm/qif-import/qif-dialog-utils.scm
	(qif-import:get-all-accts): string-split-on -> string-split.

	* src/scm/price-quotes.scm (yahoo-get-historical-quotes): new
	function - retrieve lists of historical quote information.

	* src/scm/bootstrap.scm.in (%load-path): add new guile-modules
	directory so we can use-modules from there.

	* src/guile/Makefile.am (CLEANFILES): add gnucash.c so it goes
	away on "make clean" in addition to "make distclean".

	* src/engine/gnc-pricedb.c: minor doc updates.

	* src/engine/gnc-pricedb.h: much more documentation.

	* lib/guile-www: new directory - contains guile-www CVS module.
	Used by new historical quote function.  Several new files added.
	Installed to new install directory GNC_SHAREDIR/guile-modules such
	that it is available via (use-modules (www main)), etc.

	* lib/Makefile.am (SUBDIRS): add guile-www

	* configure.in (AC_OUTPUT): add lib/guile-www/Makefile


git-svn-id: svn+ssh://svn.gnucash.org/repo/gnucash/trunk@3988 57a11ea4-9604-0410-9ed3-97b8803252fd
This commit is contained in:
Dave Peticolas
2001-04-17 21:37:38 +00:00
parent b5e8d20903
commit 1a63b7f75d
21 changed files with 1296 additions and 76 deletions
Download Patch File Download Diff File Expand all files Collapse all files
ChangeLog
+36
View File
@@ -1,3 +1,39 @@
2001-04-17 Rob Browning <rlb@cs.utexas.edu>
* src/scm/utilities.scm (string-split): used to be string-split-on
in qif-utils.scm
* src/scm/qif-import/qif-utils.scm: move string-split-on to
utilities.scm as string-split to better match string-join.
* src/scm/qif-import/qif-to-gnc.scm (qif-import:qif-to-gnc):
string-split-on -> string-split.
* src/scm/qif-import/qif-dialog-utils.scm
(qif-import:get-all-accts): string-split-on -> string-split.
* src/scm/price-quotes.scm (yahoo-get-historical-quotes): new
function - retrieve lists of historical quote information.
* src/scm/bootstrap.scm.in (%load-path): add new guile-modules
directory so we can use-modules from there.
* src/guile/Makefile.am (CLEANFILES): add gnucash.c so it goes
away on "make clean" in addition to "make distclean".
* src/engine/gnc-pricedb.c: minor doc updates.
* src/engine/gnc-pricedb.h: much more documentation.
* lib/guile-www: new directory - contains guile-www CVS module.
Used by new historical quote function. Several new files added.
Installed to new install directory GNC_SHAREDIR/guile-modules such
that it is available via (use-modules (www main)), etc.
* lib/Makefile.am (SUBDIRS): add guile-www
* configure.in (AC_OUTPUT): add lib/guile-www/Makefile
2001-04-17 Dave Peticolas <dave@krondo.com>
* src/gnome/file-history.c: fix bug
configure.in
+1
View File
@@ -551,6 +551,7 @@ AC_OUTPUT(
doc-tools/Makefile
intl/Makefile
lib/Makefile
lib/guile-www/Makefile
macros/Makefile
po/Makefile.in
po/Makefile
lib/Makefile.am
+3
View File
@@ -1,2 +1,5 @@
SUBDIRS = guile-www
EXTRA_DIST = \
README
lib/guile-www/.cvsignore
+4
View File
@@ -0,0 +1,4 @@
Makefile
config.cache
config.log
config.status
lib/guile-www/ChangeLog
+106
View File
@@ -0,0 +1,106 @@
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.
lib/guile-www/Makefile.am
+5
View File
@@ -0,0 +1,5 @@
gncscmdir = ${GNC_SHAREDIR}/guile-modules/www
gncscm_DATA = cgi.scm http.scm main.scm url.scm
EXTRA_DIST = README README.gnucash wwwcat
lib/guile-www/README
+66
View File
@@ -0,0 +1,66 @@
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.
lib/guile-www/README.gnucash
+7
View File
@@ -0,0 +1,7 @@
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.
lib/guile-www/cgi.scm
+185
View File
@@ -0,0 +1,185 @@
;;;; 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 (make-shared-substring pair 0 p))))
(define (get-value pair)
(let ((p (string-index pair #\=)))
(and p (url:decode (make-shared-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 (make-shared-substring str (+ 1 pos)) fields)
(make-shared-substring str 0 pos))
(cons str fields)))))
lib/guile-www/http.scm
+302
View File
@@ -0,0 +1,302 @@
;;;; 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 (make-shared-substring statline 0 first)
(make-shared-substring statline (1+ first) second)
(make-shared-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)
""
(make-shared-substring s st end))))
lib/guile-www/main.scm
+49
View File
@@ -0,0 +1,49 @@
;;;; 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))))))))
lib/guile-www/url.scm
+152
View File
@@ -0,0 +1,152 @@
;;;; 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)))
lib/guile-www/wwwcat
Executable
+28
View File
@@ -0,0 +1,28 @@
#!/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)))
src/engine/gnc-pricedb.c
+4 -5
View File
@@ -295,14 +295,13 @@ gnc_price_list_destroy(GList *prices)
/****************************************************************************/
/* GNCPriceDB functions
A pricedb is a hash mapping price commodities (of type
gnc_commodity*) to hashes mapping price currencies (of type
gnc_commodity*) to price lists. The top-level key is the commodity
Structurally a GNCPriceDB contains a hash mapping price commodities
(of type gnc_commodity*) to hashes mapping price currencies (of
type gnc_commodity*) to GNCPrice lists (see gnc-pricedb.h for a
description of GNCPrice lists). The top-level key is the commodity
you want the prices for, and the second level key is the commodity
that the value is expressed in terms of.
See the header for other info.
*/
GNCPriceDB *
src/engine/gnc-pricedb.h
+141 -51
View File
@@ -30,59 +30,114 @@
#include <stdio.h>
/**********************************************************************\
Introduction:
The PriceDB is intended to be a database of price quotes, or more
specifically, a database of GNCPrices. For the time being, it is
still a fairly simple database supporting only fairly simple
queries. It is expected that new queries will be added as needed,
and that there is some advantage to delaying complex queries for
now in the hope that we get a real DB implementation before
they're really needed.
Every GNCBook contains a GNCPriceDB, accessable via
gnc_book_get_pricedb.
*/
/**********************************************************************\
GNCPrice:
commodity: the item being priced.
Each price in the database represents an "instantaneous" quote for
a given commodity with respect to another commodity. For example,
a given price might represent the value of LNUX in USD on
2001-02-03.
value: the value of the item being priced.
Fields:
currency: the denomination of the value of the item being priced.
commodity: the item being priced.
time: the time the price was valid.
currency: the denomination of the value of the item being priced.
source: a string describing the source of the quote. These
strings will be something like this: "Finance::Quote",
"user:misc", "user:foo", etc. If the quote came from a user, as a
matter of policy, you *must* prefix the string you give with
"user:". For now, the only other reserved values are
"Finance::Quote" and "old-file-import".
value: the value of the item being priced.
type: the type of quote - types possible right now are bid, ask,
last, and unknown.
time: the time the price was valid.
NOTE: for source and type, NULL and the empty string are
considered the same, so if one of these is "", then after a file
save/restore, it might be NULL. Behave accordingly.
source: a string describing the source of the quote. These
strings will be something like this: "Finance::Quote",
"user:misc", "user:foo", etc. If the quote came from a user,
as a matter of policy, you *must* prefix the string you give
with "user:". For now, the only other reserved values are
"Finance::Quote" and "old-file-import".
GNCPrices are reference counted. When you gnc_price_create one or
clone it, the new price's count is set to 1. When you're finished
with a price, call gnc_price_unref. If you hand the pointer to
some other code that needs to keep it, make sure it calls
gnc_price_ref to indicate it's interest in that price, and calls
gnc_price_unref when it's finished with the price.
type: the type of quote - types possible right now are bid, ask,
last, and unknown.
All of the getters return data that's internal to the GNCPrice,
not copies, so don't free these values.
Implementation Details:
All of the setters store copies of the data, with the exception of
the commodity field which just stores the pointer given. It is
assumed that commodities are a global resource and are pointer
unique.
NOTE: for source and type, NULL and the empty string are
considered the same, so if one of these is "", then after a file
save/restore, it might be NULL. Behave accordingly.
GNCPrices are reference counted. When you gnc_price_create one
or clone it, the new price's count is set to 1. When you are
finished with a price, call gnc_price_unref. If you hand the
price pointer to some other code that needs to keep it, make
sure it calls gnc_price_ref to indicate its interest in that
price, and calls gnc_price_unref when it's finished with the
price. For those unfamiliar with reference counting, basically
each price stores an integer count which starts at 1 and is
incremented every time someone calls gnc_price_ref. Conversely,
the count is decremented every time someone calls
gnc_price_unref. If the count ever reaches 0, the price is
destroyed.
All of the getters return data that's internal to the GNCPrice,
not copies, so don't free these values.
All of the setters store copies of the data given, with the
exception of the commodity field which just stores the pointer
given. It is assumed that commodities are a global resource and
are pointer unique.
*/
typedef struct _GNCPrice GNCPrice;
/* allocation */
GNCPrice *gnc_price_create(void); /* create and initialize a price */
/****************/
/* constructors */
/* gnc_price_create - returns a newly allocated and initialized price
with a reference count of 1. */
GNCPrice *gnc_price_create(void);
/* gnc_price_clone - returns a newly allocated price that's a
content-wise duplicate of the given price, p. The returned clone
will have a reference count of 1. */
GNCPrice *gnc_price_clone(GNCPrice* p);
/*********************/
/* memory management */
/* gnc_price_ref - indicate your need for a given price to stick
around (i.e. increase its reference count by 1). */
void gnc_price_ref(GNCPrice *p);
/* gnc_price_ref - indicate you're finished with a price
(i.e. decrease its reference count by 1). */
void gnc_price_unref(GNCPrice *p);
/***********/
/* setters */
/* As mentioned above, all of the setters store copies of the data
given, with the exception of the commodity field which just stores
the pointer given. It is assumed that commodities are a global
resource and are pointer unique. */
void gnc_price_set_commodity(GNCPrice *p, gnc_commodity *c);
void gnc_price_set_currency(GNCPrice *p, gnc_commodity *c);
void gnc_price_set_time(GNCPrice *p, Timespec t);
@@ -90,7 +145,11 @@ void gnc_price_set_source(GNCPrice *p, const char *source);
void gnc_price_set_type(GNCPrice *p, const char* type);
void gnc_price_set_value(GNCPrice *p, gnc_numeric value);
/***********/
/* getters */
/* As mentioned above all of the getters return data that's internal
to the GNCPrice, not copies, so don't free these values. */
gnc_commodity * gnc_price_get_commodity(GNCPrice *p);
gnc_commodity * gnc_price_get_currency(GNCPrice *p);
Timespec gnc_price_get_time(GNCPrice *p);
@@ -98,15 +157,28 @@ const char * gnc_price_get_source(GNCPrice *p);
const char * gnc_price_get_type(GNCPrice *p);
gnc_numeric gnc_price_get_value(GNCPrice *p);
/* price_list funcs
/**********************************************************************
GNCPrice lists:
A price list is a time sorted GList of prices. The price list
maintains a ref for itself for all the prices in the list
(i.e. adding a price calls gnc_price_ref on it, removing a price
calls gnc_price_unref, etc. Destroying a list also removes this
list reference from the prices in the list. */
The database communicates multiple prices in and out via gnc price
lists. These are just time sorted GLists of GNCPrice pointers.
Functions for manipulating these lists are provided. These
functions are helpful in that they handle maintaining proper
reference counts on behalf of the price list for every price being
held in a given list. I.e. insert "refs" the prices being
inserted, remove and destroy "unref" the prices that will no
longer be referred to by the list.
*/
/* gnc_price_list_insert - insert a price into the given list, calling
gnc_price_ref on it during the process. */
gboolean gnc_price_list_insert(GList **prices, GNCPrice *p);
/* gnc_price_list_remove - remove the price, p, from the given list,
calling gnc_price_unref on it during the process. */
gboolean gnc_price_list_remove(GList **prices, GNCPrice *p);
/* gnc_price_list_destroy - destroy the given price list, calling
gnc_price_unref on all the prices included in the list. */
void gnc_price_list_destroy(GList *prices);
@@ -114,62 +186,80 @@ void gnc_price_list_destroy(GList *prices);
GNCPriceDB
Whenever a you store a price in the pricedb, the pricedb adds its
own reference to the price, so you can safely unref that price when
you're finished with it.
own reference to the price, so you can safely unref that price after
inserting it into the DB if you're finished with it otherwise.
Similarly, when the pricedb returns a price to you, either singly,
or in a price list, the price will have had a ref added for you, so
you only need to unref the price(s) when you're finished with them.
you only need to unref the price(s) when you're finished with
it/them.
*/
typedef struct _GNCPriceDB GNCPriceDB;
/* gnc_pricedb_create - create a new pricedb. Normally you won't need
this; you will get the pricedb via gnc_book_get_pricedb. */
GNCPriceDB * gnc_pricedb_create(void);
void gnc_pricedb_destroy(GNCPriceDB *db);
/* gnc_pricedb_destroy - destroy the given pricedb and unref all of
the prices it contains. This may not deallocate all of those
prices. Other code may still be holding references to them. */
void gnc_pricedb_destroy(GNCPriceDB *db);
/* Add a price to the pricedb, you may drop your reference to the
price (i.e. call unref) after this succeeds, whenever you're
finished with the price. */
/* gnc_pricedb_add_price - add a price to the pricedb, you may drop
your reference to the price (i.e. call unref) after this
succeeds, whenever you're finished with the price. */
gboolean gnc_pricedb_add_price(GNCPriceDB *db, GNCPrice *p);
/* Remove a price from the pricedb. */
/* gnc_pricedb_remove_price - removes the given price, p, from the
pricedb. Returns TRUE if successful, FALSE otherwise. */
gboolean gnc_pricedb_remove_price(GNCPriceDB *db, GNCPrice *p);
/* gnc_pricedb_lookup_latest - find the most recent price for the
given commodity in the given currency. Returns NULL on
failure. */
GNCPrice * gnc_pricedb_lookup_latest(GNCPriceDB *db,
gnc_commodity *commodity,
gnc_commodity *currency);
/* gnc_pricedb_get_prices - return all the prices for a given
commodity in the given currency. Returns NULL on failure. The
result is a GNCPrice list (see above). */
GList * gnc_pricedb_get_prices(GNCPriceDB *db,
gnc_commodity *commodity,
gnc_commodity *currency);
/* Return all prices that match the given commodity, currency, and
timespec. Prices will be returned as a price_list (see above) */
/* gnc_pricedb_lookup_at_time - return all prices that match the given
commodity, currency, and timespec. Prices will be returned as a
GNCPrice list (see above). */
GList * gnc_pricedb_lookup_at_time(GNCPriceDB *db,
gnc_commodity *commodity,
gnc_commodity *currency,
Timespec t);
/* Return the price that occurs nearest to t */
/* gnc_pricedb_lookup_nearest_in_time - return the price for the given
commodity in the given currency nearest to the given time t. */
GNCPrice *
gnc_pricedb_lookup_nearest_in_time(GNCPriceDB *db,
gnc_commodity *c,
gnc_commodity *currency,
Timespec t);
/* Call f once for each price in db, until and unless f returns FALSE.
If stable_order is not FALSE, make sure the ordering of the
traversal is stable (i.e. the same order every time given the same
db contents). */
/* gnc_pricedb_foreach_price - call f once for each price in db, until
and unless f returns FALSE. If stable_order is not FALSE, make
sure the ordering of the traversal is stable (i.e. the same order
every time given the same db contents -- stable traversals may be
less efficient). */
gboolean gnc_pricedb_foreach_price(GNCPriceDB *db,
gboolean (*f)(GNCPrice *p,
gpointer user_data),
gpointer user_data,
gboolean stable_order);
/* Return FALSE if the database has not been modified */
/* gnc_pricedb_dirty - return FALSE if the database has not been
modified. */
gboolean gnc_pricedb_dirty(GNCPriceDB *p);
/* semi-lame debugging code */
src/scm/bootstrap.scm.in
+4
View File
@@ -99,6 +99,10 @@
(define gnc:_help-dir-default_ "@-GNC_HELPDIR-@")
(define gnc:version "@-VERSION-@")
(set! %load-path
(cons (string-append gnc:_share-dir-default_ "/guile-modules")
%load-path))
;; These will be converted to config vars later (see prefs.scm)
(define gnc:*load-path* #f)
(define gnc:*debugging?* (if (getenv "GNC_DEBUG") #t #f))
src/scm/price-quotes.scm
+179
View File
@@ -27,6 +27,185 @@
(gnc:depend "utilities.scm")
(gnc:depend "engine-utilities.scm")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Yahoo-based Historical Quotes
;;
(use-modules (www main))
;; (use-modules (srfi srfi-19)) when available (see below).
(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))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Finance::Quote based instantaneous quotes -- used by the
;; --add-price-quotes command line option, etc.
;;
;; Note From: Dave Peticolas <dave@krondo.com> Date: Sun, 01 Apr 2001
;; Those aren't pricedb functions, those are online quote functions,
;; i.e., low-level functions for getting online-quotes and putting
src/scm/qif-import/qif-dialog-utils.scm
+5 -3
View File
@@ -9,6 +9,8 @@
(gnc:support "qif-import/qif-dialog-utils.scm")
(gnc:depend "utilities.scm")
(use-modules (ice-9 regex))
(define (default-stock-acct brokerage security)
@@ -696,8 +698,8 @@
(if (qif-map-entry:display? v)
(set! accts
(cons
(cons (string-split-on (qif-map-entry:gnc-name v)
separator)
(cons (string-split (qif-map-entry:gnc-name v)
separator)
(qif-map-entry:new-acct? v))
accts)))
#f)
@@ -709,7 +711,7 @@
(lambda (acct)
(set! accts
(cons
(cons (string-split-on
(cons (string-split
(gnc:account-get-full-name acct)
separator)
#f)
src/scm/qif-import/qif-to-gnc.scm
+6 -4
View File
@@ -9,6 +9,8 @@
(gnc:support "qif-import/qif-to-gnc.scm")
(gnc:depend "utilities.scm")
(define (gnc:qif-fuzzy= num-1 num-2)
(< (abs (- num-1 num-2)) .00000001))
@@ -252,12 +254,12 @@
(lambda (a b)
(let ((a-depth
(length
(string-split-on (qif-map-entry:gnc-name a)
separator)))
(string-split (qif-map-entry:gnc-name a)
separator)))
(b-depth
(length
(string-split-on (qif-map-entry:gnc-name b)
separator))))
(string-split (qif-map-entry:gnc-name b)
separator))))
(< a-depth b-depth)))))
;; make all the accounts
src/scm/qif-import/qif-utils.scm
-13
View File
@@ -60,19 +60,6 @@
(newstr (make-string 1 new)))
(regexp-substitute/global #f rexpstr str 'pre newstr 'post)))
(define (string-split-on str char)
(let ((parts '())
(first-char #f))
(let loop ((last-char (string-length str)))
(set! first-char (string-rindex str char 0 last-char))
(if first-char
(begin
(set! parts (cons (substring str (+ 1 first-char) last-char)
parts))
(loop first-char))
(set! parts (cons (substring str 0 last-char) parts))))
parts))
(define (string-to-canonical-symbol str)
(string->symbol
(string-downcase
src/scm/utilities.scm
+13
View File
@@ -146,3 +146,16 @@ string and 'directories' must be a list of strings."
'()
(cons joinstr (cons (car remaining-elements)
(loop (cdr remaining-elements)))))))))
(define (string-split str char)
(let ((parts '())
(first-char #f))
(let loop ((last-char (string-length str)))
(set! first-char (string-rindex str char 0 last-char))
(if first-char
(begin
(set! parts (cons (substring str (+ 1 first-char) last-char)
parts))
(loop first-char))
(set! parts (cons (substring str 0 last-char) parts))))
parts))