simyager/lspack
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gpl3 and apache2 licenses, with notice

Browse Source
This commit is contained in:
simyager
2026-06-28 18:51:54 +03:00
parent 509f4a44bb
commit 12ca9f5940
6 changed files with 948 additions and 15 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/license.lisp
+45 -14
View File
@@ -1,6 +1,7 @@
(in-package :lspack)
(defparameter *licenses* (make-hash-table))
(defparameter *notices* (make-hash-table))
(defparameter *license-default-filename* "LICENSE")
(defclass <license> ()
@@ -19,18 +20,38 @@
(defun set-license (key value)
(setf (gethash key *licenses*) value)))
(defun get-notice (key)
(gethash key *notices*))
(eval-always
(defmacro deflicense (keys template-name &optional file-name)
(let ((sym (gensym "LICENSE")))
`(let ((,sym (make-instance '<license>
:license-template-name ,template-name
,@(unless (null file-name)
`(:license-file-name file-name)))))
,@(loop for key in (uiop:ensure-list keys)
collect `(set-license ,key ,sym))))))
(defun set-notice (key value)
(setf (gethash key *notices*) value)))
(eval-always
(defmacro deflicense (keys template-name &key file-name notice-name)
(let ((sym (gensym "LICENSE")))
`(progn (let ((,sym (make-instance '<license>
:license-template-name ,template-name
,@(unless (null file-name)
`(:license-file-name ,file-name)))))
,@(loop for key in (uiop:ensure-list keys)
collect `(set-license ,key ,sym)))
,@(unless (null notice-name)
`((let ((,sym (make-instance '<license>
:license-template-name ,notice-name
:license-file-name nil)))
,@(loop for key in (uiop:ensure-list keys)
collect `(set-notice ,key ,sym)))))))))
(deflicense :mit "mit.txt")
(deflicense :gpl3+ "gpl-3.0-or-later.txt"
:file-name "COPYING"
:notice-name "gpl-3.0-or-later-notice.txt")
(deflicense :apache2 "apache-2.0.txt"
:notice-name "apache-2.0-notice.txt")
(defmethod license-find-template ((license <license>))
(with-slots (template-name) license
(or (uiop:file-exists-p
@@ -71,6 +92,10 @@
(lambda (p s)
`(format ,s "~A" (project-author ,p))))
(define-template-arg "project-name"
(lambda (p s)
`(format ,s "~A" (project-name ,p))))
(defun generate-argument-writer (arg project-sym stream-sym)
(uiop:if-let ((arg-expander (get-arg-expander arg)))
(funcall arg-expander project-sym stream-sym)))
@@ -87,23 +112,29 @@
(generate-writer-body (cdr args) project-sym template-sym
stream-sym end)))))))
(defun template-generate-writer (template-string)
(defun template-generate-writer (template-string &optional commented)
(let ((args (template-find-args template-string))
(template-sym (gensym "TEMPLATE"))
(project-sym (gensym "PROJECT"))
(stream-sym (gensym "STREAM")))
`(lambda (,project-sym ,stream-sym)
,@(when (null args)
`((declare (ignore ,project-sym))))
(let ((,template-sym ,template-string))
,@(generate-writer-body args project-sym template-sym stream-sym)))))
,@(unless (null commented)
`((format ,stream-sym "~&#||~%")))
,@(generate-writer-body args project-sym template-sym stream-sym)
,@(unless (null commented)
`((format ,stream-sym "~&||#~%~%")))))))
(defmethod license-generate-writer ((license <license>))
(defmethod license-generate-writer ((license <license>) &optional commented)
(uiop:if-let (template (license-read-template license))
(setf (license-writer license)
(compile nil (template-generate-writer template)))))
(compile nil (template-generate-writer template commented)))))
(defmethod license-ensure-writer ((license <license>))
(defmethod license-ensure-writer ((license <license>) &optional commented)
(with-slots (writer) license
(if (functionp writer)
writer
(license-generate-writer license))))
(license-generate-writer license commented))))
src/starter.lisp
+7 -1
View File
@@ -88,6 +88,11 @@
(ensure-directories-exist (uiop:physicalize-pathname src))
(format *error-output* " created.")))))
(defmethod project-write-notice ((project <project>) stream)
(uiop:if-let ((notice (get-notice (project-license project))))
(uiop:if-let ((writer (license-ensure-writer notice t)))
(funcall writer project stream))))
(defmethod project-create-package ((project <project>))
(with-slots (root name pathname) project
(let ((path (uiop:merge-pathnames* (uiop:make-pathname* :name "package"
@@ -96,7 +101,8 @@
(with-open-file (out path :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format out "(defpackage :~a~% (:use :cl))~%" name))
(project-write-notice project out)
(format out "~&(defpackage :~a~% (:use :cl))~%" name))
(format *error-output* "~&Created ~S" path))))
(defmethod project-license-create ((project <project>))