;;; HyperFred: Fred extension to deal with hyperlinks
;;; 5/21/03 Alexander Repenning http://www.agentsheets.com
;;; TOdos: making link hot should not dirty the buffer
;;; Status: dirty hack

(in-package :ccl)


;________________________________________
; Launching                              |
;________________________________________

(defun OPEN-URL (Url)
  (without-interrupts
   (with-cfstrs ((cf-url Url))
     (let ((cf-url-obj (#_CFURLCreateWithString (%null-ptr) cf-url (%null-ptr))))
       (unwind-protect
         (#_LSOpenCFURLRef cf-url-obj (%null-ptr))
         (#_CFRelease cf-url-obj))))))

;________________________________________
; URL Parsing                            |
;________________________________________

(defun BUFFER-CURRENT-STRING (Buffer Position)
  (when (< (buffer-size Buffer) 1) (return-from buffer-current-string))
  (unless (char= (buffer-char Buffer Position) #\space)
    (let ((Start Position)
          (End Position)) 
      ;; scan left for delimiter
      (loop
        (when (= Start 0) (return))
        (case (buffer-char Buffer Start)
          ((#\space #\return) (return (incf Start))))
        (decf Start))
      ;; scan right for delimiter
      (loop
        (when (= End (buffer-size Buffer)) (return))
        (incf End)
        (case (buffer-char Buffer End)
          ((#\space #\return) (return))))
      (values
       (buffer-substring Buffer Start End)
       Start
       End))))


(defun URL-STRING-P (String)
  (when (>= (length String) #.(length "http://"))
    (string-equal 
     (subseq String 0 #.(length "http://"))
     "http://")))
    
    
(defvar *Current-Fred-URL* nil)


(defun HEAT-LINK (Buffer Start End)
  (buffer-set-font-spec Buffer '("monaco" 9 (:color #.*Orange-Color*)) Start End))


(defun COOL-LINK (Buffer Start End)
  (buffer-set-font-spec Buffer '("monaco" 9 (:color #.*Blue-Color*)) Start End))


(defun MARK-LINK (Buffer Start End)
  (buffer-set-font-spec Buffer '("monaco" 9 :underline (:color #.*Blue-Color*)) Start End))
      
;________________________________________
; Fred Extensions                        |
;________________________________________

(defmethod WINDOW-NULL-EVENT-HANDLER ((Self fred-window)) "
  Track mouse position to heat and cool candidate links.
  Set cursor."
  (let* ((Position (view-mouse-position Self))
         (Fred-View (fred-item Self))
         (Buffer (fred-buffer Fred-View)))
    (multiple-value-bind (String Start End)
                         (buffer-current-string Buffer (fred-point-position Fred-View Position))
      (cond
       ((url-string-p String)  ;; pointing at URL
        (cond
         ;; there already is an activated URL
         (*Current-Fred-URL* 
          (when (not (= (second  *Current-Fred-URL*) Start))
            ;; URL is different: switch activation
            (cool-link Buffer (second *Current-Fred-URL*) (third *Current-Fred-URL*))
            (heat-link Buffer Start End)
            (setf *Current-Fred-URL* (list String Start End))
            (fred-update Self)))
         (t  ;; new activation
            (heat-link Buffer Start End)
            (setf *Current-Fred-URL* (list String Start End))
            (fred-update Self)))
        (#_SetThemeCursor #$kThemePointingHandCursor))
       (t
        (when *Current-Fred-URL*
          ;; reset activation
          (cool-link Buffer (second *Current-Fred-URL*) (third *Current-Fred-URL*))
          (fred-update Self)
          (setf *Current-Fred-URL* nil))
        ;; let Fred determine cursor
        (call-next-method))))))


(defmethod VIEW-CLICK-EVENT-HANDLER :after ((Self fred-window) Where) "
  If there is a link open it."
  (let* ((Fred-View (fred-item Self))
         (Buffer (fred-buffer Fred-View)))
    (let ((String (buffer-current-string Buffer (fred-point-position Fred-View Where))))
      (when (url-string-p String)
        ;; (format t "~%Open URL: ~A" String)
        (open-url String)))))


(defmethod ED-INSERT-CHAR :after ((Self fred-mixin) Char) "
  After typing a delimiter check if there is a link"
  (case Char
    ((#\space #\return)
     (multiple-value-bind (String Start End)
                          (buffer-current-string (fred-buffer Self) (- (buffer-position (fred-buffer Self)) 2))
       (when (url-string-p String)
         (mark-link (fred-buffer Self) Start End))))))




#| Examples:



http://www.apple.com

http://www.agentsheets.com


http://www.webmd.com 

hyperventilation: http://my.webmd.com/content/healthwise/63/15780.htm?lastselectedguid=%7B5FE84E90-BC77-4056-A91C-9531713CA348%7D



|#