;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Tue Oct 03 18:54:23 2006 +0530 <enometh@net.meer>
;;;   Time-stamp: <06/10/03 21:28:08 madhu>
;;;   Copyright (C) 2006 Madhu. All rights ~RESEDA~
;;;   Bugs-To: <enometh@net.meer>
;;;
(in-package "CL-USER")
(eval-when (load eval compile)
  (unless (find-package "BINARY-TYPES")
    (or #+cmu
	(lc "home:cmu/binary-types-0.90/binary-types.lisp")
	(error "Requires frodef's excellent BINARY-TYPES package."))))

(defpackage "BSD-FORTUNE"
  (:use "CL" "BINARY-TYPES"))
(in-package "BSD-FORTUNE")

;;; The .dat data files contain a header and a table of offsets.  All
;;; fields of the header are written in network byte order.

(setq *endian* :big-endian)		; network byte

(define-binary-class strfile-header ()	; doc adapted from strfile.1
  ((str_version
    :binary-type 'u32
    :documentation "Version number. (1)")
   (str_numstr
    :binary-type 'u32
    :documentation "Number of strings in the file.")
   (str_longlen
    :binary-type 'u32
    :documentation "Length of longest string.")
   (str_shortlen
    :binary-type 'u32
    :documentation "Length of shortest string.")
   (str_flags
    :binary-type 'u32
    :documentation "Bit-field for flags #x1 random, #x2 ordered, #x4 rot-13")
   (str_delim
    :binary-type 'char8
    :documentation "Delimiting character.")))

(defclass fortune-file ()
  ((fortunes :type pathname :documentation "pathname to the fortune file.")
   (dat :type  pathname :documentation "pathname to the strfile data file.")
   (offsets :type array)
   (header :type strfile-header)))

(defmethod initialize-instance :after ((obj fortune-file) &key fortune-file
				       data-file)
  (unless fortune-file (error "Required pathname argument missing."))
  (assert (truename fortune-file) nil
	  "Specified fortune file not found" fortune-file)
  (unless data-file
    (setq data-file (make-pathname :name (pathname-name fortune-file)
				   :type "dat"
				   :version (pathname-version fortune-file)
				   :defaults (truename fortune-file)))
    (assert (truename data-file) nil
	    "Datafile ~A (for fortune file ~A) not found." data-file
	    (truename fortune-file)))
  (with-slots (fortunes dat header offsets) obj
    (setq fortunes (truename fortune-file)
	  dat (truename data-file))
    (with-open-file (stream dat :element-type '(unsigned-byte 8))
      (setq header (read-binary 'strfile-header stream))
      (assert (= (file-position stream) 21))
      (assert (= 0 (read-binary 'u8 stream)))
      (assert (= 0 (read-binary 'u8 stream)))
      (assert (= 0 (read-binary 'u8 stream)))
      (let ((len (1+ (slot-value header 'str_numstr))))
	(setq offsets (make-array len :element-type '(unsigned-byte 32)
				  :initial-element 0))
	(loop for i below len
	      do (setf (aref offsets i)  (read-binary 'u32 stream))))
      (assert (= (file-position stream) (file-length stream)) nil
	      "file-position=~D != file-length=~D"
	      (file-position stream)
	      (file-length stream)))))

(defmethod random-fortune ((fortune-file fortune-file))
  "Return a sequence. XXX. This works only on unix, with a lisp
that reads 8 bits per character, and with crlf fortune files."
  (with-slots (fortunes header offsets) fortune-file
    (with-open-file (stream fortunes)
      (with-slots (str_numstr) header
	(let* ((i (random str_numstr))
	       (start (aref offsets i))
	       (end (1- (aref offsets (1+ i))))
	       (seq (make-array (- end start 1) :element-type
				(stream-element-type stream))))
	  (and (file-position stream (aref offsets i))
	       (read-sequence seq stream)
	       seq))))))

#||
# rpm2cpio fortune-mod-fortunes-1.2.1-1.noarch.rpm | (cd /tmp; cpio -id)
(let ((*default-pathname-defaults*  #p"/tmp/usr/share/games/fortunes/"))
  (setq $a (make-instance 'fortune-file :fortune-file #p"love")))
(random-fortune $a)
||#