;;; ysq.el --- look up stock quotes using Yahoo

;; Copyright (C) 1999 Noah S. Friedman

;; Author: Noah Friedman <friedman@splode.com>
;; Maintainer: friedman@splode.com
;; Keywords: extensions
;; Created: 1999-03-31

;; $Id: ysq.el,v 1.4 1999/04/19 17:34:18 friedman Exp $

;; 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 program; if not, you can either send email to this
;; program's maintainer or write to: The Free Software Foundation,
;; Inc.; 59 Temple Place, Suite 330; Boston, MA 02111-1307, USA.

;;; Commentary:

;; Updates of this program may be available via the URL
;; http://www.splode.com/~friedman/software/emacs-lisp/

;;; Code:

(defvar ysq-server "quote.yahoo.com")
(defvar ysq-port   "http")
(defvar ysq-cgi    "/d/quotes.csv")

(defvar ysq-query-tickers '("aol"))

(defvar ysq-query-fields
  '(ticker-symbol                       ; Should be first; search key
    52-week-high
    52-week-low
    ask
    bid
    change
    company-name
    daily-high
    daily-low
    date
    dividend-date
    dividend/share
    earnings/share
    error
    ex-dividend-date
    last-price
    market-capitalization
    opening-price
    previous-close
    price/earning-ratio
    stock-exchange-name
    time
    volume
    yield
    ;; Must be last because of parsing considerations,
    ;; see ysq-ticker-collect-parse.
    shares-outstanding))

(defvar ysq-field-alist
  '((52-week-high          "k")
    (52-week-low           "j")
    ;; redundant; see j,k
    (52-week-range         "w")
    (ask                   "a")
    (bid                   "b")
    (change                "c1")
    ;; redundant; see c1,[(l1-p)/p]*100
    (change-value-percent  "c")
    (company-name          "n"  ysq-read-company-name)
    (daily-high            "h")
    (daily-low             "g")
    (date                  "d1")
    ;; redundant; see h,g
    (day-range             "m")
    (dividend-date         "r1")
    (dividend/share        "d")
    (earnings/share        "e")
    (error                 "e1" ysq-read-error)
    (ex-dividend-date      "q")
    ;; `info' contains a string of the form "cnsprmi", which means that
    ;; Yahoo has more information for this stock, e.g. Chart, News, SEC,
    ;; Msgs, Profile, Research, Insider.  Not very useful to this
    ;; interface.
    (info                  "i")
    (last-price            "l1")
    ;; redundant; see l1
    (last-price-y2         "y2")
    ;; redundant; see d1,l1
    (last-trade-time-price "n1" ysq-read-string)
    (market-capitalization "j1" ysq-read-string)
    (opening-price         "o")
    (previous-close        "p")
    (price/earning-ratio   "r")
    (shares-outstanding    "j2" ysq-read-shares-outstanding)
    (stock-exchange-name   "x")
    (ticker-symbol         "s")
    (time                  "t1")
    ;; I don't know what these fields are meant to contain, but the cgi
    ;; seems to return something for them; usually N/A.
    (unknown-m1            "m1")
    (unknown-n2            "n2")
    (unknown-w1            "w1")
    (volume                "v")
    (yield                 "y")))

(defvar ysq-reader-default 'ysq-read)

(defun ysq-field-form-identifier (field &optional field-alist)
  (nth 1 (assq field (or field-alist ysq-field-alist))))

(defun ysq-field-reader (field &optional field-alist)
  (or (nth 2 (assq field (or field-alist ysq-field-alist)))
      ysq-reader-default))

(defun ysq-open (server port sentinel)
  (let* ((newbuf (generate-new-buffer " *ysq data*"))
         (proc (open-network-stream "ysq" newbuf server port)))
    (buffer-disable-undo newbuf)
    (set-process-sentinel proc sentinel)
    proc))

(defun ysq-send (proc &rest args)
  (while args
    (process-send-string proc (car args))
    (setq args (cdr args))))


(defvar ysq-ticker-collected-async-data nil)
(defvar ysq-ticker-async-process nil)

(defun ysq-ticker-collect (&rest ticker-names)
  (ysq-ticker-collect-internal 'ysq-ticker-collect-sentinel-sync
                               'ysq-ticker-collector-sync
                               ticker-names))

(defun ysq-ticker-collect-async (&rest ticker-names)
  (or (ysq-process-live-p ysq-ticker-async-process)
      (setq ysq-ticker-collected-async-data nil)
      (setq ysq-ticker-async-process
            (ysq-ticker-collect-internal 'ysq-ticker-collect-sentinel-async
                                         nil ticker-names))))

(defun ysq-ticker-collect-internal (sentinel collector ticker-names)
  (or ticker-names
      (setq ticker-names ysq-query-tickers))
  (let* ((proc    (ysq-open ysq-server ysq-port sentinel))
         (fields  (mapconcat 'ysq-field-form-identifier ysq-query-fields ""))
         (tickers (mapconcat 'identity ticker-names "+")))

    (ysq-send proc
              (format "get %s?%s&%s&%s http/1.0\r\n"
                      ysq-cgi
                      (format "f=%s" fields)
                      (format "s=%s" tickers)
                      "e=.csv")
              ;; Put any http 1.0 headers here.
              "\r\n")

    (if collector
        (funcall collector proc)
      proc)))

(defun ysq-process-live-p (proc)
  (and (processp proc)
       (memq (process-status proc) '(open run))))

;; This sentinel is a no-op, but keeps any process-exit message from being
;; inserted into the process buffer.
(defun ysq-ticker-collect-sentinel-sync (proc string)
  nil)

(defun ysq-ticker-collector-sync (proc)
  (while (ysq-process-live-p proc)
    (accept-process-output))
  (let ((result nil))
    (save-excursion
      (set-buffer (process-buffer proc))
      (goto-char (point-min))
      (setq result (ysq-ticker-collect-parse)))
    (kill-buffer (process-buffer proc))
    result))

(defun ysq-ticker-collect-sentinel-async (proc string)
  (save-excursion
    (set-buffer (process-buffer proc))
    (goto-char (point-min))
    (setq ysq-ticker-collected-async-data (ysq-ticker-collect-parse))
    (kill-buffer (process-buffer proc)))
  (setq ysq-ticker-async-process nil))

(defun ysq-ticker-collect-parse ()
  (save-match-data

    ;; easier to get rid of trailing RETs in a single pass.
    (while (re-search-forward "\r$" nil t)
      (replace-match ""))
    (goto-char (point-min))

    (cond ((looking-at "^HTTP/1\\.")
           (re-search-forward "^$")
           (forward-char)))

    (let ((all-data nil))
      (while (not (eobp))
        (let ((field ysq-query-fields)
              (data nil)
              parsed p)
          (while (not (eolp))
            (setq p (point))

            ;; Special hack because, annoyingly, the shares outstanding are
            ;; printed with commas in the number and are not quoted to avoid
            ;; ambiguity with the spreadsheet field separator.
            (cond ((eq (car field) 'shares-outstanding)
                   (re-search-forward "\\([0-9,]+\\)\\|$" nil t))
                  (t
                   (re-search-forward ",\\|$" nil t)))
            (goto-char (match-end 0))
            (setq parsed
                  (funcall (ysq-field-reader (car field))
                           (buffer-substring p (or (match-end 1)
                                                   (match-beginning 0)))))
            (cond (parsed
                   (setq data (cons (cons (car field) parsed) data))
                   (and (eq (car field) 'ticker-symbol)
                        (setq ticker-symbol parsed))))
            (setq field (cdr field)))
          (setq all-data (cons (nreverse data) all-data))
          (forward-char)))
      (nreverse all-data))))


;; Readers for various kinds of data.

(defun ysq-read (obj)
  (and (ysq-read-string obj)
       (read obj)))

(defun ysq-read-error (obj)
  (save-match-data
    (cond ((null (ysq-read-string obj))
           nil)
          ((string-match "No such ticker symbol" obj)
           (substring obj (match-beginning 0) (match-end 0)))
          ((string-match "^\".*\"$" obj)
           (substring obj 1 -1)))))

(defun ysq-read-company-name (obj)
  (setq obj (ysq-read obj))
  (save-match-data
    (cond ((not (stringp obj))
           obj)
          ((string-match "[ \t]+$" obj)
           (substring obj 0 (match-beginning 0)))
          (t obj))))

(defun ysq-read-shares-outstanding (obj)
  (save-match-data
    (let ((s "")
          (p 0))
      (while (string-match ",+" obj p)
        (setq s (concat s (substring obj p (match-beginning 0))))
        (setq p (match-end 0)))
      ;; Return a string because in many cases, the number of shares
      ;; outstanding a company might have overflows emacs' maximum integer
      ;; range on 32-bit machines.  For example, AOL has over 933 million
      ;; shares outstanding as of 1999-04-04.
      (concat s (substring obj p)))))

(defun ysq-read-string (obj)
  (cond ((or (string= obj "N/A")
             (string= obj "\"N/A\""))
         nil)
        (t obj)))


;;; Timer internals

(defconst ysq-xemacs-p
  (and (string-match "XEmacs\\|Lucid" (emacs-version)) t))

(if ysq-xemacs-p
    (require 'itimer)
  (require 'timer))

(defsubst ysq-timer-get-time     (timer)        (aref timer 0))
(defsubst ysq-timer-get-repeat   (timer)        (aref timer 1))
(defsubst ysq-timer-get-function (timer)        (aref timer 2))
(defsubst ysq-timer-get-args     (timer)        (aref timer 3))
(defsubst ysq-timer-get-data     (timer)        (aref timer 4))
(defsubst ysq-timer-set-time     (timer time)   (aset timer 0 time))
(defsubst ysq-timer-set-repeat   (timer repeat) (aset timer 1 repeat))
(defsubst ysq-timer-set-function (timer fn)     (aset timer 2 fn))
(defsubst ysq-timer-set-args     (timer args)   (aset timer 3 args))
(defsubst ysq-timer-set-data     (timer data)   (aset timer 4 data))

(defun ysq-timer-create (time repeat function &rest args)
  (let ((timer (make-vector 5 nil)))
    (ysq-timer-set-time     timer time)
    (ysq-timer-set-repeat   timer repeat)
    (ysq-timer-set-function timer function)
    (ysq-timer-set-args     timer args)
    timer))

(defun ysq-timer-schedule (timer)
  (ysq-timer-set-data timer
   (if ysq-xemacs-p
       (start-itimer (if (symbolp (ysq-timer-get-function timer))
                         (symbol-name (ysq-timer-get-function timer))
                       "anonymous function")
                     (ysq-timer-get-function timer)
                     (ysq-timer-get-time     timer)
                     (ysq-timer-get-repeat   timer))
     (apply 'run-at-time
            (ysq-timer-get-time     timer)
            (ysq-timer-get-repeat   timer)
            (ysq-timer-get-function timer)
            (ysq-timer-get-args     timer)))))

(defun ysq-timer-cancel (timer)
  (and (ysq-timer-get-data timer)
       (ysq-timer-set-data timer
        (if ysq-xemacs-p
            (delete-itimer (ysq-timer-get-data timer))
          (cancel-timer (ysq-timer-get-data timer))))))

(defun ysq-timer-reset (timer)
  (ysq-timer-cancel timer)
  (ysq-timer-schedule timer))


;;; Put your favorite stock quotes in your mode line!
;;; This section is delightfully baroque.
;; Also still under development.

(defvar ysq-mode-line-tickers
  '((("aol") (last-price))))

(defvar ysq-mode-line-default-formatter-function
  'ysq-mode-line-default-formatter)

(defvar ysq-mode-line-format
  '(ysq-mode-line-string (" " ysq-mode-line-string)))

(defvar ysq-mode-line-string "")

(defvar ysq-mode-line-update-interval 10)
(defvar ysq-mode-line-timer nil)

(defun ysq-mode-line-install ()
  (interactive)
  (cond ((or (not (boundp 'global-mode-string))
             (null global-mode-string))
         (setq global-mode-string '("" ysq-mode-line-format)))
        ((listp global-mode-string)
         (or (member 'ysq-mode-line-format global-mode-string)
             (setq global-mode-string
                   (append global-mode-string '(ysq-mode-line-format))))))
  (ysq-mode-line-schedule))

(defun ysq-mode-line-schedule ()
  (setq ysq-mode-line-timer
        (ysq-timer-create 0
                          ysq-mode-line-update-interval
                          'ysq-mode-line-update))
  (ysq-timer-schedule ysq-mode-line-timer))

(defun ysq-mode-line-schedule-cancel ()
  (ysq-timer-cancel ysq-mode-line-timer))

(defun ysq-mode-line-update-sync ()
  (let ((alist (ysq-mode-line-get-sync ysq-mode-line-tickers))
        (tickers ysq-mode-line-tickers)
        (result "")
        formatter)
    (while alist
      (setq formatter (or (nth 2 (car tickers))
                          ysq-mode-line-default-formatter-function))

      (setq result (concat result (funcall formatter (car alist))))

      (setq alist (cdr alist))
      (setq tickers (cdr tickers)))
    (setq ysq-mode-line-string result)
    (force-mode-line-update)))

(defun ysq-mode-line-get-sync (&optional tickers)
  (or tickers
      (setq tickers ysq-mode-line-tickers))
  (let ((data nil)
        (ysq-query-fields ysq-query-fields))
    (while tickers
      (setq ysq-query-fields (nth 1 (car tickers)))
      (setq data
            (cons (car (apply 'ysq-ticker-collect (car (car tickers))))
                  data))
      (setq tickers (cdr tickers)))
    data))

(defun ysq-mode-line-default-formatter (alist &optional separator)
  (or separator
      (setq separator " "))
  (let ((result "")
        val)
    (while alist
      (setq val (cdr (car alist)))
      (setq result (concat result (if (string= "" result)
                                      ""
                                    separator)
                           (cond ((stringp val)
                                  val)
                                 ((integerp val)
                                  (number-to-string val))
                                 ((floatp val)
                                  (format "%.2f" val)))))
      (setq alist (cdr alist)))
    result))


(defun ysq-mode-line-get (&optional tickers)
  (or tickers
      (setq tickers ysq-mode-line-tickers))
  (let ((data nil)
        (ysq-query-fields ysq-query-fields))
    (while tickers
      (setq ysq-query-fields (nth 1 (car tickers)))

      (apply 'ysq-ticker-collect-async (car (car tickers)))
      (while (ysq-process-live-p ysq-ticker-async-process)
        (accept-process-output nil 1))
      (sit-for 0 1)

      (setq data (cons (car ysq-ticker-collected-async-data) data))
      (setq tickers (cdr tickers)))
    data))

;; obsolete
(defun ysq-mode-line-get-OBS (&optional tickers)
  (or tickers
      (setq tickers ysq-mode-line-tickers))
  (let ((data nil)
        (ysq-query-fields ysq-query-fields))
    (while tickers
      (setq ysq-query-fields (nth 1 (car tickers)))

      (apply 'ysq-ticker-collect-async (car (car tickers)))
      (while (ysq-process-live-p ysq-ticker-async-process)
        (accept-process-output nil 1))
      (sit-for 0 1)

      (setq data (cons (car ysq-ticker-collected-async-data) data))
      (setq tickers (cdr tickers)))
    data))


(provide 'ysq)

;; ysq.el ends here