source: cl-darcs/tags/0.1.0/touching.lisp

;;; Copyright (C) 2006 Magnus Henoch
;;;
;;; 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 of the
;;; License, 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, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :cl-darcs)

(defgeneric find-touching (patch filename)
  (:documentation "Find and return the subset of PATCH that touches FILENAME.
Return NIL if PATCH doesn't touch FILENAME at all."))

(defmethod find-touching :around (patch (filename string))
  (find-touching patch (sanitize-filename filename)))

(defmethod find-touching ((patch patch) filename)
  "This least specific method returns NIL."
  (declare (ignore filename))
  nil)

(defmethod find-touching ((patch composite-patch) filename)
  "Return a new composite patch containing those patches that touch FILENAME.
Return nil if no patches do."
  (let ((touching-patches
         (loop for p in (patches patch)
            when (find-touching p filename)
            collect it)))
    (when touching-patches
      (make-instance 'composite-patch :patches touching-patches))))

(defmethod find-touching ((patch file-patch) filename)
  (when (equal filename (patch-filename patch))
    patch))

(defmethod find-touching ((patch directory-patch) filename)
  (when (equal filename (patch-directory patch))
    patch))

(defmethod find-touching ((patch named-patch) filename)
  (let ((touching-patch (find-touching (named-patch-patch patch) filename)))
    (when touching-patch
      (make-instance 'named-patch 
                     :patchinfo (named-patch-patchinfo patch)
                     :dependencies (named-patch-dependencies patch)
                     :patch touching-patch))))