Find file
Fetching contributors…
Cannot retrieve contributors at this time
123 lines (105 sloc) 4.25 KB
;;; shampoo-fetcher.el --- Shampoo message fetcher
;; Copyright (C) 2010 - 2012 Dmitry Matveev <>
;; This software is released under terms of the MIT license,
;; please refer to the LICENSE file for details.
(eval-when-compile (require 'cl))
(require 'shampoo-modes)
(require 'shampoo-utils)
;; Message fetcher can be described as a finite state machine:
;; got "Content-Length: XXX\r\n"
;; ******** +----------------+ "\r\n"
;; * INIT *---->| Parsing header |-----------------.
;; ******** +----------------+ V
;; ^ +-----------------+
;; '-----------------| Parsing payload |
;; got that XXX bytes and "\r\n" +-----------------+
(defstruct shampoo-fetcher-fsm state bytes-awaiting)
(defun shampoo-fetcher-fsm-switch-to-header (fsm)
(setf (shampoo-fetcher-fsm-state fsm) :header))
(defun shampoo-fetcher-fsm-switch-to-payload (fsm payload-len)
(setf (shampoo-fetcher-fsm-state fsm) :payload)
(setf (shampoo-fetcher-fsm-bytes-awaiting fsm) payload-len))
(defun shampoo-fetcher-can-process-header (fsm)
(<= 2 (shampoo-buffer-num-lines)))
(defun shampoo-fetcher-can-process-payload (fsm)
(<= (shampoo-fetcher-fsm-bytes-awaiting fsm)
(- (point-max) (point-min))))
(defun shampoo-fetcher-can-process (fsm)
(let ((state (shampoo-fetcher-fsm-state fsm)))
(cond ((eq state :header)
(shampoo-fetcher-can-process-header fsm))
((eq state :payload)
(shampoo-fetcher-can-process-payload fsm)))))
(defun shampoo-crp (str)
(let ((l (length str)))
(and (>= l 1)
(equal "\r" (substring str (- l 1))))))
(defun shampoo-uncr (str)
(if (shampoo-crp str)
(substring str 0 (- (length str) 1))
(defun shampoo-fetcher-fsm-process-header (fsm)
(let* ((this-str (shampoo-uncr (shampoo-this-line)))
(next-str (shampoo-uncr (shampoo-next-line)))
(maybe-header (concat this-str "\r\n" next-str "\r\n"))
(pattern '("Content-Length:" :sp :D :cr :lf :cr :lf))
(parsed (shampoo-regexp-parse maybe-header pattern)))
; (message "Trying to parse \"%s\"" maybe-header)
(if parsed
; (message "Parsed ok!")
(let ((len
(string-to-number (shampoo-regexp-extract 0 parsed))))
(goto-char (point-min))
(loop repeat 2 do (shampoo-delete-this-line))
(shampoo-fetcher-fsm-switch-to-payload fsm len)))
(defun shampoo-fetcher-fsm-process-payload (fsm)
(let* ((len (shampoo-fetcher-fsm-bytes-awaiting fsm))
(cur (point))
(end (+ cur len))
(str (buffer-substring (point) end)))
(delete-region cur end)
(goto-char (point-min))
(shampoo-fetcher-fsm-switch-to-header fsm)
(defun shampoo-fetcher-fsm-process (fsm)
(let ((state (shampoo-fetcher-fsm-state fsm)))
(cond ((eq state :header)
; (message "Processing header")
(shampoo-fetcher-fsm-process-header fsm))
((eq state :payload)
; (message "Processing payload")
(shampoo-fetcher-fsm-process-payload fsm)))))
(defun shampoo-fetcher-process (str)
(with-current-buffer (shampoo-fetcher-buffer)
(when (boundp 'buflocal-fsm)
(goto-char (point-max))
(insert str)
(goto-char (point-min))
(loop while (shampoo-fetcher-can-process buflocal-fsm)
for payload = (shampoo-fetcher-fsm-process buflocal-fsm)
unless (null payload)
collect payload))))
(defun shampoo-fetcher-buffer ()
(let* ((bufname "*shampoo-working-buffer*")
(buffer (get-buffer bufname)))
(or buffer
(with-current-buffer (get-buffer-create bufname)
(if (boundp 'buflocal-fsm)
(setq buflocal-fsm
(make-shampoo-fetcher-fsm :state :header
:bytes-awaiting 0))
(error "No FSM created in the working buffer!"))
(provide 'shampoo-fetcher)
;;; shampoo-fetcher.el ends here.