dev-tools:dialog-edit-pkg

说明:

用法:

 (dev-tools:dialog-edit-pkg)

参数:

返回值:

示例:

(defun dev-tools:dialog-edit-pkg (/ pkg-name dcl-tmp dcl_fp callback-inc-version
					   addfile removefile files-list tmp change need-change
					   compile-pkg save-pkg need-publish need-upload Publish upload
					   callback-add-category stable-version release-version)
  (@::load-module 'pkgman)
  (progn (@::package-update)(@::package-update-release))
  (if (null (= 'subr (type vlisp-compile))) (C:vlide))

(if (null (@::check-userinfo)) (exit))
  (if (/= "" (@::get-config '@::current-pkg))
      (setq pkg-name (@::get-config '@::current-pkg))
    (progn
      (@::package-list-in-local)
      (setq tmp (vl-remove-if-not '(lambda(x) (eq (@::pkg x ':email) (@::get-config '@::user-email)))
				  (mapcar 'cdr @::*local-pkgs*)))
      (setq pkg-name
	    (cdr
	     (assoc
	      "Package:"
	      (ui:input "Please select your package."
			(list (list "Package:" (mapcar '(lambda(x)(@::pkg x ':name)) tmp)))))))))

(if (findfile (strcat (@::package-src pkg-name) "pkg.lsp"))
      (progn
	(vl-file-delete (strcat (@::package-path pkg-name) "pkg.lsp"))
	(vl-file-copy (strcat (@::package-src pkg-name) "pkg.lsp")
		      (strcat (@::package-path pkg-name) "pkg.lsp"))
	(load (strcat (@::package-path pkg-name) "pkg.lsp") "failure")))
  (if (or (/= 'str (type  pkg-name))
	  (= (strlen pkg-name) 0))
      (progn
	(alert (_"No package to manager. Please Create one first."))
	(exit)))
  (@::set-config '@::current-pkg pkg-name)
  (setq stable-version (@::pkg (@::get-remote-pkg-info pkg-name) ':version))
  (setq release-version (@::pkg (@::get-remote-release-pkg-info pkg-name) ':version))
  (setq need-upload nil)
  (setq need-publish nil)
  (setq need-change nil)
  (defun change ()
    (setq need-change T)
    (done_dialog))
  (defun compile-pkg ()
    (save-pkg)(setq need-compile T)(done_dialog))
  (defun Publish ()
    (save-pkg)(setq need-publish T)(done_dialog))
  (defun upload ()
    (save-pkg)(setq need-upload T)(done_dialog))
  (defun callback-inc-version (/ curr-ver)
    (setq curr-ver (dev-tools:inc-version (get_tile "version")))
    (set_tile "version" curr-ver)
    (if (or (null stable-version)
 	    (@::compare-version curr-ver stable-version))
	(mode_tile "Publish" 0)
      (mode_tile "Publish" 1)
      )
    (if (or (null release-version)
 	    (@::compare-version curr-ver release-version))
	(mode_tile "upload" 0)
      (mode_tile "upload" 1)
      )
    )
  (defun save-pkg (/ pkg-info fp )
    (setq pkg-info (@::get-local-pkg-info pkg-name))
    (setq pkg-info (subst (cons ':version (get_tile "version"))
			  (assoc ':version pkg-info) pkg-info))
    (setq pkg-info (subst (cons ':full-name (get_tile "fullname"))
			      (assoc ':full-name pkg-info) pkg-info))
    (setq pkg-info (subst (cons ':description (get_tile "description"))
			      (assoc ':description pkg-info) pkg-info))
    (setq pkg-info (subst (cons ':files files-list)
			  (assoc ':files pkg-info) pkg-info))
    (setq pkg-info (subst (cons ':category (nth (atoi (get_tile "category")) @::*pkgs-category*))
			  (assoc ':category  pkg-info) pkg-info))
    (setq fp (open (strcat (@::package-src pkg-name) "pkg.lsp") "w" "utf8"))
    (write-line (string:indent(strcat "(@::def-pkg '" (vl-prin1-to-string pkg-info) ")")) fp)
    (close fp)
    (mode_tile "savepkg" 1)
    )
  (defun callback-add-category (/ new-category)
    (setq new-category (cdr (assoc "category" (ui:input "Please input category name:" '(("category"))))))
    (if (/= "" new-category)
	(if (member new-category @::*pkgs-category*)
	    (set_tile "category" (itoa(vl-position new-category @::*pkgs-category*)))
	  (progn
	    (setq @::*pkgs-category*
		  (cons (cdr (assoc "category" (ui:input "Please input category name:" '(("category")))))
			@::*pkgs-category*))
	    (start_list "category" 3)
	    (mapcar 'add_list @::*pkgs-category*)
	    (end_list)
	    (set_tile "category" "0")
	    ))))
    
  (defun addfile (/ file target)
    ;; addfile    (setq file (getfiled "Select a file add to package." "" "" 8))
    (setq target (strcat (vl-filename-base file) (vl-filename-extension file)))
    
    (if (and file
	     (vl-filename-extension file)
	     ;; 非中文检查	     ;; (< (apply 'max (vl-string->list (vl-filename-base file))) 128)	     ;; (> (apply 'min (vl-string->list (vl-filename-base file))) 32)	     ) 
	(progn
	  ;; TODO: 去空格转中文	  (vl-file-copy file (strcat (@::package-src pkg-name) target))
	  ;; 重新生成文件表。	  (start_list "files" 2)
	  (if (= ".lsp" (vl-filename-extension file))
	      (progn 
		(add_list (strcat (vl-filename-base file)))
		(setq files-list (append files-list (list (vl-filename-base file)))))
	    (progn
	      (add_list (strcat (vl-filename-base file)(vl-filename-extension file)))
	      (setq files-list (append files-list (list (strcat (vl-filename-base file)(vl-filename-extension file)))))
	      ))
	  (end_list) 
	  )
      (cond
       ((null (vl-filename-extension file))
	(alert "文件名不含扩展名。暂不支持该文件。"))
       (t (alert "文件名含有其它未知问题。"))
       
       )
      )
    
    (save-pkg)
    )
  (defun removefile (/ files-idx)
    (setq files-idx  (get_tile "files"))
    (setq files-remove (mapcar '(lambda (x)(nth (atoi x) files-list)) (string:to-list files-idx " ")))
    (foreach f% files-remove
	     (if (vl-filename-extension f%)
		 (vl-file-delete (strcat (@::package-src pkg-name) f%))
	       (progn
		 (vl-file-delete (strcat (@::package-src pkg-name) f% ".lsp"))
		 (vl-file-delete (strcat (@::package-src pkg-name) f% ".fas"))))
	     (setq files-list (vl-remove f% files-list)))
    ;; 重新生成文件表。    (start_list "files" 3)
    (mapcar 'add_list files-list)
    (end_list)
    (save-pkg)
    (mode_tile "savepkg" 1)
    )
       
  (setq dcl-tmp (vl-filename-mktemp nil nil ".dcl" ))
  (setq dcl_fp (open dcl-tmp "w"))
  (foreach
   line%
   (list
    (strcat "pkgInfo : dialog {label=\"" (_"Package information.") "\";" )
    (strcat ":column {:row {:edit_box {label=\""(_"PKG Name")
	    ":\";key=\"name\";width=36;fixed_width=true;edit_width=20;alignment=right;is_enabled=false;}")
    
    (strcat ":button{label=\""(_"Change package") "\";key =\"change\";width=25; }}")
    
    (strcat  ":row {: edit_box {label=\""(_"Full Name")":\";" ) 
    "key=\"fullname\";width=36;fixed_width=true;edit_width=20;alignment=right; }" 
    (strcat ":text_part {label=\""(_"The name in your local language.")
	    "\";key =\"fullname_desc\";width=65;}}")
    
    (strcat  ":row {: edit_box {label=\""(_"Version")":\";" )
    "key=\"version\";width=36;fixed_width=true;edit_width=20;alignment=right; }" 
    (strcat ":button {label=\""(_"Inc Version")
	    "\";key =\"inc_version\";width=25;action=\"(callback-inc-version)\";alignment=left;}}")
    
    (strcat ":row {:popup_list{label=\""(_"Category")
	    ":\";key=\"category\";width=36;fixed_width=true;edit_width=20;alignment=right;}")
    
    (strcat ":button {label=\""(_"Add Category")
	    "\";key =\"add_category\";width=25;action=\"(callback-add-category)\";alignment=left;}""}")
    
    (strcat ": row {: edit_box {label=\""(_"Description")
	    ":\";key=\"description\";width=110;fixed_width=true;edit_width=95;alignment=right;}}" )
    
    (strcat ": row {:row{label=\""(_"Files")"\"; : list_box {label=\"Files list:\""
	    ";key=\"files\";width=45;height=15;fixed_width=true;edit_width=45;alignment=right;multiple_select=true;}")
    ;; 加减文件    (strcat ":column {fixed_height=true;:button{label=\""(_"Add File")"\";key=\"addfile\";width=25;fixed_width=true;alignment=left;height=3;}"
	    ":button {label=\""(_"Remove File")"\";key=\"removefile\";width=25;fixed_width=true;alignment=left;height=3;}"
	    ":button {label=\""(_"Save PKG")"\";key=\"savepkg\";width=25;fixed_width=true;alignment=left;height=3;}"
	    "}}spacer;")
    
    ;; 发布按钮    (strcat ": column {fixed_height=true;:button{label=\""(_"Compile")"\";key=\"compile\";width=25;fixed_width=true;alignment=right;height=5;}"
	    ":button{label=\""(_"Upload")"\";key=\"upload\";width=25;fixed_width=true;alignment=right;height=5;}"
	    ":button {label=\""(_"Publish")"\";key=\"Publish\";width=25;fixed_width=true;alignment=right;height=5;}"
	    "}}")
    "} ok_cancel;}" )
   (write-line line% dcl_fp))
  (close dcl_fp)

(setq dcl_id (load_dialog dcl-tmp))

(if (not (new_dialog "pkgInfo" dcl_id))
      (exit))
  (start_list "category")
  ;; (add_list "Uncategorized")  (mapcar 'add_list @::*pkgs-category*)
  (end_list)
  (if (member (@::pkg (@::get-local-pkg-info pkg-name) ':category) @::*pkgs-category*)
      (set_tile "category"(itoa (vl-position (@::pkg (@::get-local-pkg-info pkg-name) ':category)
					     @::*pkgs-category*)))
    (progn
      (setq @::*pkgs-category*
	    (cons (@::pkg (@::get-local-pkg-info pkg-name) ':category)
		  @::*pkgs-category*))
      (start_list "category" 3)
      (mapcar 'add_list @::*pkgs-category*)
      (end_list)
      (set_tile "category" "0")
      ))
  (set_tile "name" (@::pkg (@::get-local-pkg-info pkg-name) ':name))
  (set_tile "fullname" (@::pkg (@::get-local-pkg-info pkg-name) ':full-name))
  (set_tile "version" (@::pkg (@::get-local-pkg-info pkg-name) ':version))
  (set_tile "description" (@::pkg (@::get-local-pkg-info pkg-name) ':description))
  (mode_tile "savepkg" 1)
  (if (@::compare-version (get_tile "version") stable-version)
      (mode_tile "Publish" 0)
    (mode_tile "Publish" 1))
  (if (@::compare-version (get_tile "version") release-version)
      (mode_tile "upload" 0)
    (mode_tile "upload" 1))
  (setq files-list (@::pkg (@::get-local-pkg-info pkg-name) ':files))
  (start_list "files")
  (mapcar 'add_list files-list)
  (end_list)
  (action_tile "fullname" "(mode_tile \"savepkg\" 0)")
  (action_tile "version" "(mode_tile \"savepkg\" 0)")
  (action_tile "description" "(mode_tile \"savepkg\" 0)")
  (action_tile "addfile" "(addfile)")
  (action_tile "compile" "(compile-pkg)")
  (action_tile "upload" "(upload)")
  (action_tile "change" "(change)")
  (action_tile "Publish" "(publish)")
  (action_tile "removefile" "(removefile)")
  (action_tile "savepkg" "(save-pkg)")
  (action_tile "accept" "(save-pkg)(done_dialog)")
  (start_dialog)
  (unload_dialog dcl_id)
  (vl-file-delete dcl-tmp)
  (cond
   ((and need-change @::*local-pkgs*)
    (setq pkg-name
	  (cdr
	   (assoc "Package:"
		  (ui:input
		   "Please select your package."
		   (list
		    (list "Package:"
			  (mapcar '(lambda(x)(@::pkg x ':name))
				  (vl-remove-if-not
				   '(lambda(x) (eq (@::pkg x ':email)
						   (@::get-config '@::user-email)))
				   (mapcar 'cdr @::*local-pkgs*)))))))))
      (@::set-config '@::current-pkg pkg-name)
      (dev-tools:dialog-edit-pkg)
      )
   (need-publish
    (@::compile-pkg pkg-name)
    (@::upload-pkg (strcase pkg-name T) "release")
    (@::upload-pkg (strcase pkg-name T) "stable"))
   (need-upload
    (progn
      (@::compile-pkg pkg-name)
      (@::upload-pkg (strcase pkg-name T) "release"))
    )
   (need-compile
    (@::compile-pkg (strcase pkg-name T)))
   ))

@lisp 函数库

介绍

调用函数

安装教程

快速上手：

dev-tools:dialog-edit-pkg

上传记录