From 1a2d326ed2a41d37b940c3affad06686cad95691 Mon Sep 17 00:00:00 2001 From: Michael Moese Date: Fri, 6 Jun 2025 15:44:19 +0200 Subject: [PATCH] initial commit --- .gitignore | 25 + init.el | 137 ++ lisp/elmine.el | 416 +++++ lisp/orgmine.el | 3411 +++++++++++++++++++++++++++++++++++++++ lisp/perltidy.el | 249 +++ lisp/s.el | 792 +++++++++ request/curl-cookie-jar | 4 + transient/history.el | 1 + 8 files changed, 5035 insertions(+) create mode 100644 .gitignore create mode 100644 init.el create mode 100644 lisp/elmine.el create mode 100644 lisp/orgmine.el create mode 100644 lisp/perltidy.el create mode 100644 lisp/s.el create mode 100644 request/curl-cookie-jar create mode 100644 transient/history.el diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2ace877 --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +# ELPA-Ordner mit den installierten Paketen ignorieren +elpa/ +auto-save-list/ +.cache/ + +# Backup-Dateien von Emacs ignorieren +*~ + +# Autosave-Dateien ignorieren +.#* + +# Cache-Dateien, z.B. von org-mode, ignorieren +*.elc +*.cache + +# Wenn du org-mode mit LaTeX benutzt, kannst du temporäre Dateien ignorieren +*.aux +*.log +*.out +*.toc + +# Optional: Wenn du andere temporäre oder systembezogene Dateien hast +.DS_Store + +.lsp-session-v1 \ No newline at end of file diff --git a/init.el b/init.el new file mode 100644 index 0000000..f1876ee --- /dev/null +++ b/init.el @@ -0,0 +1,137 @@ +(add-to-list 'load-path "~/.emacs.d/lisp/") +(normal-erase-is-backspace-mode 0) + + +(windmove-default-keybindings) + + +(require 'package) +(add-to-list 'package-archives '("melpa" . "https://melpa.org/packages/")) +(custom-set-variables + ;; custom-set-variables was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(custom-safe-themes + '("77f1e155387d355fbbb3b382a28da41cc709b2a1cc71e7ede03ee5c1859468d2" default)) + '(lsp-perl-perl-inc ["./lib/"]) + '(package-selected-packages + '(exec-path-from-shell company flycheck vterm minimap lsp-treemacs treemacs-magit treemacs lsp-mode magit whitespace-cleanup-mode request markdown-mode elmine kuronami-theme yaml-mode))) +(custom-set-faces + ;; custom-set-faces was added by Custom. + ;; If you edit it by hand, you could mess it up, so be careful. + ;; Your init file should contain only one such instance. + ;; If there is more than one, they won't work right. + '(minimap-font-face ((t (:height 5 :family "DejaVu Sans Mono"))))) + +(load-theme 'kuronami) +;; Disable the splash screen (to enable it agin, replace the t with 0) +(setq inhibit-splash-screen t) + + + +;; Enable transient mark mode +(transient-mark-mode 1) + +;;;;Org mode configuration +;; Enable Org mode +(require 'org) +;; Make Org mode work with files ending in .org +(add-to-list 'auto-mode-alist '("\\.org$" . org-mode)) +(setq org-todo-keywords + '((sequence "TODO" "IN-PROGRESS" "WAITING" "DONE"))) + + +(require 'orgmine) +(add-hook 'org-mode-hook + (lambda () (if (assoc "om_project" org-keyword-properties) + (orgmine-mode)))) + + +(setq org-link-abbrev-alist + '(("poo" . "https://progress.opensuse.org/") + ;;... + )) +(setq request-curl-options '("-k")) +(setq orgmine-servers + '(("poo" ; server name for this entry + (host . "https://progress.opensuse.org") + (api-key . "9fe3c1484c9bf956fce04ec67f08917b9ac2206d") + (issue-title-format . "[[redmine:issues/%{id}][#%{id}]] %{subject}") + (journal-title-format . "[[redmine:issues/%{id}#note-%{count}][V#%{id}-%{count}]] %{created_on} %{author}") + (version-title-format . "[[redmine:versions/%{id}][V#%{id}]] %{name}") + (tracker-title-format . "%{name}") + (project-title-format . "[[redmine:projects/%{identifier}][%{identifier}]] %{name}") + (user-name-format . "%{firstname} %{lastname}") + (default-todo-keyword . "NEW")))) + +(require 'perltidy) +(fset 'perl-mode 'cperl-mode) +(add-hook 'fperl-mode-hook 'whitespace-cleanup-mode) +(setq cperl-invalid-face nil) + +(setq cperl-indent-level 4) + +(use-package exec-path-from-shell + :ensure t + :config + (exec-path-from-shell-initialize) + (exec-path-from-shell-copy-env "PERL5LIB")) + +(use-package company + :ensure t + :config + (add-to-list 'company-backends 'company-capf) + (global-company-mode)) + +(use-package lsp-mode + :ensure t + :init + (setq lsp-keymap-prefix "C-c l") + :config + (add-hook 'c-mode-hook #'lsp) + (add-hook 'c++-mode-hook #'lsp) + (add-hook 'cperl-mode-hook #'lsp) + (setq lsp-clangd-binary-path "/usr/bin/clangd") + (setq lsp-client-clangd-args '("-j=4" "-background-index" "-log=error")) + (setq lsp-keymap-prefix "C-c C-l")) + +;;;(add-to-list 'lsp-perl-perl-inc ("/Users/MMOESE/work/os-autoinst-distri-opensuse/lib" "/Users/MMOESE/work/os-autoinst-distri-opensuse/os-autoinst")) + +(use-package treemacs + :ensure t) + +(use-package treemacs-magit + :ensure t) + +(use-package lsp-treemacs + :ensure t) + +(use-package minimap + :ensure t + :config (setq minimap-window-location 'right)) + +(use-package flycheck + :ensure t + ) + +(lsp-treemacs-sync-mode 1) +(setq lsp-modeline-diagnostics-enable t) + +(add-to-list 'display-buffer-alist + '("\*vterm\*" + (display-buffer-in-side-window) + (window-height . 0.25) + (side . bottom) + (slot . 0))) + +(add-to-list 'display-buffer-alist + '("\*compilation\*" + (display-buffer-in-side-window) + (window-height . 0.25) + (side . bottom) + (slot . 0))) + + +(add-hook 'after-init-hook #'global-flycheck-mode) +;;;(add-hook 'after-init-hook #'treemacs) diff --git a/lisp/elmine.el b/lisp/elmine.el new file mode 100644 index 0000000..48042c3 --- /dev/null +++ b/lisp/elmine.el @@ -0,0 +1,416 @@ +;;; elmine.el --- Redmine API access via elisp. + +;; Copyright (c) 2012 Arthur Leonard Andersen +;; +;; Author: Arthur Andersen +;; URL: http://github.com/leoc/elmine +;; Version: 0.3.1 +;; Keywords: tools +;; Package-Requires: ((s "1.10.0")) +;; +;; This file is not part of GNU Emacs. +;; +;; 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 3 +;; 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; `elmine` provides simple means of accessing the redmine Rest API +;; programmatically. This means that you do not have interactive +;; functions but functions that give and take list representations of +;; JSON objects of the redmine API. + +;;; Code: + +(require 'json) +(require 's) + +(defun plist-merge (base new) + "Merges two plists. The keys of the second one will overwrite the old ones." + (let ((key (car new)) + (val (cadr new)) + (new (cddr new))) + (while (and key val) + (setq base (plist-put base key val)) + (setq key (car new)) + (setq val (cadr new)) + (setq new (cddr new))) + base)) + +(defvar elmine/host nil + "The default host of the redmine.") + +(defvar elmine/api-key nil + "The default API key for the redmine") + +(defun elmine/get (plist key &rest keys) + "Execute `plist-get` recursively for `plist`. + +Example: + (setq plist '(:a 3 + :b (:c 12 + :d (:e 31)))) + + (elmine/get plist \"a\") + ;; => 3 + (elmine/get plist :b) + ;; => (:c 12 :d (:e 31)) + (elmine/get plist :b :c) + ;; => 12 + (elmine/get plist :b :d :e) + ;; => 31 + (elmine/get plist :b :a) + ;; => nil + (elmine/get plist :a :c) + ;; => nil" + (save-match-data + (let ((ret (plist-get plist key))) + (while (and keys ret) + (if (listp ret) + (progn + (setq ret (elmine/get ret (car keys))) + (setq keys (cdr keys))) + (setq ret nil))) + ret))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; HTTP functions using Emacs URL package ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun elmine/make-key (string) + (make-symbol (format ":%s" (s-dashed-words string)))) + +(defun elmine/ensure-string (object) + "Return a string representation of OBJECT." + (cond ((stringp object) object) + ((keywordp object) (substring (format "%s" object) 1 nil)) + ((symbolp object) (symbol-name object)) + ((numberp object) (number-to-string object)) + (t (pp-to-string object)))) + +(defun elmine/api-build-query-string (plist) + "Builds a query string from a given plist." + (if plist + (let (query-pairs) + (while plist + (let ((key (url-hexify-string (elmine/ensure-string (car plist)))) + (val (url-hexify-string (elmine/ensure-string (cadr plist))))) + (setq query-pairs (cons (format "%s=%s" key val) query-pairs)) + (setq plist (cddr plist)))) + (concat "?" (s-join "&" query-pairs))) + "")) + +(defun elmine/api-build-url (path params) + "Creates a URL from a relative PATH, a plist of query PARAMS and +the dynamically bound `redmine-api-key` and `redmine-host` variables." + (let ((host (s-chop-suffix "/" redmine-host)) + (query-str (elmine/api-build-query-string params))) + (concat host path query-str))) + +(defun elmine/api-raw (method path data params) + "Perform a raw HTTP request with given METHOD, a relative PATH and a +plist of PARAMS for the query." + (let* ((redmine-host (if (boundp 'redmine-host) + redmine-host + elmine/host)) + (redmine-api-key (if (boundp 'redmine-api-key) + redmine-api-key + elmine/api-key)) + (url (elmine/api-build-url path params)) + (url-request-method method) + (url-request-extra-headers + `(("Content-Type" . "application/json") + ("X-Redmine-API-Key" . ,redmine-api-key))) + (url-request-data data) + header-end status header body) + (save-excursion + (switch-to-buffer (url-retrieve-synchronously url)) + (beginning-of-buffer) + (setq header-end (save-excursion + (if (re-search-forward "^$" nil t) + (progn + (forward-char) + (point)) + (point-max)))) + (when (re-search-forward "^HTTP/\\(1\\.0\\|1\\.1\\) \\([0-9]+\\) \\([A-Za-z ]+\\)$" nil t) + (setq status (plist-put status :code (string-to-number (match-string 2)))) + (setq status (plist-put status :text (match-string 3)))) + (while (re-search-forward "^\\([^:]+\\): \\(.*\\)" header-end t) + (setq header (cons (match-string 1) (cons (match-string 2) header)))) + (unless (eq header-end (point-max)) + (setq body (url-unhex-string + (buffer-substring header-end (point-max))))) + (kill-buffer)) + `(:status ,status + :header ,header + :body ,body))) + +(defun elmine/api-get (element path &rest params) + "Perform an HTTP GET request and return a PLIST with the request information. +It returns the " + (let* ((params (if (listp (car params)) (car params) params)) + (response (elmine/api-raw "GET" path nil params)) + (object (elmine/api-decode (plist-get response :body))) + ) + (if element + (plist-get object element) + object))) + +(defun elmine/api-post (element object path &rest params) + "Does an http POST request and returns response status as symbol." + (let* ((params (if (listp (car params)) (car params) params)) + (data (elmine/api-encode `(,element ,object))) + (response (elmine/api-raw "POST" path data params)) + (object (elmine/api-decode (plist-get response :body)))) + object)) + +(defun elmine/api-put (element object path &rest params) + "Does an http PUT request and returns the response status as symbol. +Either :ok or :unprocessible." + (let* ((params (if (listp (car params)) (car params) params)) + (data (elmine/api-encode `(,element ,object))) + (response (elmine/api-raw "PUT" path data params)) + (object (elmine/api-decode (plist-get response :body))) + (status (elmine/get response :status :code))) + (cond ((eq status 200) t) + ((eq status 404) + (signal 'no-such-resource `(:response ,response)))))) + +(defun elmine/api-delete (path &rest params) + "Does an http DELETE request and returns the body of the response." + (let* ((params (if (listp (car params)) (car params) params)) + (response (elmine/api-raw "DELETE" path nil params)) + (status (elmine/get response :status :code))) + (cond ((eq status 200) t) + ((eq status 404) + (signal 'no-such-resource `(:response ,response)))))) + +(defun elmine/api-get-all (element path &rest filters) + "Return list of ELEMENT items retrieved from PATH limited by FILTERS. + +Limiting items by count can be done using `limit' in FILTERS: +- If `limit' is t, return all items. +- If `limit' is number, return items up to that count. +- Otherwise return up to 25 items (redmine api default)." + (let* ((initial-limit (plist-get filters :limit)) + (initial-limit (when (or + (eq t initial-limit) + (numberp initial-limit)) + initial-limit)) + (limit (if (eq t initial-limit) 100 initial-limit)) + (response-object (apply #'elmine/api-get nil path (plist-put filters :limit limit))) + (offset (elmine/get response-object :offset)) + (limit (elmine/get response-object :limit)) + (total-count (elmine/get response-object :total_count)) + (issue-list (elmine/get response-object element))) + (if (and offset + limit + (< (+ offset limit) total-count) + (or (eq t initial-limit) + (and initial-limit (< (+ offset limit) initial-limit)))) + (let* ((offset (+ offset limit)) + (limit (if (eq t initial-limit) + t + (- initial-limit offset)))) + (append issue-list (apply #'elmine/api-get-all element path + (plist-merge + filters + `(:offset ,offset :limit ,limit))))) + issue-list))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Simple JSON decode/encode functions ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun elmine/api-decode (json-string) + "Parses a JSON string and returns an object. Per default JSON objects are +going to be hashtables and JSON arrays are going to be lists." + (if (null json-string) + nil + (let ((json-object-type 'plist) + (json-array-type 'list)) + (condition-case err + (json-read-from-string json-string) + (json-readtable-error + (message "%s: Could not parse json-string into an object. See %s" + (error-message-string err) json-string)))))) + +(defun elmine/api-encode (object) + "Return a JSON representation from the given object." + (let ((json-object-type 'plist) + (json-array-type 'list)) + (condition-case err + (encode-coding-string (json-encode object) 'utf-8) + (json-readtable-error + (message "%s: Could not encode object into JSON string. See %s" + (error-message-string err) object))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; API functions to retrieve data from redmine ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun elmine/get-issues (&rest filters) + "Get a list of issues." + (apply #'elmine/api-get-all :issues "/issues.json" filters)) + +(defun elmine/get-issue (id &rest params) + "Get a specific issue via id." + (elmine/api-get :issue (format "/issues/%s.json" id) params)) + +(defun elmine/create-issue (&rest params) + "Create an issue. + +You can create an issue with giving each of its parameters or simply passing +an issue object to this function." + (let ((object (if (listp (car params)) (car params) params))) + (elmine/api-post :issue object "/issues.json"))) + +(defun elmine/update-issue (object) + "Update an issue. The object passed to this function gets updated." + (let ((id (plist-get object :id))) + (elmine/api-put :issue object (format "/issues/%s.json" id)))) + +(defun elmine/delete-issue (id) + "Deletes an issue with a specific id." + (elmine/api-delete (format "/issues/%s.json" id))) + +(defun elmine/get-issue-time-entries (issue-id &rest filters) + "Gets all time entries for a specific issue." + (apply #'elmine/api-get-all :time_entries + (format "/issues/%s/time_entries.json" issue-id) filters)) + +(defun elmine/get-issue-relations (issue-id) + "Get all relations for a specific issue." + (apply #'elmine/api-get-all :relations + (format "/issues/%s/relations.json" issue-id) nil)) + +(defun elmine/get-projects (&rest filters) + "Get a list with projects." + (apply #'elmine/api-get-all :projects "/projects.json" filters)) + +(defun elmine/get-project (project) + "Get a specific project." + (elmine/api-get :project (format "/projects/%s.json" project))) + +(defun elmine/create-project (&rest params) + "Create a new project." + (let ((object (if (listp (car params)) (car params) params))) + (elmine/api-post :project object "/projects.json"))) + +(defun elmine/update-project (&rest params) + "Update a given project." + (let* ((object (if (listp (car params)) (car params) params)) + (identifier (plist-get object :identifier))) + (elmine/api-put :project object + (format "/projects/%s.json" identifier)))) + +(defun elmine/delete-project (project) + "Deletes a project." + (elmine/api-delete (format "/projects/%s.json" project))) + +(defun elmine/get-project-categories (project &rest filters) + "Get all categories for a project." + (apply #'elmine/api-get-all :issue_categories + (format "/projects/%s/issue_categories.json" project) filters)) + +(defun elmine/get-project-issues (project &rest filters) + "Get a list of issues for a specific project." + (apply #'elmine/api-get-all :issues + (format "/projects/%s/issues.json" project) filters)) + +(defun elmine/get-project-versions (project &rest filters) + "Get a list of versions for a specific project." + (apply #'elmine/api-get-all :versions + (format "/projects/%s/versions.json" project) filters)) + +(defun elmine/get-project-memberships (project &rest filters) + "Get PROJECT memberships limited by FILTERS." + (apply #'elmine/api-get-all :memberships + (format "/projects/%s/memberships.json" project) filters)) + +(defun elmine/get-version (id) + "Get a specific version." + (elmine/api-get :version (format "/versions/%s.json" id))) + +(defun elmine/create-version (&rest params) + "Create a new version." + (let* ((object (if (listp (car params)) (car params) params)) + (project (plist-get object :project_id))) + (elmine/api-post :version object + (format "/projects/%s/versions.json" project)))) + +(defun elmine/update-version (&rest params) + "Update a given version." + (let* ((object (if (listp (car params)) (car params) params)) + (id (plist-get object :id))) + (elmine/api-put :version object + (format "/versions/%s.json" id)))) + +(defun elmine/get-issue-statuses () + "Get a list of available issue statuses." + (elmine/api-get-all :issue_statuses "/issue_statuses.json")) + +(defun elmine/get-issue-priorities (&rest params) + "Get a list of issue priorities." + (apply #'elmine/api-get-all :issue_priorities + "/enumerations/issue_priorities.json" params)) + +(defun elmine/get-trackers () + "Get a list of tracker names and their IDs." + (elmine/api-get-all :trackers "/trackers.json")) + +(defun elmine/get-issue-priorities () + "Get a list of issue priorities and their IDs." + (elmine/api-get-all :issue_priorities "/enumerations/issue_priorities.json")) + +(defun elmine/get-time-entries (&rest filters) + "Get a list of time entries." + (apply #'elmine/api-get-all :time_entries "/time_entries.json" filters)) + +(defun elmine/get-time-entry (id) + "Get a specific time entry." + (elmine/api-get :time_entry (format "/time_entries/%s.json" id))) + +(defun elmine/get-time-entry-activities (&rest params) + "Get a list of time entry activities." + (apply #'elmine/api-get-all :time_entry_activities + "/enumerations/time_entry_activities.json" params)) + +(defun elmine/create-time-entry (&rest params) + "Create a new time entry" + (let* ((object (if (listp (car params)) (car params) params))) + (elmine/api-post :time_entry object "/time_entries.json"))) + +(defun elmine/update-time-entry (&rest params) + "Update a given time entry." + (let* ((object (if (listp (car params)) (car params) params)) + (id (plist-get object :id))) + (elmine/api-put :time_entry object (format "/time_entries/%s.json" id)))) + +(defun elmine/delete-time-entry (id) + "Delete a specific time entry." + (elmine/api-delete (format "/time_entries/%s.json" id))) + +(defun elmine/get-users (&rest filters) + "Get a list of users limited by FILTERS." + (apply #'elmine/api-get-all :users "/users.json" filters)) + +(defun elmine/get-user (user &rest params) + "Get USER. PARAMS can be used to retrieve additional details. +If USER is `current', get user whose credentials are used." + (elmine/api-get :user (format "/users/%s.json" user) params)) + +(provide 'elmine) + +;;; elmine.el ends here diff --git a/lisp/orgmine.el b/lisp/orgmine.el new file mode 100644 index 0000000..2375f50 --- /dev/null +++ b/lisp/orgmine.el @@ -0,0 +1,3411 @@ +;;; orgmine.el --- minor mode for org-mode with redmine integration + +;; Copyright (C) 2015-2017 Tokuya Kameshima + +;; Author: Tokuya Kameshima +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: https://github.com/kametoku/orgmine + +;; This file is not part of GNU Emacs. +;; +;; 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 3 +;; 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; orgmine is a minor mode for org-mode with Redmine integration. +;; In a orgmine-mode buffer, you can retrieve the issues from Redmine, +;; edit the entries locally, and submit the changes to Redmine. + +;; - [ ] implement orgmine-copy-issue to push an issue tree to clipboard +;; so that it will be inserted into the buffer as a new issue. +;; - [ ] suppress adding TODO keyword to headlines without :issue: tag. If +;; a headline already has a TODO keyword, changing todo status is +;; permitted. Alternatively, if the current position is under an +;; issue subtree, changing todo keyword will be applied to the issue +;; headline. This is the case for setting properties as well. +;; - [ ] improve syncing process with cache effectively. +;; - [ ] changing issue status will updates TODO keyword as well. +;; - [ ] more supports for custom fields. +;; - [ ] orgmine-y-or-n permits scroll the plist buffer. +;; - [ ] a command to show properties of the current entry in other window. + +;;; Code: + +(require 'elmine) +(require 'request) +(require 'json) +(require 's) +(require 'org) +(require 'org-archive) +(require 'timezone) + +(defgroup orgmine nil + "Options concerning orgmie minor mode." + :tag "Org Mine" + :group 'org) + +(defcustom orgmine-issue-title-format + "[[redmine:issues/%{id}][#%{id}]] %{subject}" + "Title format for issue entry." + :group 'orgmine) + +(defcustom orgmine-journal-title-format + "[[redmine:issues/%{id}#note-%{count}][V#%{id}-%{count}]] %{created_on} %{author}" + "Title format for journal entry." + :group 'orgmine) + +(defcustom orgmine-version-title-format + "[[redmine:versions/%{id}][V#%{id}]] %{name}" + "Title format for version entry." + :group 'orgmine) + +(defcustom orgmine-tracker-title-format "%{name}" + "Title format for tracker entry." + :group 'orgmine) + +(defcustom orgmine-project-title-format + "[[redmine:projects/%{identifier}][%{identifier}]] %{name}" + "Title format for project entry." + :group 'orgmine) + +(defcustom orgmine-wiki-page-title-format + "[[redmine:projects/%{project}/wiki/%{title}][%{title}]]" + "Title format for wiki page entry." + :group 'orgmine) + +(defcustom orgmine-title-format-regexp + (let ((brackert-link-regexp + "\\[\\[\\(?:[^][]+\\)\\]\\(?:\\[\\(?:[^][]+\\)\\]\\)?\\]")) + (concat "^[ \t]*" brackert-link-regexp "[ \t]*\\(.*?\\)" + "[ \t]*\\(?:(" brackert-link-regexp ")\\)?$")) + "Regular express to extract subject part from headline title." + :group 'orgmine) + +(defcustom orgmine-user-name-format "%{firstname} %{lastname}" + "User name format." + :group 'orgmine) + +(defcustom orgmine-attachment-format + (concat "[[%{content_url}][%{filename}]] (%{filesize} bytes)" + " %{author.name} %{created_on}") + "attachment item format." + :group 'orgmine) + +(defcustom orgmine-journal-details-drawer "DETAILS" + "Drawer name to hold journal details." + :group 'orgmine) + +(defcustom orgmine-note-block-begin "#+begin_src gfm" + "" + :group 'orgmine) + +(defcustom orgmine-note-block-end "#+end_src" + "" + :group 'orgmine) + +(defcustom orgmine-tags + '((update-me . "UPDATE_ME") + (create-me . "CREATE_ME") + (refile-me . "REFILE_ME") + (project . "project") + (tracker . "tracker") + (versions . "versions") + (version . "version") + (issue . "issue") + (description . "description") + (journals . "journals") + (journal . "journal") + (attachments . "attachments") + (wiki . "wiki")) + "Alist of tags which are used in orgmine mode." + :group 'orgmine) + +(defvar orgmine-tag-update-me) +(defvar orgmine-tag-create-me) +(defvar orgmine-tag-refile-me) +(defvar orgmine-tag-project) +(defvar orgmine-tag-tracker) +(defvar orgmine-tag-versions) +(defvar orgmine-tag-version) +(defvar orgmine-tag-issue) +(defvar orgmine-tag-description) +(defvar orgmine-tag-journals) +(defvar orgmine-tag-journal) +(defvar orgmine-tag-attachments) +(defvar orgmine-tag-wiki) + +(defcustom orgmine-servers + '(("redmine" + (host . "http://www.example.com") + (api-key . "blabblabblab") + (issue-title-format . "[[redmine:issues/%{id}][#%{id}]] %{subject}") + (journal-title-format + . "[[redmine:issues/%{id}#note-%{count}][V#%{id}-%{count}]] %{created_on} %{author}") + (version-title-format . "[[redmine:versions/%{id}][V#%{id}]] %{name}") + (tracker-title-format . "%{name}") + (project-title-format + . "[[redmine:projects/%{identifier}][%{identifier}]] %{name}") + (user-name-format . "%{firstname} %{lastname}") + (default-todo-keyword . "New")) + ("localhost" + (host . "http://localhost:8080/redmine") + (api-key . "XXX") + (issue-title-format . "[\[localhost:issues/%{id}][#%{id}]] %{subject}") + (journal-title-format + . "[\[localhost:issues/%{id}#note-%{count}][V#%{id}-%{count}]] %{created_on} %{author}") + (version-title-format . "[\[localhost:versions/%{id}][V#%{id}]] %{name}") + (project-title-format . "[\[localhost:projects/%{identifier}][%{name}]]") + (user-name-format . "%{firstname} %{lastname}") + (default-todo-keyword . "New"))) + "An alist of redmine servers. +Each element has the form (NAME CONFIGURATION)." + :group 'orgmine) + +(defcustom orgmine-setup-hook nil + "Hook called in `orgmine-setup'." + :group 'orgmine + :type 'hook) + +(defcustom orgmine-issue-buffer-hook nil + "Hook called in `orgmine-issue-buffer'." + :group 'orgmine + :type 'hook) + + +;; +;; for Redmine REST API (replacement of elmine.el, in the future) +;; Use request.el for the backend http protocol. +;; You can use curl command line program if it is installed. +;; + +(defun orgmine/api-json-read () + "Parse and return the JSON object following point. +Advance point just past JSON object." + (json-skip-whitespace) + (unless (eq (json-peek) :json-eof) + (let ((json-object-type 'plist) + (json-array-type 'list)) + (json-read)))) + +(defun orgmine/api-decode (json-string) + "Parse a JSON string JSON-STRING and return an object. +Per default JSON objects are going to be hashtables and JSON +arrays are going to be lists." + (unless (or (null json-string) + (string= json-string "")) + (let ((json-object-type 'plist) + (json-array-type 'list) + (json-false nil)) + (json-read-from-string json-string)))) + +(defun orgmine/api-encode (object) + "Return a JSON representation from the given object OBJECT." + (let ((json-object-type 'plist) + (json-array-type 'list)) + (encode-coding-string (json-encode object) 'utf-8))) + +(defun orgmine/api-build-url (path) + (concat orgmine-host path)) + +(defun orgmine/api-plist-to-alist (plist) + ;; (:k1 v1 :k2 v2 ...) -> (("k1" . v1) ("k2" . v2) ...) + (let (alist) + (while plist + (let ((key (elmine/ensure-string (car plist))) ; XXX + (value (car (cdr plist)))) + (push (cons key value) alist)) + (setq plist (cdr (cdr plist)))) + alist)) + +(defun orgmine/api-raw (method path data params &optional content-type) + "Perform a raw HTTP request with given METHOD, a relative PATH and a +plist of PARAMS for the query. +This is a request.el version of `elmine/api-raw'." + (if (and (not (null data)) + (listp data)) + (setq data (orgmine/api-encode data))) + (let* ((orgmine-host (cond ((boundp 'orgmine-host) orgmine-host) + ((boundp 'redmine-host) redmine-host) + (t elmine/host))) + (orgmine-api-key (cond ((boundp 'orgmine-api-key) orgmine-api-key) + ((boundp 'redmine-api-key) redmine-api-key) + (t elmine/api-key))) + (url (orgmine/api-build-url path)) + (headers `(("Content-Type" . ,(or content-type "application/json")) + ("X-Redmine-API-Key" . ,orgmine-api-key))) + (params (orgmine/api-plist-to-alist params)) + (response (request url :type method :params params :headers headers + :data data :parser 'orgmine/api-json-read :sync t)) + (err (request-response-error-thrown response)) + (status-code (request-response-status-code response)) ; eg, 200 + (status-text (request-response-header response "status")) ;eg, "200 OK" + (body (request-response-data response))) + (cond ((eq status-code 404) + (signal 'no-such-resource (list status-text url))) ;should be error? + (err (signal (car err) (cdr err)))) + response)) + +(defun orgmine/api-get (element path &rest params) + "Perform an HTTP GET request and return a PLIST with the request information." + (let* ((params (if (listp (car params)) (car params) params)) + (response (orgmine/api-raw "GET" path nil params)) + (object (request-response-data response))) + (if element + (plist-get object element) + object))) + +(defalias 'elmine/api-get 'orgmine/api-get) + +(defun orgmine/api-post (element object path &rest params) + "Perform an http POST request." + (let* ((params (if (listp (car params)) (car params) params)) + (data (list element object)) + (response (orgmine/api-raw "POST" path data params)) + (object (request-response-data response))) + object)) + +(defalias 'elmine/api-post 'orgmine/api-post) + +(defun orgmine/api-put (element object path &rest params) + "Perform an http PUT request." + (let* ((params (if (listp (car params)) (car params) params)) + (data (list element object)) + (response (orgmine/api-raw "PUT" path data params)) + (object (request-response-data response))) + object)) + +(defalias 'elmine/api-put 'orgmine/api-put) + +(defun orgmine/api-delete (path &rest params) + "Perform an http DELETE request." + (let* ((params (if (listp (car params)) (car params) params)) + (response (orgmine/api-raw "DELETE" path nil params)) + (object (request-response-data response))) + object)) + +(defalias 'elmine/api-delete 'orgmine/api-delete) + + +;; ;; workaround for decode the returned string as utf-8 +;; (defadvice json-read-string (around json-read-string-decode activate) +;; "Decode string processed in `json-read-string' as utf-8." +;; (let ((string ad-do-it)) +;; (decode-coding-string string 'utf-8))) + +;; redefine the function for workaround +(defun orgmine/json-read-string () + "Read the JSON string at point." + (unless (char-equal (json-peek) ?\") + (signal 'json-string-format (list "doesn't start with '\"'!"))) + ;; Skip over the '"' + (json-advance) + (let ((characters '()) + (char (json-peek))) + (while (not (char-equal char ?\")) + (push (if (char-equal char ?\\) + (json-read-escaped-char) + (json-pop)) + characters) + (setq char (json-peek))) + ;; Skip over the '"' + (json-advance) + (if characters +;; kame<<< +;; (apply 'string (nreverse characters)) +;; ======= + (decode-coding-string (apply 'string (nreverse characters)) + 'utf-8) +;; >>>kame + ""))) + +(defalias 'json-read-string 'orgmine/json-read-string) + +;;; XXX +;; http://www.redmine.org/projects/redmine/wiki/Rest_IssueJournals +;; '(:journals ((:details ((:new_value "3" :name "fixed_version_id" :property "attr")) +;; :created_on "2015-08-02T14:19:02Z" +;; :notes "" :user (:name "Tokuya Kameshima" :id 3) :id 3) +;; ...)) +(defun orgmine/get-issue-with-journals (id) + "Get a specific issue including journals, relations and attachments via id." +;; (elmine/api-get :issue (format "/issues/%s.json?include=journals" id))) +;; (elmine/api-get :issue (format "/issues/%s.json" id) :include "journals")) + (elmine/api-get :issue (format "/issues/%s.json" id) + :include "journals,relations,attachments")) + +(defalias 'elmine/get-issue-with-journals 'orgmine/get-issue-with-journals) + +(defun orgmine/get-project-trackers (project) + "Get trackers of a specific project." +;; (elmine/api-get :issue (format "/issues/%s.json?include=journals" id))) + (let ((plist (elmine/api-get :project (format "/projects/%s.json" project) + :include "trackers"))) + (plist-get plist :trackers))) + +(defalias 'elmine/get-project-trackers 'orgmine/get-project-trackers) + +(defun orgmine/get-users () + "Get a list with users." + (elmine/api-get-all :users "/users.json")) + +(defalias 'elmine/get-users 'orgmine/get-users) + +(defun orgmine/get-custom-fields (filters) + "Get a list with custom fields." + (apply #'elmine/api-get-all :custom_fields "/custom_fields.json" filters)) + +(defalias 'elmine/get-custom-fields 'orgmine/get-custom-fields) + +(defun orgmine/create-relation (&rest params) + "Create a new relation" + (let* ((object (if (listp (car params)) (car params) params)) + (issue-id (plist-get object :issue_id)) + (issue-to-id (plist-get object :issue_to_id)) + (relation-type (plist-get object :relation_type)) + (delay (plist-get object :delay)) + ;; plist should not have the :issue_id element. + ;; If not, redmine returns 500 error. + (plist (list :issue_to_id issue-to-id + :relation_type relation-type))) + (and delay (setq plist (plist-put plist :delay delay))) + (elmine/api-post :relation plist + (format "/issues/%s/relations.json" issue-id)))) + +(defalias 'elmine/create-relation 'orgmine/create-relation) + +(defun orgmine/delete-relation (id) + "Delete an relation with a specific id." + (elmine/api-delete (format "/relations/%s.json" id))) + +(defalias 'elmine/delete-relation 'orgmine/delete-relation) + +(defun orgmine/api-post-octet-stream (data path &rest params) + "Does an http POST request and returns response status as symbol." + (let* ((params (if (listp (car params)) (car params) params)) + (response (orgmine/api-raw "POST" path data params + "application/octet-stream")) + (object (request-response-data response))) + object)) + +(defun orgmine/upload-file (file) + "upload a specific file to Redmine for the attachment." + (let ((data (with-temp-buffer + (insert-file-contents-literally file) + (buffer-string)))) + (orgmine/api-post-octet-stream data "/uploads.json"))) + +(defalias 'elmine/upload-file 'orgmine/upload-file) + +(defun orgmine/get-project-wiki-pages (project &rest filters) + "Get a list of wiki pages for a specific project." + (apply #'elmine/api-get-all :wiki_pages + (format "/projects/%s/wiki/index.json" project) filters)) + +(defalias 'elmine/get-project-wiki-pages 'orgmine/get-project-wiki-pages) + +(defun orgmine/get-wiki-page (project title) + "Get a specific wiki page via project and title." + (elmine/api-get :wiki_page + (format "/projects/%s/wiki/%s.json" project title) + :include "attachments")) + +(defalias 'elmine/get-wiki-page 'orgmine/get-wiki-page) + +(defun orgmine/update-wiki-page (project title &rest params) + "Create or update a specific wiki page via project and title." + (let ((object (if (listp (car params)) (car params) params))) + (elmine/api-put :wiki_page object + (format "/projects/%s/wiki/%s.json" project title)))) + +(defalias 'elmine/update-wiki-page 'orgmine/update-wiki-page) + +(defun elmine/delete-wiki-page (project title) + "Delete a specific wiki page entry." + (elmine/api-delete (format "/projects/%s/wiki/%s.json" project title))) + +(defalias 'elmine/delete-wiki-page 'orgmine/delete-wiki-page) + + + +(defun orgmine-server (base-url) + "Return the server entry of the Redmine server in `orgmine-servers' +whose host is BASE-URL." + (catch 'found + (mapc (lambda (elem) + (let ((host (cdr (assoc 'host (cdr elem))))) + (if (string= host base-url) + (throw 'found elem)))) + orgmine-servers) + nil)) + +(defun orgmine-parse-issue-url (url) + "Parse URL and return a cons (SERVER . ISSUE-ID)." + (save-match-data + (if (string-match "^\\(http.*\\)/issues/\\([0-9]+\\)" url) + ;; redmine url -> orgmine + (let* ((base-url (match-string 1 link)) + (issue-id (match-string 2 link)) + (server (orgmine-server base-url))) + (if server + (cons (car server) issue-id)))))) + +(defun orgmine-issue-buffer (server issue-id &optional title) + "Create an orgmine issue buffer." + (let* ((bufname (format "*OrgMine-%s:issues/%s*" server issue-id)) + (buf (get-buffer-create bufname))) + (switch-to-buffer buf) + (erase-buffer) + (if title (insert (format "#+TITLE: %s\n" title))) + (insert (format "#+PROPERTY: om_server %s\n\n" server)) + (set-buffer-file-coding-system 'utf-8) + (org-mode) + (orgmine-mode t) + (save-excursion + (orgmine-insert-issue issue-id)) + (hide-subtree) + (show-branches) + (org-align-tags t) + (set-buffer-modified-p nil) + (run-hooks 'orgmine-issue-buffer-hook) + (message "Editing issue #%s on %s" issue-id server))) + +(defun orgmine-tag (key) + "Return tag." + (cdr (assoc key orgmine-tags))) + +(defun orgmine-setup-custom-fields (config) + (set (make-local-variable 'orgmine-custom-fields) nil) + (mapc (lambda (plist) + (let ((name (orgmine-custom-field-property-name plist))) + (add-to-list 'orgmine-custom-fields (cons name plist)))) + config)) + +(defun orgmine-setup-tags () + (mapc (lambda (elem) + (let* ((key (car elem)) + (value (cdr elem)) + (symbol (intern (format "orgmine-tag-%s" key)))) + (set (make-local-variable symbol) value))) + orgmine-tags)) + +(defvar orgmine-valid-variables + '(host api-key issue-title-format journal-title-format version-title-format + tracker-title-format project-title-format wiki-page-title-format + user-name-format custom-fields default-todo-keyword)) + +(defun orgmine-setup () + "Setup buffer local variables from ORGMINE-SERVERS per om_server property." + (let* ((server (cdr (assoc-string "om_server" org-keyword-properties t))) + (config (cdr (assoc-string server orgmine-servers t)))) + (if config + (set (make-local-variable 'orgmine-server) server)) + (mapc (lambda (elem) + (let* ((key (car elem)) + (symbol (intern (format "orgmine-%s" key))) + (value (cdr elem))) + (if (memq key orgmine-valid-variables) + (progn + (set (make-local-variable symbol) value) + (if (eq key 'custom-fields) + (orgmine-setup-custom-fields value))) + (message "orgmine-setup: %s: skipped - invalid name" key)))) + config)) + (orgmine-setup-tags) + (run-hooks 'orgmine-setup-hook)) + +(defvar orgmine-mode-map (make-sparse-keymap) + "Keymap for `orgmine-mode', a minor mode.") + +(define-minor-mode orgmine-mode + "minor mode for org-mode with Redmine integration" + :lighter "Mine" :keymap orgmine-mode-map + (org-load-modules-maybe) + (orgmine-setup) + (set (make-local-variable 'orgmine-statuses) nil) + (make-local-variable 'org-tags-exclude-from-inheritance) + (if (and orgmine-journal-details-drawer + (boundp 'org-drawers)) + (add-to-list 'org-drawers orgmine-journal-details-drawer)) + (mapc (lambda (tag) + (add-to-list 'org-tags-exclude-from-inheritance tag)) + (list orgmine-tag-update-me orgmine-tag-create-me orgmine-tag-refile-me + orgmine-tag-project orgmine-tag-tracker + orgmine-tag-versions orgmine-tag-version + orgmine-tag-issue + orgmine-tag-description orgmine-tag-journals orgmine-tag-journal + orgmine-tag-wiki orgmine-tag-attachments)) + (define-key orgmine-mode-map "\C-cma" 'orgmine-add-attachment) + (define-key orgmine-mode-map "\C-cmA" 'orgmine-insert-all-versions) + (define-key orgmine-mode-map "\C-cmc" 'orgmine-submit) + (define-key orgmine-mode-map "\C-cmd" 'orgmine-add-description) + (define-key orgmine-mode-map "\C-cme" 'orgmine-ediff) + (define-key orgmine-mode-map "\C-cmf" 'orgmine-fetch) + (define-key orgmine-mode-map "\C-cmg" 'orgmine-goto-issue) + (define-key orgmine-mode-map "\C-cmG" 'orgmine-goto-version) + (define-key orgmine-mode-map "\C-cmi" 'orgmine-add-issue) + (define-key orgmine-mode-map "\C-cmI" 'orgmine-insert-issue) + (define-key orgmine-mode-map "\C-cmj" 'orgmine-add-journal) + (define-key orgmine-mode-map "\C-cmk" 'orgmine-skeletonize-subtree) + (define-key orgmine-mode-map "\C-cmp" 'orgmine-add-project) + (define-key orgmine-mode-map "\C-cmP" 'orgmine-insert-project) + (define-key orgmine-mode-map "\C-cmr" 'orgmine-refile-me) + (define-key orgmine-mode-map "\C-cms" 'orgmine-sync-subtree-recursively) + (define-key orgmine-mode-map "\C-cmS" 'orgmine-sync-buffer) + (define-key orgmine-mode-map "\C-cmT" 'orgmine-insert-tracker) + (define-key orgmine-mode-map "\C-cmu" 'orgmine-goto-parent-issue) + (define-key orgmine-mode-map "\C-cmv" 'orgmine-add-version) + (define-key orgmine-mode-map "\C-cmV" 'orgmine-insert-version) + (define-key orgmine-mode-map "\C-cmw" 'orgmine-add-wiki-page) + (define-key orgmine-mode-map "\C-cmW" 'orgmine-insert-wiki-page) + (define-key orgmine-mode-map "\C-cm\C-w" 'orgmine-refile) + (define-key orgmine-mode-map "\C-cm#" 'orgmine-insert-template) + (define-key orgmine-mode-map "\C-cm;;" 'orgmine-set-entry-property) + (define-key orgmine-mode-map "\C-cm;a" 'orgmine-set-assigned-to) + (define-key orgmine-mode-map "\C-cm;c" 'orgmine-set-custom-field) + (define-key orgmine-mode-map "\C-cm;d" 'orgmine-set-done-ratio) + (define-key orgmine-mode-map "\C-cm;t" 'orgmine-set-tracker) + (define-key orgmine-mode-map "\C-cm;v" 'orgmine-set-version) + (define-key orgmine-mode-map "\C-cm/a" 'orgmine-show-assigned-to) + (define-key orgmine-mode-map "\C-cm/c" 'orgmine-show-child-issues) + (define-key orgmine-mode-map "\C-cm/d" 'orgmine-show-descriptions) + (define-key orgmine-mode-map "\C-cm/i" 'orgmine-show-issues) + (define-key orgmine-mode-map "\C-cm/j" 'orgmine-show-journals) + (define-key orgmine-mode-map "\C-cm/m" 'orgmine-show-assigned-to-me) + (define-key orgmine-mode-map "\C-cm/n" 'orgmine-show-notes) + (define-key orgmine-mode-map "\C-cm/p" 'orgmine-show-projects) + (define-key orgmine-mode-map "\C-cm/r" 'orgmine-show-all) + (define-key orgmine-mode-map "\C-cm/t" 'orgmine-show-trackers) + (define-key orgmine-mode-map "\C-cm/u" 'orgmine-show-create-or-update) + (define-key orgmine-mode-map "\C-cm/v" 'orgmine-show-versions) + (define-key orgmine-mode-map "\C-cm/w" 'orgmine-show-refile) + (define-key orgmine-mode-map "\C-cm?" 'orgmine-ediff) + (add-hook 'org-after-todo-state-change-hook 'orgmine-after-todo-state-change) + ) + + +(defun orgmine-insert-demoted-heading (&optional title tags-list) + "Insert a demoted headling at the beginning of the current line." + (move-beginning-of-line nil) + (if (save-match-data + (or (looking-at "^\\*+ ") (eobp))) + (open-line 1)) + (outline-insert-heading) + (org-do-demote) + (insert (or title "")) + (mapc (lambda (tag) + (org-toggle-tag tag 'on)) + tags-list)) + +(defun orgmine-idname-to-id (idname &optional for-filter) + ;; "ID:NAME" -> "ID" + (save-match-data + (cond ((string-match "^[0-9]+" idname) + (match-string 0 idname)) + ((and for-filter + (string-match "^!?\\*" idname)) ; "*" and "!*" for filter. + (match-string 0 idname))))) + +(defun orgmine-redmine-date (date) + ;; "[2011-03-02 Wed]" -> "2011-03-02" + (save-match-data + (if (string-match "[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" date) + (match-string 0 date) + ""))) + +(defun orgmine-org-date (date) + ;; "2011-03-02" -> "[2011-03-02 Wed]" + (condition-case nil + (let ((time (apply 'encode-time (org-parse-time-string date)))) + (format-time-string (org-time-stamp-format nil t) time)) + (error ""))) + +(defun orgmine-tz-org-date (time-string) + ;; "2015-08-07T02:55:08Z" -> "[2015-08-07 Fri 11:55]" + (save-match-data + (let* ((time-vector (timezone-fix-time time-string nil nil)) + (time (apply 'encode-time + (cdr (nreverse (append time-vector nil)))))) + (format-time-string (org-time-stamp-format t t) time)))) + +(defun orgmine-format-value (plist key) + ;; author.name extract value of (:author (:name NAME)) + (save-match-data + (let ((key-list (org-split-string key "\\.")) + (value plist)) + (mapc (lambda (k) + (setq value (plist-get value (intern (format ":%s" k))))) + key-list) + value))) + +(defun orgmine-format (string plist) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (while (re-search-forward "%{\\([^}]+\\)}" nil t) +;; (let* ((key (intern (format ":%s" (match-string 1)))) +;; (value (plist-get plist key))) + (let* ((key-str (match-string 1)) + (key (intern (format ":%s" key-str))) + (value (orgmine-format-value plist key-str))) + (cond ((member key '(:created_on :updated_on :closed_on)) + (setq value (orgmine-tz-org-date value)))) + (replace-match (elmine/ensure-string value) t t))) + (buffer-string))) + +(defun orgmine-extract-subject (title) + (save-match-data + (if (string-match orgmine-title-format-regexp title) + (match-string 1 title) + title))) + +(defun orgmine-map-region (func beg end &optional only-same-level) + "Call FUNC for every heading between BEG and END." + (let ((next-heading-func + (if only-same-level 'outline-get-next-sibling 'outline-next-heading)) + level) + (save-excursion + (setq end (copy-marker end)) + (goto-char beg) + (if (outline-on-heading-p t) + (funcall func)) + (while (and (progn + (funcall next-heading-func) + (< (point) end)) + (not (eobp))) + (funcall func)) + (set-marker end nil)))) + +(defun orgmine-tags-in-tag-p (tags1 tags2) + (catch 'found + (mapc (lambda (tag) + (if (member tag tags2) + (throw 'found tag))) + tags1) + nil)) + +;;; +(defun orgmine-find-headline (tag &optional end only-same-level) + "Search forward from point for headline with TAG +within the region between the current position and END. +If found, returns the beginning position of the headline." + (let* ((pred (cond ((stringp tag) 'member) + ((listp tag) 'orgmine-tags-in-tag-p))) + (pos (catch 'found + (orgmine-map-region (lambda () + (if (funcall pred tag (org-get-tags)) + (throw 'found (point)))) + (point) (or end (point-max)) + only-same-level) + nil))) + (if pos (goto-char pos)))) + +(defun orgmine-find-headline-prop (tag key value &optional end) + "Search forward from point for headline with TAG and property of KEY is VALUE. +within the region between the current position and END. +If found, returns the beginning position of the headline." + (let* ((value-regexp (if (orgmine-id-property-p key) + (format "%s\\(:?:.*\\)?" (regexp-quote value)) + (regexp-quote value))) + (name (orgmine-property-name key)) + (property-regexp (format "^[ \t]*:%s:[ \t]+%s[ \t]*$" + (regexp-quote name) value-regexp))) + (catch 'found + (while (re-search-forward property-regexp end t) + (let ((pos (point)) + (tags (progn + (outline-previous-heading) + (org-get-tags)))) + (if (and (member tag tags) + (equal (nth 1 (orgmine-get-property nil key)) value)) + (throw 'found (point))) + (goto-char pos))) + nil))) + +(defun orgmine-find-headline-ancestor (tag &optional no-error) + "Find a headline with TAG going back to ancestor headlines. +Return org-element data of the headline found. +If not found and NO-ERROR, return nil. Otherwise, raise an error." +;; +Set point to the beginning of the headline found and return non-nil.+ + (org-with-wide-buffer + (unless (eq (org-element-type (org-element-at-point)) 'headline) + (outline-previous-heading)) + (catch 'found + (let (no-more-ancestor) + (while (not no-more-ancestor) + (let ((element (org-element-at-point))) + (cond ((member tag (org-element-property :tags element)) + (throw 'found element)) + ((<= (funcall outline-level) 1) + (setq no-more-ancestor t)) ; not found + (t (outline-up-heading 1)))))) + (unless no-error + (error "No redmine %s headline found" tag))))) + +(defun orgmine-delete-headline (tag &optional end only-same-level) + "Search forward from point for headline with TAG +within the region between the current position and END. +If the headline is found, delete the subtree of the headline." + (save-excursion + (while (orgmine-find-headline tag end only-same-level) + (let ((region (orgmine-subtree-region))) + (delete-region (car region) (cdr region))) + (outline-next-heading)))) + +(defun orgmine-note (headline) + "return note in src-block element." + (save-excursion + (save-restriction + (let ((start (org-element-property :begin headline))) + (goto-char start) + (outline-next-heading) + (narrow-to-region start (point)) + (let* ((tree (org-element-parse-buffer)) + (src-block (org-element-map tree 'src-block 'identity nil t))) + (org-element-property :value src-block)))))) + +(defun orgmine-um-headline (beg end tag) + "return headlines with :UPDATE_ME: tag." + (save-excursion + (goto-char beg) + (let ((headline)) + (while (orgmine-find-headline orgmine-tag-update-me end t) + (let ((tags (org-get-tags))) + (cond ((member tag tags) + (if headline + (error "More than one %s headlines for an entry." tag) + (setq headline (org-element-at-point)))) + ((or (member orgmine-tag-description tags) + (member orgmine-tag-attachments tags) + (member orgmine-tag-journal tags) + (member orgmine-tag-issue tags) + (member orgmine-tag-version tags) + (member orgmine-tag-tracker tags) + (member orgmine-tag-project tags) + (member orgmine-tag-wiki tags))) ; just ignore + (t (error "invalid headline %s for :UPDATE_ME: tag." tag)))) +;; (outline-next-heading)) + (outline-get-next-sibling)) + headline))) + +(defun orgmine-parse-attachments-plain-list (element) + "Parse plain list of attachments to upload. +Return list of plist (:path PATH :filename FILENAME :description DESCRIPTION)." + (if (not element) + nil + (save-excursion + (goto-char (org-element-property :begin element)) + (let* ((end (cdr (orgmine-subtree-region))) + (plain-link-regexp "file:\\([^ \t\n]+\\)\\(?:::[^ \t\n]+\\)") + (bracket-link-regexp + (concat "\\[\\[\\(?:file:\\([^][]+\\)" + "\\(?:::\\(?:[^][]+\\)\\)?\\)\\]" + "\\(?:\\[\\([^][]+\\)\\]\\)?\\]")) + attachments) + (while (re-search-forward "^[ \t]*[+*-] +" end t) + (let ((plist + (cond ((looking-at plain-link-regexp) + (let* ((path (match-string-no-properties 1)) + (filename (file-name-nondirectory path))) + (list :path path :filename filename))) + ((looking-at bracket-link-regexp) + (let* ((path (match-string-no-properties 1)) + (filename (file-name-nondirectory + (or (match-string-no-properties 2) + path)))) + (list :path path :filename filename)))))) + (when plist + (goto-char (match-end 0)) + (if (looking-at "[ \t]*\\(.+\\)[ \t]*$") + (let ((description (match-string-no-properties 1))) + (setq plist (plist-put plist :description description)))) + (add-to-list 'attachments plist t)))) + attachments)))) + +(defun orgmine-um-headlines (beg end) + "return headlines with :UPDATE_ME: tag. +Return value: (DESCRIPTION JOURNAL ATTACHMENTS)" + (save-excursion + (let* ((description (orgmine-um-headline beg end orgmine-tag-description)) + (attachments (orgmine-parse-attachments-plain-list + (orgmine-um-headline beg end orgmine-tag-attachments))) + (journals (progn + (goto-char beg) + (orgmine-find-headline orgmine-tag-journals end t))) + (journal (and journals + (goto-char journals) + (org-goto-first-child) + (orgmine-um-headline (point) end + orgmine-tag-journal)))) + (list description journal attachments)))) + +(defun orgmine-current-issue-heading (&optional no-error) + "Move to the beginning of the current issue headline." + (let ((issue (orgmine-find-headline-ancestor orgmine-tag-issue no-error))) + (when issue + (goto-char (org-element-property :begin issue)) + issue))) + +(defun orgmine-current-entry-heading (&optional no-error) + "Move to the beginning of current entry headline +or move to current issue headline." + (condition-case err + (org-back-to-heading) + (error (unless no-error (error (nth 1 err))))) + (let ((tags (org-get-tags))) + (cond ((or (member orgmine-tag-project tags) + (member orgmine-tag-tracker tags) + (member orgmine-tag-version tags) + (member orgmine-tag-wiki tags)) + (org-element-at-point)) + (t (orgmine-current-issue-heading no-error))))) + +(defun orgmine-property-name (key) + "Convert Redmine REST API property name to org-mode property name." + (format "om_%s" key)) + +(defun orgmine-prop (property) + ;; "trcker" -> :tracker_id + (intern (format (if (orgmine-id-property-p property) + ":%s_id" ":%s") + property))) + +(defun orgmine-name (plist &optional format escape) + (let ((name (if format + (orgmine-format format plist) + (plist-get plist :name)))) + (if (and name escape) + (replace-regexp-in-string " " "\\\\ " name) + name))) + +(defun orgmine-idname (plist &optional format escape) + ;; plist -> "ID:NAME" + (let ((id (plist-get plist :id)) + (name (orgmine-name plist format escape))) + (cond ((and id name) + (format "%s:%s" id name)) + (id + (elmine/ensure-string id))))) + +(defun orgmine-delete-properties (pom regexp) + "Delete entry properties at POM which match REGEXP." + (let ((properties (orgmine-entry-properties pom 'all))) + (save-match-data + (mapc (lambda (prop) + (let ((property (car prop))) + (if (string-match regexp property) +;; (org-delete-property property)))) + (org-entry-delete nil property)))) + properties)))) + +(defun orgmine-custom-field-property-name (plist) + ;; (:value "3" :name "Owner" :id 1) -> "om_cf_1_Owner" + (let ((org-url-hexify-p nil)) + (format "om_cf_%s_%s" + (plist-get plist :id) (org-link-encode (plist-get plist :name) + '(? ?% ?:))))) + +(defun orgmine-custom-field-plist (property-name) + ;; "om_cf_1_Owner" -> (:name "Owner" :id 1) + (save-match-data + (if (string-match "^om_cf_\\([0-9]+\\)_\\(.*\\)" property-name) + (list :name (org-link-decode (match-string 2 property-name)) + :id (match-string 1 property-name))))) + +(defun orgmine-set-properties-custom-fields (custom-fields) + ;; ((:value \"3\" :name \"Owner\" :id 1)) + ;; erase "oc_cf_*" properties. + (orgmine-delete-properties nil "^om_cf_") + (mapc (lambda (cf-plist) + (let* ((name (orgmine-custom-field-property-name cf-plist)) + (value (plist-get cf-plist :value)) + (str-value (if (listp value) + (mapconcat 'org-entry-protect-space value " ") + (org-entry-protect-space + (elmine/ensure-string value))))) + (if (and value (> (length str-value) 0)) + (org-set-property name str-value)))) + custom-fields)) + +(defvar orgmine-relations + '(("duplicates" . "duplicated") + ("blocks" . "blocked") + ("precedes" . "follows") + ("copied_to" . "copied_from"))) + +(defun orgmine-relation-property-type (plist &optional my-id) + (let ((type (plist-get plist :relation_type)) + (issue-to-id (plist-get plist :issue_to_id))) + (if (equal my-id issue-to-id) + (or (cdr (assoc type orgmine-relations)) + (car (rassoc type orgmine-relations)) + type) + type))) + +(defun orgmine-relation-property-name (plist &optional my-id) + ;; (:relation_type "precedes" :issue_to_id 10 :delay 0 :id 1234) + ;; -> "om_relation_1234_precedesr" + (let ((type (orgmine-relation-property-type plist my-id)) + (id (plist-get plist :id))) + (format "om_relation_%s_%s" id type))) + +(defun orgmine-relation-property-value (plist &optional my-id) + (let* ((type (orgmine-relation-property-type plist my-id)) + (issue-to-id (plist-get plist :issue_to_id)) + (other-id (elmine/ensure-string (if (equal my-id issue-to-id) + (plist-get plist :issue_id) + issue-to-id))) + (delay (plist-get relation :delay))) + (if (and (member type '("precedes" "follows")) delay) + (format "%s/d%s" other-id delay) + other-id))) + +(defun orgmine-relation-plist (property &optional my-id) + ;; "om_relation_1234_precedes" -> (:relation_type "precedes" :id 1234) + (save-match-data + (let ((name (car property)) + (value (cdr property)) + plist) + (if (string-match "^om_relation_\\(?:\\([0-9]+\\)_\\)?\\(.*\\)" name) + (let ((id (match-string 1 name)) + (type (match-string 2 name))) + (if type + (progn (setq plist (list :relation_type type)) + (if id (setq plist (plist-put plist :id id))))))) + (if (and plist + (string-match "^\\([0-9]+\\)\\(?:/d\\([0-9]+\\)\\)?" value)) + (let* ((other-id (match-string 1 value)) + (delay (match-string 2 value))) + (setq plist (plist-put plist :issue_to_id other-id)) + (if my-id (setq plist (plist-put plist :issue_id my-id))) + (if delay (setq plist (plist-put plist :delay delay))))) + plist))) + +(defun orgmine-set-properties-relations (relations redmine-issue) + (orgmine-delete-properties nil "^om_relation_") + (let ((id (plist-get redmine-issue :id))) + (mapc (lambda (relation) + (let* ((name (orgmine-relation-property-name relation id)) + (value (orgmine-relation-property-value relation id))) + (org-set-property name value))) + relations))) + +(defun orgmine-set-properties (type redmine-issue property-list) + "Set properties to the current headline per REDMINE-ISSUES. +Only the properties provided in PROPERTY-LIST are updated." + (mapc (lambda (key) + (let* ((name (orgmine-property-name key)) + (prop (intern (format ":%s" key))) +;; (prop (orgmine-prop key)) + (value (cond ((and (eq key type) + (orgmine-idname redmine-issue))) + (t (plist-get redmine-issue prop))))) + ;; TODO: timestamp conversion: + ;; yyyy-mm-dd -> [yyyy-mm-dd xxx] + (cond ((eq key 'custom_fields) + (orgmine-set-properties-custom-fields value)) + ((eq key 'relations) + (orgmine-set-properties-relations value redmine-issue)) + ((null value) + (org-entry-delete nil name)) + ((listp value) ; '(:name NAME :id ID) + (org-set-property name (orgmine-idname value))) + ;; XXX: second info will be lost if converting to + ;; org-mode timestamp, hh:mm:ss -> hh:mm +;; ((member prop '(:created_on :updated_on :closed_on)) +;; (org-set-property name (orgmine-tz-org-date value))) + ((member prop '(:start_date :due_date)) + (org-set-property name (orgmine-org-date value))) + (t + (org-set-property name (elmine/ensure-string value)))))) + property-list)) + +(defvar orgmine-id-properties '(project assigned_to tracker fixed_version + author category) + "redmine property names whose value is plist of (:id ID :name NAME).") + +(defun orgmine-id-property-p (property) + "Non-nil if PROPERTY is a redmine ID property whose value is +a plist of (:id ID :name NAME)." + (memq property orgmine-id-properties)) + +(defun orgmine-entry-properties (&optional pom which) + "Workaround for old `org-entry-properties' that cannot get properties +from the headline property drawer." + (condition-case err + (org-entry-properties pom which "") + (error + (if (eq (car err) 'wrong-number-of-arguments) + (org-entry-properties pom which))))) + +(defun orgmine-get-property-custom-fields (pom &optional properties) + (or properties + (setq properties (orgmine-entry-properties pom 'all))) + (let (custom-fields) + (mapc (lambda (property) + (let* ((name (car property)) + (plist (orgmine-custom-field-plist name))) + (if (and plist + (not (orgmine-plist-list-get custom-fields + :id (plist-get plist :id)))) + (let* ((props (cdr (assoc-string name orgmine-custom-fields + t))) + (value (cdr property))) + (if (plist-get props :multiple) + (setq value (mapcar 'org-entry-restore-space + (org-split-string value "[ \t]"))) + (setq value (org-entry-restore-space value))) + (add-to-list 'custom-fields + (nconc plist (list :value value))))))) + properties) +;; custom-fields)) + (if custom-fields + ;; workaround for `json-enconde-list', which wrongly handles + ;; list of plist as alist. + (add-to-list 'custom-fields nil t)))) + +(defun orgmine-relation-value-plist (value &optional my-id) + ;; "123/d3" -> (:issue_to_id 123 :delay 3) + ;; "444" -> (:issue_to_id 444) + (save-excursion + (if (string-match "^\\([0-9]+\\)\\(?:/d\\([0-9]+\\)\\)?" value) + (let* ((other-id (match-string 1 value)) + (delay (match-string 2 value)) + (plist (cond ((null my-id) + (list :issue_to_id other-id)) + ((equal my-id other-id) + (list :issue_to_id my-id :issue-id other-id)) + (t + (list :issue_to_id other-id :issue-id my-id))))) + (if delay + (plist-put plist :delay delay) + plist))))) + +(defun orgmine-get-property-relations (pom &optional properties) + (or properties + (setq properties (orgmine-entry-properties pom 'all))) + (let* ((issue (orgmine-find-headline-ancestor orgmine-tag-issue t)) + (beg (org-element-property :begin issue)) + (id (orgmine-get-id beg)) + relations) + (if issue + (mapc (lambda (property) + (let* ((plist (orgmine-relation-plist property id))) + (if plist + (add-to-list 'relations plist)))) + properties)) + ;; (if relations +;; ;; workaround for `json-enconde-list', which wrongly handles +;; ;; list of plist as alist. +;; (add-to-list 'relations nil t)) + relations)) + +(defun orgmine-get-property (pom property + &optional properties inherit for-filter) + (cond + ((eq property 'custom_fields) + (let ((custom-fields (and (boundp 'orgmine-custom-fields) + (orgmine-get-property-custom-fields pom)))) + (if custom-fields (list :custom_fields custom-fields)))) + ((eq property 'relations) + (let ((relations (orgmine-get-property-relations pom))) + (if relations (list :relations relations)))) + (t + (let* ((name (orgmine-property-name property)) ; 'id -> "om_id" and so on + (id-property-p (orgmine-id-property-p property)) + (prop (intern (format (if id-property-p ":%s_id" ":%s") + property))) + (value (if (or inherit (not properties)) + (save-restriction +;; (widen) +;; (org-show-hidden-entry) ;XXX + (org-entry-get pom name inherit)) +;; (or properties +;; (setq properties (orgmine-entry-properties pom 'all))) + (cdr (assoc-string name properties t))))) + (if value + (let ((redmine-value + (cond (id-property-p + (orgmine-idname-to-id value for-filter)) + ((member prop '(:start_date :due_date)) + (orgmine-redmine-date value)) + (t value)))) + (list prop redmine-value))))))) + +(defun orgmine-get-properties (pom property-list &optional inherit for-filter) + "Get properties from the headline at point-or-maker POM. +Only the properties given by PROPERTY-LIST are retrieved." + (let ((properties (unless inherit (orgmine-entry-properties pom 'all))) + plist) + (mapc (lambda (property) + (let ((list (orgmine-get-property pom property + properties inherit for-filter))) + (if list + (setq plist (plist-merge plist list))))) + property-list) + plist)) + +(defun orgmine-get-id (pom &optional id-prop properties) + (or id-prop (setq id-prop 'id)) + (let* ((plist (orgmine-get-property pom id-prop properties)) + (id (nth 1 plist))) + id)) + +(defun orgmine-todo-keyword (name) + "Convert Redmine a status name to orgmode todo keyword. +Space characters and brackets are removed from the status name." + (replace-regexp-in-string "(.*)" "" + (replace-regexp-in-string " " "" name))) + +(defvar orgmine-statuses) + +(defun orgmine-issue-status-id (todo-keyword) + ;; orgmode todo-keyword -> redmine status id + ;; TODO: cache statues + (or orgmine-statuses (setq orgmine-statuses (elmine/get-issue-statuses))) + (catch 'found + (mapc (lambda (status) + (if (equal (orgmine-todo-keyword (plist-get status :name)) + todo-keyword) + (throw 'found (plist-get status :id)))) + orgmine-statuses))) + +(defun orgmine-subtree-region () + (save-excursion + (cons (progn + (org-back-to-heading t) + (point)) + (progn + (org-end-of-subtree t t) +;; (if (and (org-at-heading-p) (not (eobp))) (backward-char 1)) + (point))))) + +(defun orgmine-entry-region () + "Returns the region from the beginning of headline to the next headline +as a cons cell (BEG . END)." + (save-excursion + (cons (progn + (org-back-to-heading t) + (point)) + (progn + (outline-next-heading) +;; (if (and (org-at-heading-p) (not (eobp))) (backward-char 1)) + (if (org-at-heading-p) (backward-char 1)) + (point))))) + +(defun orgmine-body-region () + "Returns the region from the beginning of body to the next headline +as a cons cell (BEG . END)." + (org-back-to-heading t) + (show-subtree) + (save-excursion + (forward-line) + (if (not (org-at-heading-p t)) + (cons (point) + (or (outline-next-heading) (point-max)))))) + +(defun orgmine-default-todo-keyword () + "Returns the default TODO keyword for the initial status of Redmine issue. +The default TODO keyword can be specified by \"om_default_todo\" property, +such as \"#+PROPERTY: om_default_todo NEW\". +If the property is not found, the first TODO keyword of `org-todo-keywords-1' +is returned." + (or (cdr (assoc-string "om_default_todo" org-keyword-properties)) + orgmine-default-todo-keyword + (nth 0 org-todo-keywords-1) + 1)) + +(defun orgmine-todo (name) + "Set the TODO state to NAME." + (let ((org-after-todo-state-change-hook + org-after-todo-state-change-hook)) + (remove-hook 'org-after-todo-state-change-hook + 'orgmine-after-todo-state-change) + (org-todo (orgmine-todo-keyword name)))) + +(defun orgmine-collect-update-plist (issue &optional subject-prop) + "collect updating entries and return them as plist" + (or subject-prop (setq subject-prop :subject)) + (org-with-wide-buffer + (goto-char (org-element-property :begin issue)) + ;; XXX: TODO: restrict range to subtree. + (let* ((beg (point)) + (end (cdr (orgmine-subtree-region))) +;; (um-headlines (orgmine-um-headlines beg end)) + (um-headlines (and (org-goto-first-child) + (orgmine-um-headlines (point) end))) + (description (nth 0 um-headlines)) + (journal (nth 1 um-headlines)) + (attachments (nth 2 um-headlines))) + (goto-char beg) + (let* ((title (org-element-property :title issue)) + (todo-keyword (org-element-property :todo-keyword issue)) + (scheduled (org-entry-get nil "SCHEDULED")) + (deadline (org-entry-get nil "DEADLINE")) + (effort (org-entry-get nil org-effort-property)) ; "Effort" + (plist-inherit + (orgmine-get-properties nil '(tracker fixed_version project) t)) + (plist + (orgmine-get-properties + nil '(id start_date due_date done_ratio assigned_to author + category estimated_hours custom_fields relations) nil))) + (setq plist (plist-merge plist plist-inherit)) + (if title + (setq plist ; `subject-prop': :subject or :name + (plist-put plist subject-prop + (orgmine-extract-subject title)))) + (if todo-keyword + (let ((status-id (orgmine-issue-status-id todo-keyword))) + (setq plist (plist-put plist :status_id status-id)))) + (if scheduled + (setq plist + (plist-put plist :start_date + (orgmine-redmine-date scheduled)))) + (if deadline + (setq plist + (plist-put plist :due_date (orgmine-redmine-date deadline)))) + (if effort + (setq plist + (plist-put plist :estimated_hours + (/ (org-duration-to-minutes effort) 60)))) + (if description + (setq plist + (plist-put plist :description (orgmine-note description)))) + (if journal + (setq plist (plist-put plist :notes (orgmine-note journal)))) + (if attachments ; XXX + (setq plist (plist-put plist :attachments attachments))) + plist)))) + +(defun orgmine-plist-list-get (plist-list key value) + "Search for a plist in list of plist. +Return plist whose key is KEY and its value is equal to VALUE." + (catch 'found + (mapc (lambda (plist) + (let ((ret (plist-member plist key))) + (if (and (listp ret) + (equal (nth 1 ret) value)) + (throw 'found plist)))) + plist-list) + nil)) + +(defun orgmine-get-issue (id &optional cache) + "Get a redmine issue." + (if (stringp id) + (setq id (string-to-number id))) + (if cache + (orgmine-plist-list-get cache :id id) + (elmine/get-issue-with-journals id))) + +(defun orgmine-get-version (id &optional cache) + "Get a redmine fixed version." + (if (stringp id) + (setq id (string-to-number id))) + (if cache + (orgmine-plist-list-get cache :id id) + (elmine/get-version id))) + +(defun orgmine-get-tracker (id &optional cache) + "Get a redmine tracker." + (if (stringp id) + (setq id (string-to-number id))) + (if cache + (orgmine-plist-list-get cache :id id) + (let ((trackers (elmine/get-trackers))) + (orgmine-plist-list-get trackers :id id)))) + +(defun orgmine-get-project (id &optional cache) + "Get a redmine project." + (if (stringp id) + (setq id (string-to-number id))) + (if cache + (or (orgmine-plist-list-get cache :identifier id) + (orgmine-plist-list-get cache :id id)) + (elmine/get-project id))) + +;; TODO: make much more readable +(defun orgmine-pp-plist (plist &optional depth) + (or depth (setq depth 0)) + (let ((count 0)) + (save-match-data + (mapconcat + (lambda (elem) + (prog1 + (let* ((id-value-p + (and (listp elem) + (plist-get elem :id) (plist-get elem :value))) + (str (elmine/ensure-string elem)) + (nl (string-match "\n" str))) + (cond (id-value-p + (format " %s: %s\n" + (orgmine-idname elem) (plist-get elem :value))) + ((listp elem) + (format "\n%s" (orgmine-pp-plist elem (1+ depth)))) + ((= (% count 2) 0) (format "%s%s:" + (make-string (* depth 2) ? ) + str)) + (nl (format "\n%s\n" str)) + (t (format " %s\n" str)))) + (setq count (1+ count)))) + plist "")))) + +(defun orgmine-y-or-n-p (prompt plist) + (save-window-excursion + (switch-to-buffer-other-window "*ORGMINE PROPERTIY LIST*") + (read-only-mode -1) + (erase-buffer) + (insert (orgmine-pp-plist plist)) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (read-only-mode) + (message "plist: %s" plist) + (prog1 + ;; XXX: map-y-or-n-p -- see `save-some-buffers' for its usage + (y-or-n-p prompt) + (kill-buffer)))) + +(defun orgmine-pp-note (redmine-note indent) + (save-match-data + (if (string-match "\n\\'" redmine-note) + (setq redmine-note (substring redmine-note 0 + (1- (length redmine-note)))))) + (let ((leading (make-string indent ? ))) + (mapconcat (lambda (line) + (concat leading line)) + (split-string redmine-note "\n") "\n"))) + +(defun orgmine-insert-note (note &optional force) + (when (or force (> (length note) 0)) + (forward-line) + (unless (bolp) (insert "\n")) + (open-line 1) + (insert orgmine-note-block-begin) ; "#+begin_src gfm" + (org-indent-line) + (let ((indent (current-indentation)) + pos) + (insert "\n") + (setq pos (point)) + (org-indent-line) + (insert orgmine-note-block-end) ; "#+end_src" + (goto-char pos) + (cond ((equal note "\n") + (open-line 1)) + ((> (length note) 0) + (insert (orgmine-pp-note note (+ indent 2)) "\n")))))) + +(defun orgmine-find-note-block () + "Return the note block of the current entry as cons of (BEG . END). +If the note block is not found, return nil." + (save-excursion + (let* ((region (orgmine-entry-region)) + (beg (car region)) + (end (cdr region)) + (note-block-begin-regexp + (format "^[ \t]*%s" (regexp-quote orgmine-note-block-begin))) + (note-block-end-regexp + (format "^[ \t]*%s[ \t]*\n?" (regexp-quote orgmine-note-block-end)))) + (goto-char end) + (catch 'found + (while (re-search-backward note-block-begin-regexp beg t) + (let ((pos (point))) + (if (re-search-forward note-block-end-regexp end t) + (throw 'found (cons pos (point)))))))))) + +(defun orgmine-journal-details-drawer-region (beg end) + (save-excursion + (goto-char beg) + (let ((re (format "^[ \t]*:%s:[ \t]*$" orgmine-journal-details-drawer))) + (if (re-search-forward re end t) + (let ((beg (match-beginning 0))) + (when (re-search-forward "^[ \t]*:END:.*" end t) + (cons beg (match-end 0)))))))) + +(defun orgmine-insert-journal-details (journal) + (let* ((details (plist-get journal :details)) + (region (orgmine-entry-region)) + (beg (car region)) + (end (cdr region))) + (when details + (org-back-to-heading t) + (if (fboundp 'org-end-of-meta-data-and-drawers) + (org-end-of-meta-data-and-drawers) + (org-end-of-meta-data t)) + (when orgmine-journal-details-drawer + (let* ((region (orgmine-journal-details-drawer-region beg end))) + (if region + (progn + (delete-region (car region) (cdr region)) + (goto-char (car region))) + (open-line 1))) + (if (looking-at org-outline-regexp) + (open-line 1)) + (org-indent-line) + (insert ":" orgmine-journal-details-drawer ":\n") + (org-indent-line) + (insert ":END:") + (move-beginning-of-line nil)) + (let ((pos (copy-marker (save-excursion + (forward-line) + (point))))) + (mapc (lambda (plist) + (open-line 1) + (org-indent-line) + (let ((old (plist-get plist :old_value)) + (new (plist-get plist :new_value)) + (name (plist-get plist :name)) + (property (plist-get plist :property))) + (insert "- " property "_" name ": " + (cond ((or (equal name "description") + (and (stringp old) (string-match "\n" old)) + (and (stringp new) (string-match "\n" new))) + "CHANGED") + ((and old new) + (format "\"%s\" -> \"%s\"" old new)) + (old (format "\"%s\" -> DELETED" old)) + (new (format "ADDED -> \"%s\"" new))))) + (move-beginning-of-line nil)) + details) + (goto-char pos) + (forward-line -1) + (set-marker pos nil))))) + +(defun orgmine-insert-journal (beg end journal issue-id count &optional force) + (let* ((author (plist-get (plist-get journal :user) :name)) + (journal-id (plist-get journal :id)) + (journal (plist-merge journal + (list :id issue-id :count count + :author author :journal_id journal-id))) + (title (orgmine-format orgmine-journal-title-format journal))) + (goto-char beg) + (if (orgmine-find-headline-prop orgmine-tag-journal + 'count (elmine/ensure-string count) end) + (let ((region (orgmine-find-note-block))) + (if region + (progn + (delete-region (car region) (cdr region)) + (goto-char (car region)) + (if (and (looking-at "^$") (not (eobp))) + (delete-char 1))) + (outline-next-heading)) + (forward-line -1)) + (goto-char beg) + (orgmine-insert-demoted-heading title (list orgmine-tag-journal))) + (orgmine-insert-note (plist-get journal :notes) force) + (orgmine-insert-journal-details journal) +;; (orgmine-set-properties 'journal journal '(id count created_on user)) + (orgmine-set-properties 'journal journal '(count)))) + +(defun orgmine-find-journals (end &optional insert keep-subtree) + "Find journals headline of the child entry of the current headline. +If the journals headline is not found and INSERT is non-nil, +the new entry will be inserted as the child entry of the current headline." + (let ((beg (point))) +;; (outline-next-heading) + (org-goto-first-child) + (if (orgmine-find-headline orgmine-tag-journals end t) + (if keep-subtree + (outline-next-heading) + (let ((journal-end (cdr (orgmine-subtree-region)))) + (forward-line) + (delete-region (point) journal-end))) + (when insert + (goto-char beg) + (outline-next-heading) + (orgmine-insert-demoted-heading "Journals" + (list orgmine-tag-journals)) + (outline-next-heading) + (if (and (markerp end) + (> (point) end)) + (set-marker end (point))))))) + +(defun orgmine-insert-journals (redmine-journals beg end) + "Insert journals subtree between region from BEG to END. +If the journals headline already exits, the tree will be updated. +Otherwise, new tree will be inserted at BEG." + (goto-char beg) +;; (orgmine-find-journals end t nil) + (orgmine-find-journals end t t) + (save-excursion + ;; remove journal headline with :UPDATE_ME: tag. + (outline-previous-heading) + (when (orgmine-find-headline-prop orgmine-tag-journal 'count "0" end) + (let ((region (orgmine-entry-region))) + (delete-region (car region) (cdr region))))) + (let ((pos (point)) + (count 0)) + (mapc (lambda (journal) + (goto-char pos) + (orgmine-insert-journal pos end journal id + (setq count (1+ count)))) + (reverse redmine-journals)))) + +(defun orgmine-insert-description (redmine-description beg end &optional force) + "Insert description headline between region from BEG to END. +If the description headline already exits, the headline will be updated. +Otherwise, new tree will be inserted at BEG." + (goto-char beg) + (outline-next-heading) + (if (orgmine-find-headline orgmine-tag-description end t) + (progn + (org-toggle-tag orgmine-tag-update-me 'off) + (let ((region (orgmine-find-note-block))) + (if region + (progn + (delete-region (car region) (cdr region)) + (goto-char (car region)) + (if (and (looking-at "^$") (not (eobp))) + (delete-char 1))) + (outline-next-heading)) + (forward-line -1))) + ;; insert description headline + (orgmine-insert-demoted-heading "Description" + (list orgmine-tag-description))) + (orgmine-insert-note redmine-description force)) + +(defun orgmine-insert-attachment (plist) + (let ((description (plist-get plist :description))) + (unless (looking-at "^$") (move-beginning-of-line nil) (open-line 1)) + (org-indent-line) + (insert "- " + (orgmine-format orgmine-attachment-format plist)) + (when (and description (> (length description) 0)) + (insert "\n") + (org-indent-line) + (insert description)))) + +(defun orgmine-insert-attachments (redmine-attachments beg end &optional force) + "Insert attachments headline between region from BEG to END. +If the attachments headline already exits, the headline will be updated. +Otherwise, new tree will be inserted at BEG." + (goto-char beg) + (outline-next-heading) + (if (orgmine-find-headline orgmine-tag-attachments end t) + (progn + (org-toggle-tag orgmine-tag-update-me 'off) + (let ((region (orgmine-subtree-region))) + (forward-line) + (delete-region (point) (cdr region)) + (if (and (looking-at "^$") (not (eobp))) + (delete-char 1)))) + ;; insert attachments headline + (orgmine-insert-demoted-heading "Attachments" + (list orgmine-tag-attachments)) + (forward-line)) + (mapc (lambda (redmine-attachment) + (save-excursion + (orgmine-insert-attachment redmine-attachment))) + (reverse redmine-attachments))) + +(defun orgmine-update-special-properties (redmine-issue) + "Update the special properties per REDMINE-ISSUE." + (let* ((status (plist-get redmine-issue :status)) ; version :status STATUS + (status-name (plist-get status :name)) ; issue (:id ID :name NAME) + (start-date (plist-get redmine-issue :start_date)) + (due-date (plist-get redmine-issue :due_date)) + (created-on (plist-get redmine-issue :created_on)) + (closed-on (plist-get redmine-issue :closed_on)) + (estimated-hours (plist-get redmine-issue :estimated_hours))) + (if (equal status "closed") ; for version entry + (orgmine-toggle-tag org-archive-tag 'on) + (orgmine-toggle-tag org-archive-tag 'off)) + (if status-name ; for issue entry + (orgmine-todo status-name)) + (if start-date ; SCHEDULED: prop + (org-add-planning-info 'scheduled start-date) + (org-remove-timestamp-with-keyword org-scheduled-string)) + (if due-date ; DEADLINE: prop + (org-add-planning-info 'deadline due-date) + (org-remove-timestamp-with-keyword org-deadline-string)) +;; (if (and (stringp closed-on) (stringp created-on) +;; (string< created-on closed-on)) ; XXX + (if (member status-name org-done-keywords) + (org-add-planning-info 'closed (orgmine-tz-org-date closed-on)) + (org-add-planning-info nil nil 'closed)) + (if estimated-hours + (org-set-property org-effort-property + (format "%sh" (elmine/ensure-string estimated-hours))) + (org-entry-delete nil org-effort-property)))) + +(defun orgmine-entry-up-to-date-p (entry plist) + "Returns non-nil if ENTRY is up-to-date comparing to Redmine's PLIST." + (let* ((beg (org-element-property :begin entry)) + (redmine-updated-on (plist-get plist :updated_on)) + (updated-on (nth 1 (orgmine-get-property beg 'updated_on)))) + (and (stringp redmine-updated-on) (stringp updated-on) + (not (string< updated-on redmine-updated-on))))) + +(defun orgmine-dirty-p (entry &optional plist) + "Non-nil if the ENTRY (org-element data) is locally edited." + (setq plist (or plist (orgmine-collect-update-plist entry))) + (or (member orgmine-tag-update-me (org-element-property :tags entry)) + (plist-get plist :description) ; XXX: for issue only + (plist-get plist :notes) ; XXX: for issue only + (plist-get plist :attachments))) ; XXX: for issue only + +(defun orgmine-update-title (title) + "Update the title of the current headline." + (unless (org-at-heading-p) (error "not on heading")) + (save-excursion + (let* ((org-special-ctrl-a/e t) + (beg (progn (move-beginning-of-line nil) + (org-beginning-of-line) + (point))) + (end (progn (move-end-of-line nil) + (org-end-of-line) + (point)))) + (if (< beg end) + (delete-region beg end)) + (goto-char beg) + (insert title)))) + +(defun orgmine-update-entry (type entry plist + &optional force property-list extra) + "Update ENTRY (org-element data) of TYPE per PLIST. +If the entry of Redmine is not updated since last sync and FORCE is nil, +the entry is not updated. +TYPE could be 'issue, 'fixed_version, 'tracker, and 'project. +Returns non-nil if the entry is updated." + (let* ((beg (org-element-property :begin entry)) + (idname (orgmine-idname plist)) + ;; `title-format' is value of one of the following variable: + ;; orgmine-issue-title-format, orgmine-version-title-format + ;; orgmine-tracker-title-format, orgmine-project-title-format + (type0 (if (eq type 'fixed_version) 'version type)) + (title-format (eval (intern (format "orgmine-%s-title-format" type0)))) + (title (orgmine-format title-format plist))) + (if (and (not force) + (orgmine-entry-up-to-date-p entry plist)) + (progn + (message "#%s: no change since last sync." idname) + nil) + (if (and (not force) + (orgmine-dirty-p entry)) + (error "#%s is locally edited. Please submit change before updating." + idname)) + (message "Updating entry #%s ..." idname) + (org-with-wide-buffer + (goto-char beg) + (let ((end (make-marker))) + (set-marker end (cdr (orgmine-subtree-region))) + (show-subtree) + (orgmine-update-title title) + (goto-char beg) + (orgmine-toggle-tag orgmine-tag-update-me 'off) + (orgmine-set-properties type plist property-list) + ;; Update SCHEDULED:, DEADLINE:, TODO keyword, and CLOSED: + ;; per redmine properties. + (orgmine-update-special-properties plist) + ;; Update extra properties. + (if (functionp extra) + (funcall extra plist beg end)) + (set-marker end nil) + (hide-subtree))) + (message "Updating entry #%s ... done" idname)))) + +;;;; + +(defun orgmine-submit-entry-update (entry id-prop subject-prop + orgmine-get-entry-func + orgmine-submit-entry-func + &optional force no-prompt) + "Submit the entry update to Redmine." + (org-save-outline-visibility t + (show-branches) + (let* ((plist (orgmine-collect-update-plist entry subject-prop)) + (id (plist-get plist id-prop))) ; XXX + (unless id + (error "No entry ID found at position %d" + (org-element-property :begin entry))) + (setq plist (plist-merge plist (list :id id))) + (if (or force + (orgmine-dirty-p entry plist)) + (let* ((redmine-entry (funcall orgmine-get-entry-func id)) + (up-to-date-p + (orgmine-entry-up-to-date-p entry redmine-entry))) + (if up-to-date-p + (if (or no-prompt + (orgmine-y-or-n-p + (format "Will you update entry #%s?" id) plist)) + (funcall orgmine-submit-entry-func plist)) + (if (not force) + (error "#%s: entry has been updated by other user." id) + (if (yes-or-no-p + (format "#%s: entry has been updated by other user. +Will you force to update entry #%s? %s" id id plist)) + (funcall orgmine-submit-entry-func plist))))) + (message "#%s: no need to submit update." id))))) + +(defun orgmine-submit-issue-relations (plist) + "Create or delete issue relations per PLIST: (:relations relations)." + (let ((relations (plist-get plist :relations)) + (issue-id (plist-get plist :id))) + (if (and relations issue-id) + (mapc (lambda (relation) + (let* ((id (plist-get relation :id)) + (issue-to-id (plist-get relation :issue_to_id))) + (setq relation (plist-merge relation + (list :issue_id issue-id))) + (cond ((and (null id) issue-to-id) + (elmine/create-relation relation)) + ((and id (null issue-to-id)) + (elmine/delete-relation id))))) + relations)))) + + +(defun orgmine-upload-attachent (attachment) + ;; => (:upload (:token "3.8b652b8c79f357694a04bd793f533c96")) + (let ((path (plist-get attachment :path))) + (unless (file-exists-p path) + (error "%s: file not exist" path)) + (elmine/upload-file path))) + +(defun orgmine-upload-attachents (plist) + (let ((attachments (plist-get plist :attachments)) + uploads) + (mapc (lambda (attachment) + (let ((path (plist-get attachment :path))) + (unless path + (error "path is not specified in attachment plist: %s" + attachment)) + (unless (file-exists-p path) + (error "%s: file not exist" path)))) + attachments) + (mapc (lambda (attachment) + (let ((res-plist (orgmine-upload-attachent attachment))) + (if res-plist + (let ((upload (plist-get res-plist :upload)) + (filename (plist-get attachment :filename)) + (description (plist-get attachment :description))) + (setq upload (plist-put upload :filename filename)) + (if description + (setq upload + (plist-put upload :description description))) + (add-to-list 'uploads upload))))) + attachments) + (if uploads + ;; workaround for `json-enconde-list', which wrongly handles + ;; list of plist as alist. + (add-to-list 'uploads nil t)) + uploads)) + +(defun orgmine-submit-issue-update (issue force &optional no-prompt) + "Submit the issue update to Redmine." + (orgmine-submit-entry-update issue :id :subject + 'orgmine-get-issue + (lambda (plist) + (orgmine-submit-issue-relations plist) + (let ((uploads + (orgmine-upload-attachents plist))) + (if uploads + (setq plist + (plist-merge plist + (list + :uploads uploads + :attachments nil))))) + (elmine/update-issue plist) + (orgmine-fetch-issue t)) + force no-prompt)) + +(defun orgmine-submit-version-update (version force &optional no-prompt) + "Submit the version update to Redmine." + (orgmine-submit-entry-update version :fixed_version_id :name + 'orgmine-get-version + (lambda (plist) + (elmine/update-version plist) + (orgmine-fetch-version t)) + force no-prompt)) + +;;;; + +(defun orgmine-project (&optional parent) + (let ((projects (elmine/get-projects))) + (mapcar (lambda (project) + (orgmine-idname project)) + projects))) + +(defvar orgmine-project-hist nil) + +(defun orgmine-read-project (&optional prompt) + (or prompt (setq prompt "Project# ")) + (let* ((project (nth 1 (orgmine-get-property nil 'project nil t))) + (collection (orgmine-project project))) + (if project + (setq prompt (format "%s(default %s): " prompt project))) + (completing-read prompt collection nil t nil + 'orgmine-project-hist project))) + +(defvar orgmine-project-versions nil) + +(defun orgmine-project-versions (project) + (let ((versions (elmine/get-project-versions project))) + (mapcar (lambda (version) + (orgmine-idname version)) + versions))) + +(defun orgmine-current-issue () + "Return the number that point is on as a string. +If no number is on the position and the position is under the issue entry, +return the issue number of the current entry." + (or (save-match-data + ;; XXX + (let ((word (current-word))) + (if (and word (string-match "\\([0-9]+\\)" word)) + (match-string 1 word)))) + (let* ((issue (orgmine-find-headline-ancestor orgmine-tag-issue t)) + (beg (org-element-property :begin issue)) + (id (orgmine-get-id beg))) + id))) + +;; XXX +(defun orgmine-current-version () + (save-match-data + (let ((word (current-word))) + (if (and word (string-match "\\([0-9]+\\)" word)) + (match-string 1 word))))) + +(defvar orgmine-issue-hist nil) + +(defun orgmine-read-issue (&optional prompt) + (or prompt (setq prompt "Issue# ")) + (let* ((default (orgmine-current-issue))) + (if default + (setq prompt (format "%s(default %s): " prompt default))) + (completing-read prompt nil nil nil nil + 'orgmine-version-hist default))) + +(defvar orgmine-version-hist nil) + +(defun orgmine-read-version (&optional prompt collection-from-server) + (or prompt (setq prompt "Version# ")) + (let* ((default (orgmine-current-version))) + (if default + (setq prompt (format "%s(default %s): " prompt default))) + (let* ((project (nth 1 (orgmine-get-property nil 'project nil t))) + (collection (if collection-from-server + (orgmine-project-versions project)))) + (completing-read prompt collection nil nil nil + 'orgmine-version-hist default)))) + +(defvar orgmine-project-trackers nil) + +(defun orgmine-project-trackers (project) + (let ((trackers (elmine/get-project-trackers project))) + (mapcar (lambda (tracker) + (orgmine-idname tracker)) + trackers))) + +(defvar orgmine-tracker-hist nil) + +(defun orgmine-read-tracker (&optional prompt) + (or prompt (setq prompt "Tracker# ")) + (let* ((project (nth 1 (orgmine-get-property nil 'project nil t))) + (collection (orgmine-project-trackers project))) + (completing-read prompt collection nil t nil + 'orgmine-tracker-hist))) + +(defun orgmine-properties () + "Return a list of editable property names for the current entry." + (let ((tags (save-excursion + (org-back-to-heading) + (org-get-tags)))) + (cond ((member orgmine-tag-project tags) + (list "om_parent")) + ((member orgmine-tag-tracker tags) + (list "om_fixed_version")) + ((member orgmine-tag-version tags) + (list "om_status")) + (t ;; issue entry + (let ((names + (list "om_tracker" "om_parent" "om_done_ratio" + "om_assigned_to" "om_author" "om_category" + "om_fixed_version" + "om_relation_relates" + "om_relation_duplicates" "om_relation_duplicated" + "om_relation_blocks" "om_relation_blocked" + "om_relation_precedes" "om_relation_follows" + "om_relation_copied_to" "om_relation_copied_from"))) + (if (boundp 'orgmine-custom-fields) + (nconc names (mapcar 'car orgmine-custom-fields)) + names)))))) + +(defvar orgmine-property-name-hist nil) + +;; TODO: change keys per entry: issue, tracker, project, version +(defun orgmine-read-property-name () + "Read a property name." + (let* ((completion-ignore-case t) + (keys (orgmine-properties)) + (default-prop (or (car orgmine-property-name-hist) + "om_assigned_to")) + (property (completing-read + (concat "Property" + (if default-prop (concat " [" default-prop "]") "") + ": ") + (mapcar 'list keys) + nil nil nil 'orgmine-property-name-hist + default-prop))) + (if (member property keys) + property + (or (cdr (assoc-string property keys t)) + property)))) + +;;;; + +(defun orgmine-update-issue (issue redmine-issue &optional force) + "Update the entry of ISSUE (org-element data) per REDMINE-ISSUE. +If the issue of Redmine is not updated since last sync and FORCE is nil, +the entry is not updated." + (orgmine-update-entry + 'issue issue redmine-issue force + '(id tracker created_on updated_on closed_on + parent status fixed_version ;; author + start_date due_date done_ratio + estimated_hours assigned_to author category + project custom_fields relations) + (lambda (plist beg end) + (let ((description (plist-get plist :description)) + (journals (plist-get plist :journals)) + (attachments (plist-get plist :attachments))) + ;; update journals + (if journals (orgmine-insert-journals journals beg end)) + ;; update attachments + (if attachments (orgmine-insert-attachments attachments beg end)) + ;; update entry description + (if description (orgmine-insert-description description beg end)))))) + +(defun orgmine-update-version (version redmine-version &optional force) + "Update the entry of VERSION (org-element data) per REDMINE-VERSION. +If the version of Redmine is not updated since last sync and FORCE is nil, +the entry is not updated." + (orgmine-update-entry + 'fixed_version version redmine-version force + '(fixed_version created_on updated_on closed_on status due_date project))) + +(defun orgmine-update-tracker (tracker redmine-tracker &optional force) + "Update the entry of TRACKER (org-element data) per REDMINE-TRACKER. +If the version of Redmine is not updated since last sync and FORCE is nil, +the entry is not updated." + (orgmine-update-entry + 'tracker tracker redmine-tracker force '(trackers))) + +(defun orgmine-update-project (project redmine-project &optional force) + "Update the entry of PROJECT (org-element data) per REDMINE-PROJECT. +If the version of Redmine is not updated since last sync and FORCE is nil, +the entry is not updated." + (orgmine-update-entry + 'project project redmine-project force + '(project created_on updated_on status parent identifier) + (lambda (plist beg end) + (let ((description (plist-get plist :description))) + ;; update entry description + (if description (orgmine-insert-description description beg end)))))) + +(defun orgmine-copy-buffer-local-variables (buf-from buf-to) + "Copy buffer local variables in BUF-FROM to BUF-TO. +The variables to be copies are whose names start with +\"orgmine-\", \"org-\", or \"elmine/\"." + (with-current-buffer buf-to + (mapc (lambda (var) + (let ((symbol (car var)) + (value (cdr var))) + (if (string-match "^\\(orgmine-\\|org-\\|elmine/\\)" + (symbol-name symbol)) + (set (make-local-variable symbol) value)))) + (buffer-local-variables buf-from)))) + +(defvar orgmine-id-list-alist nil) + +(defun orgmine-id-list-cache (afile tag) + (let* ((key (format "%s:%s" afile tag)) + (value (cdr (assoc key orgmine-id-list-alist)))) + value)) + +(defun orgmine-id-list-cache-set (afile tag id-list) + (let* ((key (format "%s:%s" afile tag)) + (list (assoc key orgmine-id-list-alist)) + (modification-time (nth 5 (file-attributes afile))) + (new-value (cons modification-time id-list))) + (if list + (setcdr list new-value) + (add-to-list 'orgmine-id-list-alist (cons key new-value))))) + +(defun orgmine-get-id-list (tag id-prop) + (org-with-wide-buffer + (goto-char (point-min)) + (let (id-list) + (message "scanning %s IDs..." tag) + (while (orgmine-find-headline tag) + (let ((id (orgmine-get-id nil id-prop))) + (if id (add-to-list 'id-list (string-to-number id)))) + (outline-next-heading)) + (message "scanning %s IDs... done" tag) + id-list))) + +(defun orgmine-archived-ids (tag id-prop) + (let ((afile (car (org-archive--compute-location + (or (org-entry-get nil "ARCHIVE" 'inherit) org-archive-location))))) + ;; (let ((afile (org-extract-archive-file))) + (if (file-exists-p afile) + (let* ((curbuf (current-buffer)) + (visiting (find-buffer-visiting afile)) + (buffer + (or visiting + (prog2 + (message "opening archive file %s..." afile) + (find-file-noselect afile) + (message "opening archive file %s... done" afile))))) + (unless buffer + (error "Cannot access file \"%s\"" afile)) + (unless (eq buffer curbuf) + (with-current-buffer buffer + (let ((id-list-cache (orgmine-id-list-cache afile tag))) + (if (and (not (buffer-modified-p)) + (equal (nth 5 (file-attributes afile)) + (car id-list-cache))) + ;; use the cached id list if the archive file is + ;; not updated since the last scan and the buffer + ;; is not modified. + (cdr id-list-cache) + ;; Otherwise, scan the buffer for IDs and push the + ;; ID list to the cache. + (unless (eq major-mode 'org-mode) (org-mode)) + (orgmine-mode) + (orgmine-copy-buffer-local-variables curbuf buffer) + (let ((id-list (orgmine-get-id-list tag id-prop))) + (orgmine-id-list-cache-set afile tag id-list) + id-list))))))))) + +(defun orgmine-buffer-list () + "Returns the list of orgmine buffers" + (let (buffers) + (mapc (lambda (buf) + (with-current-buffer buf + (if orgmine-mode + (add-to-list 'buffers buf)))) + (org-buffer-list 'files t)) + buffers)) + +(defun orgmine-archived-issues () + (orgmine-archived-ids orgmine-tag-issue 'id)) + +(defun orgmine-archived-versions () + (orgmine-archived-ids orgmine-tag-version 'fixed_version)) + +(defun orgmine-toggle-tag (tag onoff) + (cond ((eq onoff 'on) + (or (member tag (org-get-tags)) + (org-toggle-tag tag 'on))) + ((eq onoff 'off) + (and (member tag (org-get-tags)) + (org-toggle-tag tag 'off))) + (t (org-toggle-tag tag onoff)))) + + +;;; Interactive Functions + +(defun orgmine-fetch-issue (force) + "Fetch redmine issue in the current position." + (interactive "P") + (let* ((issue (orgmine-find-headline-ancestor orgmine-tag-issue)) + (beg (org-element-property :begin issue)) + (id (orgmine-get-id beg))) + (unless id (error "Redmine issue headline without ID (om_id prop)")) + (let ((redmine-issue (elmine/get-issue-with-journals id))) + (unless redmine-issue + (error "issue #%s not found" id)) + (orgmine-update-issue issue redmine-issue force)) + (goto-char beg))) + +(defun orgmine-fetch-version (force) + "Fetch redmine version in the current position." + (interactive "P") + (let* ((version (orgmine-find-headline-ancestor orgmine-tag-version)) + (beg (org-element-property :begin version)) +;; (id (orgmine-get-id 'version beg))) + (plist (orgmine-get-properties beg '(fixed_version))) + (version-id (plist-get plist :fixed_version_id))) + (unless version-id + (error "Redmine version headline without ID (om_version).")) + (let ((redmine-version (elmine/get-version version-id))) + (unless redmine-version + (error "version #%s not found" version-id)) + (orgmine-update-version version redmine-version force)) + (goto-char beg))) + +(defun orgmine-fetch-tracker (force) + "Fetch redmine tracker in the current position." + (interactive "P") + (let* ((tracker (orgmine-find-headline-ancestor orgmine-tag-tracker)) + (beg (org-element-property :begin tracker)) + (plist (orgmine-get-properties beg '(tracker))) + (tracker-id (plist-get plist :tracker_id))) + (unless tracker-id + (error "Redmine tracker headline without ID (om_tracker).")) + (let* ((redmine-trackers (elmine/get-trackers)) + (redmine-tracker + (orgmine-plist-list-get redmine-trackers + :id (string-to-number tracker-id)))) + (unless redmine-tracker + (error "tracker #%s not found" tracker-id)) + ;; tracker does not have :updated_on prop. Update the headline + ;; only when FORCE is non-nil + (if force + (orgmine-update-tracker tracker redmine-tracker force))) + (goto-char beg))) + +(defun orgmine-fetch-project (force) + "Fetch redmine project in the current position." + (interactive "P") + (let* ((project (orgmine-find-headline-ancestor orgmine-tag-project)) + (beg (org-element-property :begin project)) + (plist (orgmine-get-properties beg '(project))) + (project-id (plist-get plist :project_id))) + (unless project-id + (error "Redmine project headline without ID (om_project).")) + (let ((redmine-project (elmine/get-project project-id))) + (unless redmine-project + (error "project #%s not found" project-id)) + (orgmine-update-project project redmine-project force)) + (goto-char beg))) + +(defun orgmine-fetch-versions (force) + (interactive "P") + (let* ((subtree (orgmine-subtree-region)) + (beg (car subtree))) + (outline-next-heading) + (orgmine-insert-all-versions force) + (goto-char beg) + (orgmine-sync-subtree-recursively (list orgmine-tag-version)) + (goto-char beg))) + +(defun orgmine-fetch (force) + "Fetch redmine issue, version, tracker, or project in the current position." + (interactive "P") + (let ((pos (point))) + (save-excursion + (unless (outline-on-heading-p t) + (outline-previous-heading)) + (setq pos + (let ((tags (org-get-tags))) + (cond ((member orgmine-tag-version tags) + (orgmine-fetch-version force)) + ((member orgmine-tag-versions tags) + (orgmine-fetch-versions force)) + ((member orgmine-tag-tracker tags) + (orgmine-fetch-tracker force)) + ((member orgmine-tag-project tags) + (prog1 + (orgmine-fetch-project force) + (orgmine-fetch-versions force))) + (t + (orgmine-fetch-issue force))) + (point)))) + (goto-char pos))) + +(defun orgmine-insert-issue (id &optional arg cache demote) + "Insert redmine issue in the current position." + (interactive (list (read-string "Issue# to insert: ") current-prefix-arg)) + (if (numberp id) (setq id (number-to-string id))) +;; (let ((redmine-issue (elmine/get-issue-with-journals id))) + (let ((redmine-issue (orgmine-get-issue id cache))) + ;; TODO: catch error from `elmine/get-issue`. + (unless redmine-issue + (error "Issue #%s not exist on Redmine or some error occurred." id)) + (if demote + (orgmine-insert-demoted-heading) + (org-insert-heading arg)) + (org-toggle-tag orgmine-tag-issue 'on) + (org-set-property "om_id" id) + (let ((issue (org-element-at-point))) + (orgmine-update-issue issue redmine-issue)))) + +(defun orgmine-add-issue (arg) + "Add redmine issue entry at the current position. +NB: the issue is not submitted to the server." + (interactive "P") + (org-insert-heading arg) + (orgmine-todo (orgmine-default-todo-keyword)) + (let ((pos (point))) + (org-toggle-tag orgmine-tag-issue 'on) + (org-toggle-tag orgmine-tag-create-me 'on) + (insert " ") + (goto-char pos) + (org-set-property "om_start_date" + (format-time-string (org-time-stamp-format nil t) + (current-time))))) + +(defun orgmine-find-new-journal (end) + (org-goto-first-child) + (catch 'found + (while (orgmine-find-headline orgmine-tag-update-me end t) + (if (member orgmine-tag-journal (org-get-tags)) + (throw 'found (point))) + (outline-next-heading)) + nil)) + +(defun orgmine-add-journal (arg) + "Add redmine journal entry for the issue at the current position. +NB: the journal is not submitted to the server." + (interactive "P") + (let* ((issue (orgmine-find-headline-ancestor orgmine-tag-issue)) + (beg (org-element-property :begin issue)) + (end (copy-marker (save-excursion + (goto-char beg) + (cdr (orgmine-subtree-region))))) + (id (orgmine-get-id beg)) + (journal (list :id nil :created_on nil :user nil :notes "\n"))) + (goto-char beg) + (show-branches) + (if arg + (orgmine-find-journals end nil t) + (orgmine-find-journals end t t) + (setq beg (point)) + (if (orgmine-find-new-journal end) + (progn + (if (re-search-forward org-block-regexp end t) + (org-previous-block 1) + (if (fboundp 'org-end-of-meta-data-and-drawers) + (org-end-of-meta-data-and-drawers) + (org-end-of-meta-data t)) + (forward-line -1) + (orgmine-insert-note "\n" t)) + (message "new journal entry already exist.")) + (goto-char beg) + (let ((orgmine-journal-title-format "New Journal")) + (orgmine-insert-journal (point) end journal id 0 t)) + (org-toggle-tag orgmine-tag-update-me 'on) + (outline-next-heading) + (forward-line -2) + (move-end-of-line nil)) + (set-marker end nil)))) + +(defun orgmine-find-description (end) + (org-goto-first-child) + (if (orgmine-find-headline orgmine-tag-description end t) + (point))) + +(defun orgmine-add-description (arg) + "Add redmine description entry for the issue at the current position. +NB: the description is not submitted to the server." + (interactive "P") + (let* ((pos (point)) + (region (and (orgmine-current-issue-heading) + (orgmine-subtree-region))) + (beg (car region)) + (end (copy-marker (cdr region)))) + (show-branches) + (if arg + (unless (orgmine-find-description end) + (goto-char pos) + (message "no description entry found.")) + (if (orgmine-find-description end) + (progn + (if (not (member orgmine-tag-update-me (org-get-tags))) + (org-toggle-tag orgmine-tag-update-me 'on)) + (if (re-search-forward org-block-regexp + (cdr (orgmine-subtree-region)) t) + (org-previous-block 1) + (if (fboundp 'org-end-of-meta-data-and-drawers) + (org-end-of-meta-data-and-drawers) + (org-end-of-meta-data t)) + (if (bolp) + (forward-line -1) + (move-beginning-of-line nil)) + (orgmine-insert-note "" t)) + (message "description entry already exist.")) + (orgmine-insert-description "" beg end t) + (unless (member orgmine-tag-update-me (org-get-tags)) + (org-toggle-tag orgmine-tag-update-me 'on)))) + (set-marker end nil))) + +(defun orgmine-find-attachments (end) + (org-goto-first-child) + (if (orgmine-find-headline orgmine-tag-attachments end t) + (point))) + +(defun orgmine-add-attachment (arg) + "Add redmine attachments entry for the issue at the current position. +NB: the attachments is not submitted to the server." + (interactive "P") + (let* ((pos (point)) + (region (and (orgmine-current-issue-heading) + (orgmine-subtree-region))) + (beg (car region)) + (end (copy-marker (cdr region)))) + (show-branches) + (if arg + (unless (orgmine-find-attachments end) + (goto-char pos) + (message "no attachments entry found.")) + (if (orgmine-find-attachments end) + (message "attachments entry already exist.") + (orgmine-insert-attachments nil beg end t) + (forward-line -1)) + (show-entry) + (org-toggle-tag orgmine-tag-update-me 'on) + (outline-next-heading) + (open-line 1) + (insert "x") ;; dummy char to indent properly + (org-indent-line) + (delete-backward-char 1) + (insert "- ") + (message "Please insert a \"file:\" link here to be attached.")) + (set-marker end nil))) + +(defun orgmine-insert-version (fixed-version &optional arg cache) + "Insert Redmine version entry in the current position." + (interactive (list (orgmine-read-version "Version# to insert: " t) + current-prefix-arg)) + (if (numberp fixed-version) + (setq fixed-version (number-to-string fixed-version))) + (let ((redmine-version (orgmine-get-version fixed-version cache))) + (unless redmine-version + (error "Version #%s does not exist on Redmine or some error occurred." + fixed-version)) +;; (org-insert-heading arg) +;; (org-toggle-tag orgmine-tag-version 'on) + (show-branches) + (move-beginning-of-line nil) + (orgmine-insert-demoted-heading "" (list orgmine-tag-version)) + (org-set-property "om_fixed_version" fixed-version) + (let ((version (org-element-at-point))) + (orgmine-update-version version redmine-version)))) + +(defun orgmine-insert-all-versions (force) + "Insert all of the Redmine version entries in the current position. +The following version entries are not inserted: + - a version entry already exists in the buffer, or + - a version entry that was archived to the archive file." + (interactive "P") + (let* ((project (nth 1 (orgmine-get-property nil 'project nil t))) + (redmine-versions (elmine/get-project-versions project)) + (archived-versions (orgmine-archived-versions)) + (count 0)) + (mapc (lambda (redmine-version) + (let ((fixed-version (plist-get redmine-version :id))) + (if (or force + (and (not (member fixed-version archived-versions)) + (not (save-excursion + (goto-char (point-min)) + (orgmine-find-version fixed-version + (point-max)))))) + (progn + (orgmine-insert-version fixed-version redmine-versions) + (setq count (1+ count)))))) + redmine-versions) + (if (> count 0) + (message "%d versions inserted" count) + (message "no version inserted")))) + +(defun orgmine-insert-tracker (tracker &optional arg cache) + "Insert Redmine tracker entry in the current position." + (interactive (list (orgmine-read-tracker) current-prefix-arg)) + (if (numberp tracker) + (setq tracker (number-to-string tracker))) + (let ((redmine-tracker (orgmine-get-tracker tracker cache))) + (unless redmine-tracker + (error "Tracker #%s does not exist on Redmine or some error occurred." + tracker)) + (org-insert-heading arg) + (org-toggle-tag orgmine-tag-tracker 'on) + (org-set-property "om_tracker" tracker) + (let ((tracker (org-element-at-point))) + (orgmine-update-tracker tracker redmine-tracker)))) + +(defun orgmine-insert-project (project &optional arg cache) + "Insert Redmine project entry in the current position." + (interactive (list (orgmine-read-project) current-prefix-arg)) + (let ((redmine-project (orgmine-get-project project cache))) + (unless redmine-project + (error "Project #%s does not exist on Redmine or some error occurred." + project)) +;; (org-insert-heading arg) + (outline-insert-heading) + (org-toggle-tag orgmine-tag-project 'on) + (org-set-property "om_project" project) + (let ((project (org-element-at-point))) + (orgmine-update-project project redmine-project)))) + +(defun orgmine-add-version (arg) + "Add new redmine version entry at the current position. +NB: the version is not submitted to the server." + (interactive "P") + (org-insert-heading arg) + (let ((pos (point))) + (org-toggle-tag orgmine-tag-version 'on) + (org-toggle-tag orgmine-tag-create-me 'on) + (insert " "))) + +(defun orgmine-add-project (name project-id parent &optional arg) + "Add new redmine project entry at the current position. +NB: the project is not submitted to the server." + (interactive (list (read-string "Project name to create: ") + (read-string "Project identifier to create: ") + (read-string "Parent project: ") + current-prefix-arg)) + (org-insert-heading arg) + (let ((pos (point))) + (org-toggle-tag orgmine-tag-project 'on) + (org-toggle-tag orgmine-tag-create-me 'on) + (let ((plist (list :project_id project-id))) + (if (and parent (> (length parent) 0)) + (setq plist (plist-put plist :parent parent))) + (orgmine-set-properties 'project plist '(project_id parent))) + (insert " " (or name "")) + (goto-char (point)))) + +(defun orgmine-set-entry-property (property value &optional arg) + "In the current entry of issue, project, tracker, or version, +set PROPERTY to VALUE." + (interactive (list (progn + (orgmine-current-entry-heading) + (orgmine-read-property-name)) + nil current-prefix-arg)) + (orgmine-current-entry-heading) + (if arg +;; (org-delete-property property) + (org-entry-delete nil property) + (org-set-property property value)) + (unless (member orgmine-tag-create-me (org-get-tags)) + (org-toggle-tag orgmine-tag-update-me 'on))) + +(defun orgmine-set-assigned-to (value &optional arg) + "In the current issue, set :assigned_to property to VALUE." + (interactive (list nil current-prefix-arg)) + (orgmine-set-entry-property (orgmine-property-name 'assigned_to) value arg)) + +;; XXX: "Author" would be a read only attribute. +;; (defun orgmine-set-author (value &optional arg) +;; "In the current issue, set :author property to VALUE." +;; (interactive (list nil current-prefix-arg)) +;; (orgmine-set-entry-property (orgmine-property-name 'author) value arg)) + +(defun orgmine-set-category (value &optional arg) + "In the current issue, set :category property to VALUE." + (interactive (list nil current-prefix-arg)) + (orgmine-set-entry-property (orgmine-property-name 'category) value arg)) + +(defun orgmine-set-done-ratio (value &optional arg) + "In the current issue, set :done_ratio property to VALUE." + (interactive (list nil current-prefix-arg)) + (orgmine-set-entry-property (orgmine-property-name 'done_ratio) value arg)) + +(defun orgmine-set-tracker (value &optional arg) + "In the current issue, set :tracker property to VALUE." + (interactive (list nil current-prefix-arg)) + (orgmine-set-entry-property (orgmine-property-name 'tracker) value arg)) + +(defun orgmine-set-version (value &optional arg) + "In the current issue, set :fixed_version property to VALUE." + (interactive (list nil current-prefix-arg)) + (orgmine-set-entry-property (orgmine-property-name 'fixed_version) value arg)) + +;; TODO +(defun orgmine-set-custom-field (value &optional arg) + "In the current issue, set :om_cf_* property to VALUE." + (interactive (list nil current-prefix-arg)) + (orgmine-set-entry-property nil value arg)) + +(defun orgmine-create-issue (issue) + "Submit new issue entry to Redmine." + (save-excursion + (unless (member orgmine-tag-create-me (org-get-tags)) + (error "No redmine issue headline to create found")) + (let* ((plist (orgmine-collect-update-plist issue :subject)) + (subject (plist-get plist :subject)) + (id (plist-get plist :id))) + (if (or (null subject) (equal subject "")) + (error "Subject is not specified.")) + (if id + (error "Issue ID (%s) is specified for new issue." id)) +;; (if (y-or-n-p (format "Will you submit new issue? %s" plist)) + (if (orgmine-y-or-n-p (format "Will you submit new issue %s ?" subject) + plist) + (let* ((uploads + (orgmine-upload-attachents plist))) + (if uploads + (setq plist + (plist-merge plist :uploads uploads :attachments nil))) + (let* ((res-plist (elmine/create-issue plist)) + (redmine-issue (plist-get res-plist :issue)) + (id (plist-get redmine-issue :id))) + (if id + (progn + (orgmine-set-properties 'issue redmine-issue '(id)) + (org-toggle-tag orgmine-tag-create-me 'off) + (orgmine-fetch-issue t)) + (error "No issue created: %s" res-plist)))))))) + +(defun orgmine-create-version (version) + "Submit new version entry to Redmine." + (save-excursion + (unless (member orgmine-tag-create-me (org-get-tags)) + (error "No redmine version headline to create found")) + (let* ((plist (orgmine-collect-update-plist version :name)) + (subject (plist-get plist :name)) + (id (plist-get plist :fixed_version_id))) +;; (plist-put plist :name subject) + (if (or (null subject) (equal subject "")) + (error "Version name is not specified.")) + (if id + (error "Version ID (%s) is specified for new version." id)) + (if (orgmine-y-or-n-p (format "Will you submit new version %s ?" subject) + plist) + (let* ((res-plist (elmine/create-version plist)) + (redmine-version (plist-get res-plist :version)) + (id (plist-get redmine-version :id)) + (errors (plist-get res-plist :errors))) + (if id + (progn + (orgmine-set-properties 'fixed_version + redmine-version '(fixed_version)) + (org-toggle-tag orgmine-tag-create-me 'off) + (orgmine-fetch-version nil)) + (error (format "No version created: %s" + (mapconcat 'identity errors " / "))))))))) + +(defun orgmine-submit-issue (force) + "Submit new issue entry or submit issue update to Redmine." + (interactive "P") + (let ((issue (orgmine-find-headline-ancestor orgmine-tag-issue))) + (goto-char (org-element-property :begin issue)) + (save-excursion +;; (goto-char (org-element-property :begin issue)) + (if (member orgmine-tag-create-me (org-get-tags)) + (orgmine-create-issue issue) + (orgmine-submit-issue-update issue force))))) + +(defun orgmine-submit-version (force) + "Submit new version entry or submit version update to Redmine." + (interactive "P") + (let ((version (orgmine-find-headline-ancestor orgmine-tag-version))) + (goto-char (org-element-property :begin version)) + (save-excursion +;; (goto-char (org-element-property :begin version)) + (if (member orgmine-tag-create-me (org-get-tags)) + (orgmine-create-version version) + (orgmine-submit-version-update version force))))) + +(defun orgmine-submit (force) + "Submit new entry or update to Redmine. +The entry could be issue or version in the current position. +Submitting update of project and tracker is not supported." + (interactive "P") + (let ((pos (point))) + (save-excursion + (unless (outline-on-heading-p t) + (outline-previous-heading)) + (setq pos + (let ((tags (org-get-tags))) + (cond ((member orgmine-tag-version tags) + (orgmine-submit-version force)) +;; ((member orgmine-tag-tracker tags) +;; (orgmine-submit-tracker force)) +;; ((member orgmine-tag-project tags) +;; (orgmine-submit-project force)) + ((member orgmine-tag-tracker tags)) + ((member orgmine-tag-project tags)) + ((member orgmine-tag-versions tags)) + (t + (orgmine-submit-issue force))) + (point)))) + (goto-char pos))) + +(defun orgmine-submit-issue-region (beg end &optional force) + "Submit new issue entries or submit issue updates to Redmine +found in the region from BEG to END." + (interactive "r\nP") + (let ((pos (point))) + (goto-char beg) + (while (orgmine-find-headline orgmine-tag-issue end) + (orgmine-submit-issue force) + (outline-next-heading)) + (goto-char pos))) + +;;; + +(defvar orgmine-ignore-ids) + +(defun orgmine-find-issue (redmine-id end) + (if (numberp redmine-id) + (setq redmine-id (number-to-string redmine-id))) + (orgmine-find-headline-prop orgmine-tag-issue 'id redmine-id end)) + +(defun orgmine-goto-issue (id arg) + "Goto issue entry of ID." +;; (interactive (list (read-string "Issue# ") current-prefix-arg)) + (interactive (list (orgmine-read-issue "Issue# ") current-prefix-arg)) + (when arg + (orgmine-show-issues nil) + (org-remove-occur-highlights)) + (let ((pos (point))) + (goto-char (point-min)) + (if (orgmine-find-issue id (point-max)) + (set-mark pos) + (goto-char pos) + (error "Issue#%s not found" id)))) + +(defun orgmine-goto-parent-issue (arg) + "Goto parent issue entry of ID." + (interactive "P") + (let* ((issue (orgmine-find-headline-ancestor orgmine-tag-issue)) + (beg (org-element-property :begin issue)) + (id (orgmine-get-id beg)) + (parent (nth 1 (orgmine-get-property beg 'parent)))) + (unless parent (error "No parent issue for issue #%s" id)) + (orgmine-goto-issue parent arg))) + +(defun orgmine-find-version (redmine-id end) + (if (numberp redmine-id) + (setq redmine-id (number-to-string redmine-id))) + (orgmine-find-headline-prop orgmine-tag-version 'fixed_version + redmine-id end)) + +(defun orgmine-goto-version (id arg) + (interactive (list (orgmine-read-version "Version# " nil) current-prefix-arg)) +;; (interactive (list (read-string "Version# ") current-prefix-arg)) + (when arg + (orgmine-show-versions nil) + (org-remove-occur-highlights)) + (let ((pos (point))) + (goto-char (point-min)) + (if (orgmine-find-version id (point-max)) + (set-mark pos) + (goto-char pos) + (error "Version#%s not found" id)))) + +;;;; + +(defun orgmine-refile-me (&optional args) + "Tag \"REFILE_ME\" on issue entries that need to be refiled." + (interactive "P") + (save-excursion + (goto-char (point-min)) + ;; compare issue's properties and parent properties + (let ((property-list '(tracker fixed_version project))) + (while (orgmine-find-headline orgmine-tag-issue) + (if (> (funcall outline-level) 1) + (let* ((my-plist (orgmine-get-properties nil property-list)) + (parent (save-excursion + (outline-up-heading 1 t) + (point))) + (parent-plist (orgmine-get-properties parent + property-list))) + (mapc (lambda (property) + (let* ((id-property-p (orgmine-id-property-p property)) + (prop (intern (format (if id-property-p + ":%s_id" ":%s") + property))) + (mine (plist-get my-plist prop)) + (parent (plist-get parent-plist prop))) + (if (and mine parent + (not (equal mine parent))) + (orgmine-toggle-tag orgmine-tag-refile-me 'on) + (orgmine-toggle-tag orgmine-tag-refile-me 'off)))) + property-list))) + (outline-next-heading)))) + (orgmine-show-refile)) + +(defun orgmine-refile (&optional goto default-buffer) + "Move the current issue entry to another heading." + (interactive "P") + (let* ((issue (orgmine-find-headline-ancestor orgmine-tag-issue t)) + (beg (org-element-property :begin issue))) + (if (and (not issue) (not goto)) + (error "Not in an issue entry to refile.")) + (goto-char (or beg (point))) + (let ((org-refile-targets `((nil :maxlevel . 1) + (nil :tag . ,orgmine-tag-project) + (nil :tag . ,orgmine-tag-version) + (nil :tag . ,orgmine-tag-tracker)))) + (org-refile goto default-buffer) + (save-excursion + (org-refile-goto-last-stored) + (mapc (lambda (property) + (org-entry-delete nil property)) + '("om_project" "om_fixed_version" "om_tracker")) + (org-toggle-tag orgmine-tag-update-me 'on) + (org-toggle-tag orgmine-tag-refile-me 'off))))) + +;;;; + +(defun orgmine-match-sparse-tree (todo-only match what) + "Creating a sparse tree according to tags string MATCH with message." + (interactive "P") + (message "highlighting %s..." what) + (org-match-sparse-tree todo-only match) + (message "highlighting %s... done" what)) + +(defun orgmine-show-issues (todo-only) + "Show entries of Redmine issue." + (interactive "P") + (orgmine-match-sparse-tree todo-only orgmine-tag-issue "issues")) + +(defun orgmine-show-child-issues (todo-only) + "Show current entry and entries of Redmine child issues of the current issue." + (interactive "P") + (let* ((issue (orgmine-find-headline-ancestor orgmine-tag-issue)) + (beg (org-element-property :begin issue)) + (id (orgmine-get-id beg))) + (unless id (error "Redmine issue headline without ID (om_id prop)")) + (org-with-wide-buffer + (goto-char (point-min)) + (unless (orgmine-find-headline-prop orgmine-tag-issue 'parent id) + (error "No child issue found for issue #%s" id))) + (let ((match (format "%s+om_parent=%s|om_id=%s" orgmine-tag-issue id id)) + (what (format "#%s and its child issues..." id))) + (orgmine-match-sparse-tree todo-only match what) +;; (goto-char beg) +;; (org-reveal) + ))) + +(defun orgmine-show-versions (arg) + "Show Version entries." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-version "versions")) + +(defun orgmine-show-trackers (arg) + "Show Tracker entries." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-tracker "trackers")) + +(defun orgmine-show-projects (arg) + "Show Project entries." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-project "projects")) + +(defun orgmine-show-all (arg) + "Show Issues, Versions, Trackers, and Projects entries." + (interactive "P") + (let ((match (concat orgmine-tag-issue "|" orgmine-tag-version "|" + orgmine-tag-tracker "|" orgmine-tag-project))) + (orgmine-match-sparse-tree nil match + "issues, versions, trackers, and projects"))) + +(defun orgmine-show-descriptions (arg) + "Show Description entries." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-description + "description headlines")) + +(defun orgmine-show-journals (arg) + "Show Journal entries." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-journal "journal headlines")) + +(defun orgmine-show-attachments (arg) + "Show Attachments entries." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-attachments + "attachment headlines")) + +(defun orgmine-show-create (arg) + "Show entries to create." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-create-me "entries to create")) + +(defun orgmine-show-update (arg) + "Show entries to update." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-update-me "entries to update")) + +(defun orgmine-show-create-or-update (arg) + "Show entries to create-or-update." + (interactive "P") + (orgmine-match-sparse-tree nil (format "%s|%s" orgmine-tag-create-me + orgmine-tag-update-me) + "entries to create or to update")) + +(defun orgmine-show-refile (&optional arg) + "Show entries to refile." + (interactive "P") + (orgmine-match-sparse-tree nil orgmine-tag-refile-me "entries to refile")) + +(defun orgmine-show-assigned-to (who todo-only) + "Show entries assigned to WHO." + (interactive (list (completing-read + "Assigned To: " + (mapcar #'list (org-property-values "om_assigned_to"))) + current-prefix-arg)) + (let ((match (format "%s+om_assigned_to=\"%s\"" orgmine-tag-issue who)) + (what (format "issues assigned to %s..." who))) + (orgmine-match-sparse-tree todo-only match what))) + +(defun orgmine-show-assigned-to-me (todo-only) + "Show entries of Redmine issue/version to update." + (interactive "P") + (let ((me (org-entry-get (point-min) "om_me" t))) + (unless me + (error + "om_me property not found. define it by \"#+PROPERTY om_me\" line")) + (orgmine-show-assigned-to me todo-only))) + +(defun orgmine-show-assigned-to (who todo-only) + "Show entries author of WHO." + (interactive (list (completing-read + "Author: " + (mapcar #'list (org-property-values "author"))) + current-prefix-arg)) + (let ((match (format "%s+om_author=\"%s\"" orgmine-tag-issue who)) + (what (format "issues whose author is %s..." who))) + (orgmine-match-sparse-tree todo-only match what))) + +(defun orgmine-show-category (category) + "Show entries of CATEGORY." + (interactive (list (completing-read + "Category: " + (mapcar #'list (org-property-values "om_category"))) + current-prefix-arg)) + (let ((match (format "%s+om_category=\"%s\"" orgmine-tag-issue category)) + (what (format "issues category of %s..." category))) + (orgmine-match-sparse-tree todo-only match what))) + +(defun orgmine-show-notes (arg) + "Show notes." + (interactive "P") + (org-occur (regexp-quote orgmine-note-block-begin))) + +;;;; + +(defun orgmine-get-filters (beg) + "Return filters for the current subtree to get issues." + (save-excursion + (org-back-to-heading t) + (let* ((plist + (orgmine-get-properties beg '(project fixed_version tracker) t t)) +;; (filters (plist-merge '(list :status_id "*" :subproject_id "!*" +;; :tracker_id "!*" :fixed_version_id "*") +;; plist))) +;; (filters (plist-merge (list :status_id "*" :subproject_id "!*" +;; :tracker_id "!*") + (filters (plist-merge (list :status_id "*" :subproject_id "!*") + plist))) + (if (member orgmine-tag-issue (org-get-tags)) + (let ((id (orgmine-get-id nil))) + ;; XXX: :parent_id does not work for filter??? + (setq filters (plist-put filters :parent_id id)))) + filters))) + +(defun orgmine-update-issue-maybe (id beg end) + "Update issue entry and return non-nil if it exists in the buffer. +Otherwise, return nil." + (goto-char beg) + (let* ((issue (and (orgmine-find-issue id end) + (org-element-at-point)))) + (if issue + ;; refetch issue so that it contains journals/attachments. + (let ((redmine-issue (orgmine-get-issue id nil))) + (orgmine-update-issue issue redmine-issue force) + (add-to-list 'orgmine-ignore-ids id) + (point))))) + +(defun orgmine-update-issue-all-maybe (id &optional beg end) + "Update all issue entries for ID and return non-nil +if it exists in the buffer. Otherwise, return nil." + (goto-char (or beg (setq begin (point-min)))) + (setq end (copy-marker (or end (point-max)))) + (let (found pos) + (while (orgmine-update-issue-maybe id (point) end) + (setq found t) + (outline-next-heading)) + found)) + +(defun orgmine-insert-or-update-issue (id-list end force) + "Insert or update the issue entries of ID-LIST. +If the issue entry does not exist after the current position, +new entry will be inserted into the current position." + (let ((beg (point))) + (mapc (lambda (id) + (or (member id orgmine-ignore-ids) +;; (orgmine-update-issue-maybe id beg end) + (orgmine-update-issue-all-maybe id) + (progn + ;; insert issue as new entry. + (goto-char beg) + (outline-next-heading) + (orgmine-insert-issue id nil nil t) ; XXX: refetch + (if (= (funcall outline-level) 1) + (org-demote-subtree))))) + id-list))) + +(defun orgmine-get-issues (beg) + "get issues from redmine on current condition." + (goto-char beg) + (if (orgmine-tags-in-tag-p (list orgmine-tag-project orgmine-tag-version + orgmine-tag-tracker) + (org-get-tags)) + (let* ((filters (orgmine-get-filters beg)) + (project (plist-get filters :project_id)) + ;; XXX: elmine/get-issues does not return issues with journals + ;; even when ':include "journals"' is passed as the parameter. + (redmine-issues + (if (not project) + (error "no project property (project_id) exists") + (message "retrieving issues with filter: %s" filters) + (apply 'elmine/get-project-issues project filters)))) + (prog1 redmine-issues + (if (not redmine-issues) + (message "no issue exists for %s" filters) + (message "%d issue(s) retrieved." (length redmine-issues))))) +;; (message "not a region for sync issues") + nil)) + +(defun orgmine-collect-issues (beg end redmine-issues + &optional force update-only) + "collect issues id list between BEG and END which needs to be updated +or newly inserted per REDMINE-ISSUES." + (let (id-list) + (mapc (lambda (redmine-issue) + (goto-char beg) + (let* ((id (plist-get redmine-issue :id)) + (issue (and (orgmine-find-issue id end) + (org-element-at-point))) + (issue-before-region-p (save-excursion + (goto-char (point-min)) + (orgmine-find-issue id beg))) + (issue-after-region-p (save-excursion + (goto-char end) + (orgmine-find-issue id + (point-max))))) + (cond ((member id orgmine-ignore-ids) + (message "issue #%s skipped (updated or archived)" id)) + ((and (not issue) + (or issue-before-region-p issue-after-region-p)) + (message "issue #%s skipped (exists outside region)" id)) + ((and (not force) issue + (orgmine-entry-up-to-date-p issue redmine-issue)) + (message "issue #%s skipped (no change since last sync)" + id)) + ((and update-only (not issue)) + (message "issue #%s skipped (not inside region)" id)) + (t (add-to-list 'id-list id))))) + (reverse redmine-issues)) + id-list)) + +(defun orgmine-sync-issues (beg end &optional force update-only cache) + "update entries between BEG and END from the condition. +If UPDATE-ONLY is nil, insert issue that does not exist in the buffer." + (goto-char beg) + (let* ((redmine-issues (orgmine-get-issues beg)) + (id-list (orgmine-collect-issues beg end redmine-issues + force update-only))) + (cond ((and redmine-issues (null id-list)) + (message "%d issue(s) retrieved - no issue to sync." + (length redmine-issues))) + (id-list + (goto-char beg) + (orgmine-insert-or-update-issue id-list end t) + (message "%d issue(s) retrieved - synchronized issues: %s" + (length redmine-issues) + (mapconcat (lambda (id) (format "#%s" id)) + id-list " ")))))) + +(defun orgmine-sync-region (beg end &optional force update-only cache) + (interactive "r\nP") + (if (and (called-interactively-p 'interactive) + (not (org-region-active-p))) + (error "region not active")) + (let ((orgmine-ignore-ids orgmine-ignore-ids)) + (if (called-interactively-p 'interactive) + (setq orgmine-ignore-ids (orgmine-archived-issues))) + (setq end (copy-marker end)) + (org-with-wide-buffer ; XXX + (orgmine-submit nil) + (goto-char beg) + (orgmine-submit-issue-region beg end nil) + ;; update version/tracker/project properties + (goto-char beg) + (orgmine-fetch force) ; XXX: issue headline before beg could be updated. + ;; update issues + (goto-char beg) + (orgmine-sync-issues beg end force update-only) + (set-marker end nil)))) + +(defun orgmine-sync-subtree (force) + (interactive "P") + (org-with-wide-buffer + (let* ((subtree (orgmine-subtree-region)) + (beg (car subtree)) + (end (cdr subtree)) + (orgmine-ignore-ids (orgmine-archived-issues))) + (narrow-to-region beg end) + (orgmine-sync-region beg end force)))) + +(defun orgmine-sync-subtree-recursively (&optional tags force) + "call `orgmine-sync-subtree' on headlines of specific TAGS recursively +in depth first manner." + (interactive (list nil current-prefix-arg)) + (or tags (setq tags (list orgmine-tag-project orgmine-tag-version + orgmine-tag-tracker orgmine-tag-versions))) + (let* ((region (orgmine-subtree-region)) + (beg (car region)) + (end (copy-marker (cdr region)))) + (show-branches) + (save-excursion + (if (org-goto-first-child) + (orgmine-map-region (lambda () + (orgmine-sync-subtree-recursively tags force)) + (point) end t))) + (if (orgmine-tags-in-tag-p tags (org-get-tags)) + (orgmine-sync-subtree force)) + (set-marker end nil) +;; (goto-char end))) + (goto-char beg))) + +(defun orgmine-sync-buffer (&optional force) + "Synchronize the whole entries in the buffer." + (interactive "P") + (when (y-or-n-p "Will you sync the whole buffer (it may take long time) ? ") + (message ">>> starting buffer synchronization ------------------------") + (org-with-wide-buffer + (let ((orgmine-ignore-ids (orgmine-archived-issues)) + (beg (progn + (goto-char (point-min)) + (and (org-before-first-heading-p) (outline-next-heading)) + (point))) + (end (copy-marker (point-max)))) + ;; sync each subtrees one by one from top to bottom of buffer. + (goto-char beg) + (let ((tags (list orgmine-tag-project orgmine-tag-version + orgmine-tag-tracker orgmine-tag-versions))) + (while (re-search-forward "^\\* " nil t) + (save-excursion + (orgmine-sync-subtree-recursively tags force)) + (outline-next-heading))) + ;; + (goto-char beg) + (orgmine-sync-issues beg end force t) + (set-marker end nil))) + (message ">>> ending buffer synchronization ------------------------") + (message + "check *Messages* buffer for entries that might not be sync'ed."))) + +(defun orgmine-sync-all-buffers (&optional force) + "Synchronize the whole entries in all of the orgmine buffers." + (interactive "P") + (save-window-excursion + (let ((buffers (orgmine-buffer-list))) + (mapc (lambda (buf) + (switch-to-buffer buf) + (orgmine-sync-buffer force)) + buffers)))) + +(defun orgmine-ediff-entry (beg id-prop orgmine-fetch-entry-func + &optional show-no-child) + "Run Ediff on local entry and Redmine server entry." + (interactive "P") + (org-with-wide-buffer + (goto-char beg) + (let* ((subtree (orgmine-subtree-region)) + (beg (car subtree)) + (end (if show-no-child (progn (goto-char beg) + (outline-next-heading) + (point)) + (cdr subtree))) + (contents (buffer-substring beg end)) + (id (orgmine-get-id beg id-prop))) + (unless id (error "Redmine issue headline without ID (om_id prop)")) + (narrow-to-region beg end) + (show-all) + (goto-char (point-min)) + (let ((level (funcall outline-level)) + (buf-a (get-buffer-create "*ORGMINE-LATEST*")) + (buf-b (current-buffer))) + (with-current-buffer buf-a + (read-only-mode 0) + (erase-buffer) + (org-mode) + (orgmine-mode) + (orgmine-copy-buffer-local-variables buf-b buf-a) + (goto-char (point-min)) + (insert contents) + (goto-char (point-min)) + (funcall orgmine-fetch-entry-func t) +;; (goto-char (point-max)) +;; (unless (bolp) (insert "\n")) + (goto-char (point-min)) + (show-all) + (set-buffer-modified-p nil) + (read-only-mode)) + (defvar orgmine-ediff-buf-a) + (setq orgmine-ediff-buf-a buf-a) + (ediff-buffers buf-a buf-b + '((lambda () + (make-local-variable 'ediff-quit-hook) + (add-hook 'ediff-quit-hook + (lambda () + (kill-buffer orgmine-ediff-buf-a)))))) + )))) + +(defun orgmine-ediff-issue (arg) + "Run Ediff on local issue entry and Redmine server issue entry." + (interactive "P") + (let ((issue (orgmine-find-headline-ancestor orgmine-tag-issue))) + (orgmine-ediff-entry (org-element-property :begin issue) +;; 'id 'orgmine-insert-issue nil))) + 'id 'orgmine-fetch-issue nil))) + +(defun orgmine-ediff-version (arg) + "Run Ediff on local version entry and Redmine server version entry." + (interactive "P") + (let ((version (orgmine-find-headline-ancestor orgmine-tag-version))) + (orgmine-ediff-entry (org-element-property :begin version) +;; 'fixed_version 'orgmine-insert-version t))) + 'fixed_version 'orgmine-fetch-version t))) + +(defun orgmine-ediff-tracker (arg) + "Run Ediff on local tracker entry and Redmine server tracker entry." + (interactive "P") + (let ((tracker (orgmine-find-headline-ancestor orgmine-tag-tracker))) + (orgmine-ediff-entry (org-element-property :begin tracker) +;; 'tracker 'orgmine-insert-tracker t))) + 'tracker 'orgmine-fetch-tracker t))) + +(defun orgmine-ediff-project (arg) + "Run Ediff on local project entry and Redmine server project entry." + (interactive "P") + (let ((project (orgmine-find-headline-ancestor orgmine-tag-project))) + (orgmine-ediff-entry (org-element-property :begin project) +;; 'project 'orgmine-insert-project nil))) + 'project 'orgmine-fetch-project nil))) + +(defun orgmine-ediff (arg) + "Run Ediff on local entry and Redmine server entry. +Then entry could be an issue, version, tracker or project." + (interactive "P") + (save-excursion + (unless (outline-on-heading-p t) + (outline-previous-heading)) + (let ((tags (org-get-tags))) + (cond ((member orgmine-tag-version tags) (orgmine-ediff-version arg)) + ((member orgmine-tag-tracker tags) (orgmine-ediff-tracker arg)) + ((member orgmine-tag-project tags) (orgmine-ediff-project arg)) + (t (orgmine-ediff-issue arg)))))) + +;;;; + +(defun orgmine-insert-todo-sequence-template () + (let* ((issue-statuses (elmine/get-issue-statuses)) + open-statuses closed-statuses) + (mapc (lambda (status) + (let ((name (orgmine-name status nil nil))) + (if (plist-get status :is_closed) + (add-to-list 'closed-statuses name) + (add-to-list 'open-statuses name)))) + (nreverse issue-statuses)) + (insert "#+SEQ_TODO: " (mapconcat 'orgmine-todo-keyword open-statuses " ")) + (if closed-statuses + (insert " | " (mapconcat 'orgmine-todo-keyword closed-statuses " "))) + (insert "\n"))) + +(defun orgmine-insert-assigned-to-property-template () + (let* ((users (elmine/get-users)) + (list (mapcar (lambda (user) + (orgmine-idname user orgmine-user-name-format t)) + users))) + (insert "#+PROPERTY: om_assigned_to_ALL " + (mapconcat 'identity list " ") + "\n"))) + +(defun orgmine-insert-author-property-template () + (let* ((users (elmine/get-users)) + (list (mapcar (lambda (user) + (orgmine-idname user orgmine-user-name-format t)) + users))) + (insert "#+PROPERTY: om_author_ALL " + (mapconcat 'identity list " ") + "\n"))) + +(defun orgmine-insert-category-property-template () + (let* ((users (elmine/get-categories)) ; TODO + (list (mapcar (lambda (category) + ;; XXX + (orgmine-idname category orgmine-user-name-format t)) + category))) + (insert "#+PROPERTY: om_category_ALL " + (mapconcat 'identity list " ") + "\n"))) + +(defun orgmine-insert-status-property-template () + (let* ((statuses (elmine/get-issue-statuses)) + (list (mapcar (lambda (status) + (orgmine-idname status nil nil)) + statuses))) + (insert "#+PROPERTY: om_status_ALL " + (mapconcat 'orgmine-todo-keyword list " ") ; XXX + " open locked closed" ; for fixed_version + "\n"))) + +(defun orgmine-insert-tracker-property-template (project) + (let* ((trackers (elmine/get-project-trackers project)) + (list (mapcar (lambda (tracker) + (orgmine-idname tracker nil t)) + trackers))) + (insert "#+PROPERTY: om_trackers_ALL " + (mapconcat 'identity list " ") + "\n"))) + +(defun orgmine-insert-custom-fields-property-template (project) + (let ((fields (elmine/get-custom-fields (list :project project)))) + (mapc (lambda (field) + (let ((field-format (plist-get field :field_format)) + (customized-type (plist-get field :customized_type)) + (possible-values (plist-get field :possible_values))) + (cond ((equal field-format "list") + (insert "#+PROPERTY: " + (orgmine-custom-field-property-name field) + "_ALL") + (mapc (lambda (elem) + (insert " " (plist-get elem :value))) + possible-values) + (insert "\n")) + ))) + fields))) + +(defun orgmine-insert-template (arg) + "Insert template property footnote for orgmine-mode at current position." + (interactive "P") + (let ((project (orgmine-read-project))) + (orgmine-insert-todo-sequence-template) + (if (and (boundp 'orgmine-server) orgmine-server) + (insert "#+PROPERTY: om_server " orgmine-server "\n")) + (insert "#+PROPERTY: om_project " project "\n") + (orgmine-insert-status-property-template) + (orgmine-insert-tracker-property-template (string-to-number project)) + (orgmine-insert-assigned-to-property-template) + (insert "#+PROPERTY: om_done_ration_ALL " + "0 10 20 30 40 50 60 70 80 90 100\n") + (orgmine-insert-custom-fields-property-template project))) + +;;;; + +;; (defun orgmine-body-block-before-subtree () +;; (org-back-to-heading t) +;; (show-subtree) +;; (save-excursion +;; (forward-line) +;; (if (not (org-at-heading-p t)) +;; (cons (point) +;; (outline-next-heading))))) + +(defun orgmine-skeletonize-headline (type property-list todo-keyword) + "Make the current headline into a skeleton headline. +TYPE is any of 'issue, 'fixed_version, 'tracker, 'project. +All properties are removed but PROPERTY-LIST. +If TODO-KEYWORD is not null, set TODO Keyword to TODO-KEYWORD." + (unless (org-at-heading-p t) (error "not a headline.")) + (show-subtree) + (let ((properties (orgmine-get-properties nil property-list)) + (title (orgmine-extract-subject + (substring-no-properties (org-get-heading t t)))) +;; (block (orgmine-body-block-before-subtree))) + (block (orgmine-body-region))) + (if block + (delete-region (car block) (cdr block))) + (orgmine-update-title title) + (org-toggle-tag org-archive-tag 'off) + (org-toggle-tag orgmine-tag-create-me 'on) + (org-toggle-tag orgmine-tag-update-me 'off) + (org-toggle-tag orgmine-tag-refile-me 'off) + (orgmine-set-properties type properties property-list) + (if todo-keyword + (orgmine-todo todo-keyword)))) + +(defun orgmine-skeletonize-issue (property-list) + "Make the current issue entry into a skeleton entry." + (or property-list + (setq property-list '(tracker assigned_to custom_fields))) + (orgmine-current-issue-heading) + (orgmine-skeletonize-headline 'issue property-list + (orgmine-default-todo-keyword)) + ;; remove attachment node and journals node + (let* ((subtree (orgmine-subtree-region)) + (beg (car subtree)) + (end (copy-marker (cdr subtree)))) + (org-goto-first-child) + (orgmine-delete-headline orgmine-tag-attachments end t) + (orgmine-delete-headline orgmine-tag-journals end t) + (set-marker end nil) + (goto-char beg))) + +(defun orgmine-skeletonize-version (property-list) + "Make the current issue entry into a skeleton entry." + (let ((version (orgmine-find-headline-ancestor orgmine-tag-version))) + (goto-char (org-element-property :begin version))) + (orgmine-skeletonize-headline 'fixed_version property-list nil)) + +(defun orgmine-skeletonize-tracker (property-list) + "Make the current tracker entry into a skeleton entry." + (or property-list + (setq property-list '(tracker))) + (let ((tracker (orgmine-find-headline-ancestor orgmine-tag-tracker))) + (goto-char (org-element-property :begin tracker))) + (orgmine-skeletonize-headline 'tracker property-list nil)) + +(defun orgmine-skeletonize-project (property-list) + "Make the current project entry into a skeleton entry." + (let ((project (orgmine-find-headline-ancestor orgmine-tag-project))) + (goto-char (org-element-property :begin project))) + (orgmine-skeletonize-headline 'project property-list nil)) + +(defun orgmine-skeletonize-region (beg end arg) + (interactive "r\nP") + (if (and (called-interactively-p 'interactive) + (not (org-region-active-p))) + (error "region not active")) + (setq end (copy-marker end)) + (org-with-wide-buffer + (goto-char beg) + (show-subtree) + (while (re-search-forward "^\\*+ " end t) + (save-excursion + (let ((tags (org-get-tags))) + (cond ((member orgmine-tag-issue tags) + (orgmine-skeletonize-issue nil)) + ((member orgmine-tag-version tags) + (orgmine-skeletonize-version nil)) + ((member orgmine-tag-tracker tags) + (orgmine-skeletonize-tracker nil)) + ((member orgmine-tag-project tags) + (orgmine-skeletonize-project nil))))) + (outline-next-heading)) + (set-marker end nil) + (goto-char beg))) + +(defun orgmine-skeletonize-subtree (arg) + "Skeletonize the current subtree." + (interactive "P") + (let* ((subtree (orgmine-subtree-region)) + (beg (car subtree)) + (end (cdr subtree))) + (orgmine-skeletonize-region beg end arg))) + + +;;;; + +(defun orgmine-after-todo-state-change () + (when (and (boundp 'orgmine-tag-issue) + (boundp 'orgmine-tag-update-me) + (member orgmine-tag-issue (org-get-tags))) + (orgmine-toggle-tag orgmine-tag-update-me 'on) + (message "run M-x orgmine-submit to send the changes to Redmine server."))) +;; (defun orgmine-after-todo-state-change () +;; (if (and (called-interactively-p 'interactive) ; XXX +;; (member orgmine-tag-issue (org-get-tags))) +;; (org-toggle-tag orgmine-tag-update-me 'on))) + +(provide 'orgmine) + +;; orgmine.el ends here diff --git a/lisp/perltidy.el b/lisp/perltidy.el new file mode 100644 index 0000000..f52bca2 --- /dev/null +++ b/lisp/perltidy.el @@ -0,0 +1,249 @@ +;;; perltidy.el --- Tidy perl code + +;; Copyright (C) 2007-2015 Free Software Foundation, Inc. +;; +;; Author: Ye Wenbin +;; Maintainer: Kirill Babikhin +;; Created: 22 Dec 2007 +;; Version: 0.05 +;; Keywords: tools, convenience, languages + +;; 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, 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., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; As the PBP(Perl Best Practice) suggest, put this to your ~/.perltidyrc: +;; ## .perltidyrc --- configuration for perltidy +;; # Max line width is 78 cols +;; -l=78 +;; # Indent level is 4 cols +;; -i=4 +;; # Continuation indent is 4 cols +;; -ci=4 +;; # Output to STDOUT +;; -st +;; # Errors to STDERR +;; -se +;; # Maximal vertical tightness +;; -vt=2 +;; # No extra indentation for closing brackets +;; -cti=0 +;; # Medium parenthesis tightness +;; -pt=1 +;; # Medium brace tightness +;; -bt=1 +;; # Medium square bracket tightness +;; -sbt=1 +;; # Medium block brace tightness +;; -bbt=1 +;; # No space before semicolons +;; -nsfs +;; # Don't outdent long quoted strings +;; -nolq +;; # Break before all operators +;; -wbb="% + - * / x != == >= <= =~ !~ < > | & >= < = **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" + +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'perltidy) + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup perltidy nil + "Tidy perl code using perltidy" + :group 'tools + :group 'pde) + +(defcustom perltidy-program "perltidy" + "*Program name of perltidy" + :type 'string + :group 'perltidy) + +(defcustom perltidy-program-params + '(;; I/O control + "--standard-output" + "--standard-error-output" + "--force-read-binary" + "--quiet" + + ;; FORMATTING OPTIONS + "--no-check-syntax" + ) + "*perltidy run options" + :type 'list + :group 'perltidy) + +(defcustom perltidy-rcregex "\\.perltidyrc" + "perltidyrc file regex" + :type 'string + :group 'perltidy) + +(defmacro perltidy-save-point (&rest body) + (declare (indent 0) (debug t)) + `(let ((old-point (point))) + ,@body + (goto-char old-point))) + +;;;###autoload +(defun perltidy-region (beg end) + "Tidy perl code in the region." + (interactive "r") + (or (get 'perltidy-program 'has-perltidy) + (if (executable-find perltidy-program) + (put 'perltidy-program 'has-perltidy t) + (error "Seem perltidy is not installed"))) + (perltidy-save-point + + (let ((old-perltidy-env (getenv "PERLTIDY")) + (remote? (tramp-tramp-file-p buffer-file-name)) + (perltidyrc (perltidy-find-perltidyrc buffer-file-truename)) + (pertidyrc-remote (expand-file-name "perltidyrc-remote" temporary-file-directory)) + (perltidy-run-list perltidy-program-params) + ) + + (if (and (bound-and-true-p remote?) + perltidyrc) + (progn + (require 'tramp-sh) + (tramp-sh-handle-copy-file perltidyrc pertidyrc-remote t) + (setq perltidyrc pertidyrc-remote) + (setq perltidy-run-list + (append perltidy-run-list + (list (concat "-pro=" pertidyrc-remote)))))) + + (apply #'call-process-region + (append (list beg end perltidy-program + t + t + t + ) + perltidy-run-list))) + t)) + +;;;###autoload +(defun perltidy-buffer () + "Call perltidy for whole buffer." + (interactive) + (perltidy-region (point-min) (point-max))) + +;;;###autoload +(defun perltidy-subroutine () + "Call perltidy for subroutine at point." + (interactive) + + (save-excursion + (let ((current-point (point)) + b e) + (setq b (progn (beginning-of-defun) (point))) + (when (and + (looking-at "\\s-*sub\\s-+") + (< b current-point) + (> (save-excursion + (setq e (progn (end-of-defun) (point)))) + current-point)) + (perltidy-region b e))))) + +;;;###autoload +(defun perltidy-dwim-safe (arg) + "Perltidy Do What I Mean safe. +If region is active call perltidy on the region. +If inside subroutine, call perltidy on the subroutine, +otherwise stop." + (interactive "P") + (let ((buf (current-buffer)) + beg end) + (cond ((and mark-active transient-mark-mode) + (setq beg (region-beginning) + end (region-end))) + ((save-excursion + (let ((current-point (point)) + b e) + (setq b (progn (beginning-of-defun) (point))) + (when (and + (looking-at "\\s-*sub\\s-+") + (< b current-point) + (> (save-excursion + (setq e (progn (end-of-defun) (point)))) + current-point)) + (setq beg b + end e))))) + (t (setq beg nil + end nil))) + (if (and beg + end) + (progn + (perltidy-region beg end) + (font-lock-fontify-buffer))))) + +;;;###autoload +(defun perltidy-dwim (arg) + "Perltidy Do What I Mean. +If region is active call perltidy on the region. +If inside subroutine, call perltidy on the subroutine, +otherwise call perltidy for whole buffer." + (interactive "P") + (let ((buf (current-buffer)) + beg end) + (cond ((and mark-active transient-mark-mode) + (setq beg (region-beginning) + end (region-end))) + ((save-excursion + (let ((current-point (point)) + b e) + (setq b (progn (beginning-of-defun) (point))) + (when (and + (looking-at "\\s-*sub\\s-+") + (< b current-point) + (> (save-excursion + (setq e (progn (end-of-defun) (point)))) + current-point)) + (setq beg b + end e))))) + (t (setq beg (point-min) + end (point-max)))) + (perltidy-region beg end) + (font-lock-fontify-buffer))) + +(defun perltidy-find-perltidyrc (&optional dir rcregex) + (unless dir (setq dir (buffer-file-name))) + (unless rcregex (setq rcregex perltidy-rcregex)) + (setq dir (file-name-directory dir)) + + (let (rcfile) + (catch 'my-tag + (locate-dominating-file + dir + (lambda (parent) + (let ((rc (car (ignore-errors (directory-files parent t rcregex)))) + (pparent (file-name-directory (directory-file-name parent)))) + (setq rcfile rc) + (cond ((equal parent + pparent) + (if (= (length rc) 0) + (throw 'my-tag rc) + (throw 'my-tag nil))) + + ((and (= (length rc) 0) + (file-exists-p (expand-file-name "lib" pparent)) + (file-directory-p (expand-file-name "lib" pparent))) + (setq rcfile (car (ignore-errors (directory-files pparent t rcregex)))) + (throw 'my-tag rcfile)) + (t rc)))))) + rcfile)) + +(provide 'perltidy) +;;; perltidy.el ends here diff --git a/lisp/s.el b/lisp/s.el new file mode 100644 index 0000000..cae199b --- /dev/null +++ b/lisp/s.el @@ -0,0 +1,792 @@ +;;; s.el --- The long lost Emacs string manipulation library. -*- lexical-binding: t -*- + +;; Copyright (C) 2012-2022 Magnar Sveen + +;; Author: Magnar Sveen +;; Maintainer: Jason Milkins +;; Version: 1.13.1 +;; Keywords: strings + +;; 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 3 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, see . + +;;; Commentary: + +;; The long lost Emacs string manipulation library. +;; +;; See documentation on https://github.com/magnars/s.el#functions + +;;; Code: + +;; Silence byte-compiler +(defvar ucs-normalize-combining-chars) ; Defined in `ucs-normalize' +(autoload 'slot-value "eieio") + +(defun s-trim-left (s) + "Remove whitespace at the beginning of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (string-match "\\`[ \t\n\r]+" s) + (replace-match "" t t s) + s))) + +(defun s-trim-right (s) + "Remove whitespace at the end of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (string-match "[ \t\n\r]+\\'" s) + (replace-match "" t t s) + s))) + +(defun s-trim (s) + "Remove whitespace at the beginning and end of S." + (declare (pure t) (side-effect-free t)) + (s-trim-left (s-trim-right s))) + +(defun s-collapse-whitespace (s) + "Convert all adjacent whitespace characters to a single space." + (declare (pure t) (side-effect-free t)) + (replace-regexp-in-string "[ \t\n\r]+" " " s)) + +(defun s-unindent (s &optional bol) + "Unindent S which has BOL (beginning of line) indicators. +BOL will default to pipe. You can optionally supply your own." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search nil) + (bol (or bol "|"))) + (s-replace-regexp (concat "^[[:space:]]*" (regexp-quote bol)) "" s))) + +(defun s-split (separator s &optional omit-nulls) + "Split S into substrings bounded by matches for regexp SEPARATOR. +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +This is a simple wrapper around the built-in `split-string'." + (declare (side-effect-free t)) + (save-match-data + (split-string s separator omit-nulls))) + +(defun s-split-up-to (separator s n &optional omit-nulls) + "Split S up to N times into substrings bounded by matches for regexp SEPARATOR. + +If OMIT-NULLS is non-nil, zero-length substrings are omitted. + +See also `s-split'." + (declare (side-effect-free t)) + (save-match-data + (let ((op 0) + (r nil)) + (with-temp-buffer + (insert s) + (setq op (goto-char (point-min))) + (while (and (re-search-forward separator nil t) + (< 0 n)) + (let ((sub (buffer-substring op (match-beginning 0)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r))) + (setq op (goto-char (match-end 0))) + (setq n (1- n))) + (let ((sub (buffer-substring op (point-max)))) + (unless (and omit-nulls + (equal sub "")) + (push sub r)))) + (nreverse r)))) + +(defun s-lines (s) + "Splits S into a list of strings on newline characters." + (declare (pure t) (side-effect-free t)) + (s-split "\\(\r\n\\|[\n\r]\\)" s)) + +(defun s-join (separator strings) + "Join all the strings in STRINGS with SEPARATOR in between." + (declare (pure t) (side-effect-free t)) + (mapconcat 'identity strings separator)) + +(defun s-concat (&rest strings) + "Join all the string arguments into one string." + (declare (pure t) (side-effect-free t)) + (apply 'concat strings)) + +(defun s-prepend (prefix s) + "Concatenate PREFIX and S." + (declare (pure t) (side-effect-free t)) + (concat prefix s)) + +(defun s-append (suffix s) + "Concatenate S and SUFFIX." + (declare (pure t) (side-effect-free t)) + (concat s suffix)) + +(defun s-splice (needle n s) + "Splice NEEDLE into S at position N. +0 is the beginning of the string, -1 is the end." + (if (< n 0) + (let ((left (substring s 0 (+ 1 n (length s)))) + (right (s-right (- -1 n) s))) + (concat left needle right)) + (let ((left (s-left n s)) + (right (substring s n (length s)))) + (concat left needle right)))) + + +(defun s-repeat (num s) + "Make a string of S repeated NUM times." + (declare (pure t) (side-effect-free t)) + (let (ss) + (while (> num 0) + (setq ss (cons s ss)) + (setq num (1- num))) + (apply 'concat ss))) + +(defun s-chop-suffix (suffix s) + "Remove SUFFIX if it is at end of S." + (declare (pure t) (side-effect-free t)) + (let ((pos (- (length suffix)))) + (if (and (>= (length s) (length suffix)) + (string= suffix (substring s pos))) + (substring s 0 pos) + s))) + +(defun s-chop-suffixes (suffixes s) + "Remove SUFFIXES one by one in order, if they are at the end of S." + (declare (pure t) (side-effect-free t)) + (while suffixes + (setq s (s-chop-suffix (car suffixes) s)) + (setq suffixes (cdr suffixes))) + s) + +(defun s-chop-prefix (prefix s) + "Remove PREFIX if it is at the start of S." + (declare (pure t) (side-effect-free t)) + (let ((pos (length prefix))) + (if (and (>= (length s) (length prefix)) + (string= prefix (substring s 0 pos))) + (substring s pos) + s))) + +(defun s-chop-prefixes (prefixes s) + "Remove PREFIXES one by one in order, if they are at the start of S." + (declare (pure t) (side-effect-free t)) + (while prefixes + (setq s (s-chop-prefix (car prefixes) s)) + (setq prefixes (cdr prefixes))) + s) + +(defun s-shared-start (s1 s2) + "Returns the longest prefix S1 and S2 have in common." + (declare (pure t) (side-effect-free t)) + (let ((cmp (compare-strings s1 0 (length s1) s2 0 (length s2)))) + (if (eq cmp t) s1 (substring s1 0 (1- (abs cmp)))))) + +(defun s-shared-end (s1 s2) + "Returns the longest suffix S1 and S2 have in common." + (declare (pure t) (side-effect-free t)) + (let* ((l1 (length s1)) + (l2 (length s2)) + (search-length (min l1 l2)) + (i 0)) + (while (and (< i search-length) + (= (aref s1 (- l1 i 1)) (aref s2 (- l2 i 1)))) + (setq i (1+ i))) + ;; If I is 0, then it means that there's no common suffix between + ;; S1 and S2. + ;; + ;; However, since (substring s (- 0)) will return the whole + ;; string, `s-shared-end' should simply return the empty string + ;; when I is 0. + (if (zerop i) + "" + (substring s1 (- i))))) + +(defun s-chomp (s) + "Remove one trailing `\\n`, `\\r` or `\\r\\n` from S." + (declare (pure t) (side-effect-free t)) + (s-chop-suffixes '("\n" "\r") s)) + +(defun s-truncate (len s &optional ellipsis) + "If S is longer than LEN, cut it down and add ELLIPSIS to the end. + +The resulting string, including ellipsis, will be LEN characters +long. + +When not specified, ELLIPSIS defaults to ‘...’." + (declare (pure t) (side-effect-free t)) + (unless ellipsis + (setq ellipsis "...")) + (if (> (length s) len) + (format "%s%s" (substring s 0 (- len (length ellipsis))) ellipsis) + s)) + +(defun s-word-wrap (len s) + "If S is longer than LEN, wrap the words with newlines." + (declare (side-effect-free t)) + (save-match-data + (with-temp-buffer + (insert s) + (let ((fill-column len)) + (fill-region (point-min) (point-max))) + (buffer-substring (point-min) (point-max))))) + +(defun s-center (len s) + "If S is shorter than LEN, pad it with spaces so it is centered." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat + (make-string (ceiling extra 2) ?\s) + s + (make-string (floor extra 2) ?\s)))) + +(defun s-pad-left (len padding s) + "If S is shorter than LEN, pad it with PADDING on the left." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat (make-string extra (string-to-char padding)) + s))) + +(defun s-pad-right (len padding s) + "If S is shorter than LEN, pad it with PADDING on the right." + (declare (pure t) (side-effect-free t)) + (let ((extra (max 0 (- len (length s))))) + (concat s + (make-string extra (string-to-char padding))))) + +(defun s-left (len s) + "Returns up to the LEN first chars of S." + (declare (pure t) (side-effect-free t)) + (if (> (length s) len) + (substring s 0 len) + s)) + +(defun s-right (len s) + "Returns up to the LEN last chars of S." + (declare (pure t) (side-effect-free t)) + (let ((l (length s))) + (if (> l len) + (substring s (- l len) l) + s))) + +(defun s-chop-left (len s) + "Remove the first LEN chars from S." + (let ((l (length s))) + (if (> l len) + (substring s len l) + ""))) + +(defun s-chop-right (len s) + "Remove the last LEN chars from S." + (let ((l (length s))) + (if (> l len) + (substring s 0 (- l len)) + ""))) + +(defun s-ends-with? (suffix s &optional ignore-case) + "Does S end with SUFFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-suffix?'" + (declare (pure t) (side-effect-free t)) + (let ((start-pos (- (length s) (length suffix)))) + (and (>= start-pos 0) + (eq t (compare-strings suffix nil nil + s start-pos nil ignore-case))))) + +(defun s-starts-with? (prefix s &optional ignore-case) + "Does S start with PREFIX? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences. + +Alias: `s-prefix?'. This is a simple wrapper around the built-in +`string-prefix-p'." + (declare (pure t) (side-effect-free t)) + (string-prefix-p prefix s ignore-case)) + +(defun s--truthy? (val) + (declare (pure t) (side-effect-free t)) + (not (null val))) + +(defun s-contains? (needle s &optional ignore-case) + "Does S contain NEEDLE? + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search ignore-case)) + (s--truthy? (string-match-p (regexp-quote needle) s)))) + +(defun s-equals? (s1 s2) + "Is S1 equal to S2? + +This is a simple wrapper around the built-in `string-equal'." + (declare (pure t) (side-effect-free t)) + (string-equal s1 s2)) + +(defun s-less? (s1 s2) + "Is S1 less than S2? + +This is a simple wrapper around the built-in `string-lessp'." + (declare (pure t) (side-effect-free t)) + (string-lessp s1 s2)) + +(defun s-matches? (regexp s &optional start) + "Does REGEXP match S? +If START is non-nil the search starts at that index. + +This is a simple wrapper around the built-in `string-match-p'." + (declare (side-effect-free t)) + (s--truthy? (string-match-p regexp s start))) + +(defun s-blank? (s) + "Is S nil or the empty string?" + (declare (pure t) (side-effect-free t)) + (or (null s) (string= "" s))) + +(defun s-blank-str? (s) + "Is S nil or the empty string or string only contains whitespace?" + (declare (pure t) (side-effect-free t)) + (or (s-blank? s) (s-blank? (s-trim s)))) + +(defun s-present? (s) + "Is S anything but nil or the empty string?" + (declare (pure t) (side-effect-free t)) + (not (s-blank? s))) + +(defun s-presence (s) + "Return S if it's `s-present?', otherwise return nil." + (declare (pure t) (side-effect-free t)) + (and (s-present? s) s)) + +(defun s-lowercase? (s) + "Are all the letters in S in lower case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (not (string-match-p "[[:upper:]]" s)))) + +(defun s-uppercase? (s) + "Are all the letters in S in upper case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (not (string-match-p "[[:lower:]]" s)))) + +(defun s-mixedcase? (s) + "Are there both lower case and upper case letters in S?" + (let ((case-fold-search nil)) + (s--truthy? + (and (string-match-p "[[:lower:]]" s) + (string-match-p "[[:upper:]]" s))))) + +(defun s-capitalized? (s) + "In S, is the first letter upper case, and all other letters lower case?" + (declare (side-effect-free t)) + (let ((case-fold-search nil)) + (s--truthy? + (string-match-p "^[[:upper:]][^[:upper:]]*$" s)))) + +(defun s-numeric? (s) + "Is S a number?" + (declare (pure t) (side-effect-free t)) + (s--truthy? + (string-match-p "^[0-9]+$" s))) + +(defun s-replace (old new s) + "Replaces OLD with NEW in S." + (declare (pure t) (side-effect-free t)) + (replace-regexp-in-string (regexp-quote old) new s t t)) + +(defalias 's-replace-regexp 'replace-regexp-in-string) + +(defun s--aget (alist key) + "Get the value of KEY in ALIST." + (declare (pure t) (side-effect-free t)) + (cdr (assoc-string key alist))) + +(defun s-replace-all (replacements s) + "REPLACEMENTS is a list of cons-cells. Each `car` is replaced with `cdr` in S." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search nil)) + (replace-regexp-in-string (regexp-opt (mapcar 'car replacements)) + (lambda (it) (s--aget replacements it)) + s t t))) + +(defun s-downcase (s) + "Convert S to lower case. + +This is a simple wrapper around the built-in `downcase'." + (declare (side-effect-free t)) + (downcase s)) + +(defun s-upcase (s) + "Convert S to upper case. + +This is a simple wrapper around the built-in `upcase'." + (declare (side-effect-free t)) + (upcase s)) + +(defun s-capitalize (s) + "Convert S first word's first character to upper and the rest to lower case." + (declare (side-effect-free t)) + (concat (upcase (substring s 0 1)) (downcase (substring s 1)))) + +(defun s-titleize (s) + "Convert in S each word's first character to upper and the rest to lower case. + +This is a simple wrapper around the built-in `capitalize'." + (declare (side-effect-free t)) + (capitalize s)) + +(defmacro s-with (s form &rest more) + "Threads S through the forms. Inserts S as the last item +in the first form, making a list of it if it is not a list +already. If there are more forms, inserts the first form as the +last item in second form, etc." + (declare (debug (form &rest [&or (function &rest form) fboundp]))) + (if (null more) + (if (listp form) + `(,(car form) ,@(cdr form) ,s) + (list form s)) + `(s-with (s-with ,s ,form) ,@more))) + +(put 's-with 'lisp-indent-function 1) + +(defun s-index-of (needle s &optional ignore-case) + "Returns first index of NEEDLE in S, or nil. + +If IGNORE-CASE is non-nil, the comparison is done without paying +attention to case differences." + (declare (pure t) (side-effect-free t)) + (let ((case-fold-search ignore-case)) + (string-match-p (regexp-quote needle) s))) + +(defun s-reverse (s) + "Return the reverse of S." + (declare (pure t) (side-effect-free t)) + (save-match-data + (if (multibyte-string-p s) + (let ((input (string-to-list s)) + output) + (require 'ucs-normalize) + (while input + ;; Handle entire grapheme cluster as a single unit + (let ((grapheme (list (pop input)))) + (while (memql (car input) ucs-normalize-combining-chars) + (push (pop input) grapheme)) + (setq output (nconc (nreverse grapheme) output)))) + (concat output)) + (concat (nreverse (string-to-list s)))))) + +(defun s-match-strings-all (regex string) + "Return a list of matches for REGEX in STRING. + +Each element itself is a list of matches, as per +`match-string'. Multiple matches at the same position will be +ignored after the first." + (declare (side-effect-free t)) + (save-match-data + (let ((all-strings ()) + (i 0)) + (while (and (< i (length string)) + (string-match regex string i)) + (setq i (1+ (match-beginning 0))) + (let (strings + (num-matches (/ (length (match-data)) 2)) + (match 0)) + (while (/= match num-matches) + (push (match-string match string) strings) + (setq match (1+ match))) + (push (nreverse strings) all-strings))) + (nreverse all-strings)))) + +(defun s-matched-positions-all (regexp string &optional subexp-depth) + "Return a list of matched positions for REGEXP in STRING. +SUBEXP-DEPTH is 0 by default." + (declare (side-effect-free t)) + (if (null subexp-depth) + (setq subexp-depth 0)) + (save-match-data + (let ((pos 0) result) + (while (and (string-match regexp string pos) + (< pos (length string))) + (push (cons (match-beginning subexp-depth) (match-end subexp-depth)) result) + (setq pos (match-end 0))) + (nreverse result)))) + +(defun s-match (regexp s &optional start) + "When the given expression matches the string, this function returns a list +of the whole matching string and a string for each matched subexpressions. +Subexpressions that didn't match are represented by nil elements +in the list, except that non-matching subexpressions at the end +of REGEXP might not appear at all in the list. That is, the +returned list can be shorter than the number of subexpressions in +REGEXP plus one. If REGEXP did not match the returned value is +an empty list (nil). + +When START is non-nil the search will start at that index." + (declare (side-effect-free t)) + (save-match-data + (if (string-match regexp s start) + (let ((match-data-list (match-data)) + result) + (while match-data-list + (let* ((beg (car match-data-list)) + (end (cadr match-data-list)) + (subs (if (and beg end) (substring s beg end) nil))) + (setq result (cons subs result)) + (setq match-data-list + (cddr match-data-list)))) + (nreverse result))))) + +(defun s-slice-at (regexp s) + "Slices S up at every index matching REGEXP." + (declare (side-effect-free t)) + (if (s-blank? s) + (list s) + (let (ss) + (while (not (s-blank? s)) + (save-match-data + (let ((i (string-match regexp s 1))) + (if i + (setq ss (cons (substring s 0 i) ss) + s (substring s i)) + (setq ss (cons s ss) + s ""))))) + (nreverse ss)))) + +(defun s-split-words (s) + "Split S into list of words." + (declare (side-effect-free t)) + (s-split + "[^[:word:]0-9]+" + (let ((case-fold-search nil)) + (replace-regexp-in-string + "\\([[:lower:]]\\)\\([[:upper:]]\\)" "\\1 \\2" + (replace-regexp-in-string "\\([[:upper:]]\\)\\([[:upper:]][0-9[:lower:]]\\)" "\\1 \\2" s))) + t)) + +(defun s--mapcar-head (fn-head fn-rest list) + "Like MAPCAR, but applies a different function to the first element." + (if list + (cons (funcall fn-head (car list)) (mapcar fn-rest (cdr list))))) + +(defun s-lower-camel-case (s) + "Convert S to lowerCamelCase." + (declare (side-effect-free t)) + (s-join "" (s--mapcar-head 'downcase 'capitalize (s-split-words s)))) + +(defun s-upper-camel-case (s) + "Convert S to UpperCamelCase." + (declare (side-effect-free t)) + (s-join "" (mapcar 'capitalize (s-split-words s)))) + +(defun s-snake-case (s) + "Convert S to snake_case." + (declare (side-effect-free t)) + (s-join "_" (mapcar 'downcase (s-split-words s)))) + +(defun s-dashed-words (s) + "Convert S to dashed-words." + (declare (side-effect-free t)) + (s-join "-" (mapcar 'downcase (s-split-words s)))) + +(defun s-spaced-words (s) + "Convert S to spaced words." + (declare (side-effect-free t)) + (s-join " " (s-split-words s))) + +(defun s-capitalized-words (s) + "Convert S to Capitalized words." + (declare (side-effect-free t)) + (let ((words (s-split-words s))) + (s-join " " (cons (capitalize (car words)) (mapcar 'downcase (cdr words)))))) + +(defun s-titleized-words (s) + "Convert S to Titleized Words." + (declare (side-effect-free t)) + (s-join " " (mapcar 's-titleize (s-split-words s)))) + +(defun s-word-initials (s) + "Convert S to its initials." + (declare (side-effect-free t)) + (s-join "" (mapcar (lambda (ss) (substring ss 0 1)) + (s-split-words s)))) + +;; Errors for s-format +(progn + (put 's-format-resolve + 'error-conditions + '(error s-format s-format-resolve)) + (put 's-format-resolve + 'error-message + "Cannot resolve a template to values")) + +(defun s-format (template replacer &optional extra) + "Format TEMPLATE with the function REPLACER. + +REPLACER takes an argument of the format variable and optionally +an extra argument which is the EXTRA value from the call to +`s-format'. + +Several standard `s-format' helper functions are recognized and +adapted for this: + + (s-format \"${name}\" \\='gethash hash-table) + (s-format \"${name}\" \\='aget alist) + (s-format \"$0\" \\='elt sequence) + +The REPLACER function may be used to do any other kind of +transformation." + (let ((saved-match-data (match-data))) + (unwind-protect + (replace-regexp-in-string + "\\$\\({\\([^}]+\\)}\\|[0-9]+\\)" + (lambda (md) + (let ((var + (let ((m (match-string 2 md))) + (if m m + (string-to-number (match-string 1 md))))) + (replacer-match-data (match-data))) + (unwind-protect + (let ((v + (cond + ((eq replacer 'gethash) + (funcall replacer var extra)) + ((eq replacer 'aget) + (funcall 's--aget extra var)) + ((eq replacer 'elt) + (funcall replacer extra var)) + ((eq replacer 'oref) + (funcall #'slot-value extra (intern var))) + (t + (set-match-data saved-match-data) + (if extra + (funcall replacer var extra) + (funcall replacer var)))))) + (if v (format "%s" v) (signal 's-format-resolve md))) + (set-match-data replacer-match-data)))) + template + ;; Need literal to make sure it works + t t) + (set-match-data saved-match-data)))) + +(defvar s-lex-value-as-lisp nil + "If `t' interpolate lisp values as lisp. + +`s-lex-format' inserts values with (format \"%S\").") + +(defun s-lex-fmt|expand (fmt) + "Expand FMT into lisp." + (declare (side-effect-free t)) + (list 's-format fmt (quote 'aget) + (append '(list) + (mapcar + (lambda (matches) + (list + 'cons + (cadr matches) + `(format + (if s-lex-value-as-lisp "%S" "%s") + ,(intern (cadr matches))))) + (s-match-strings-all "${\\([^}]+\\)}" fmt))))) + +(defmacro s-lex-format (format-str) + "`s-format` with the current environment. + +FORMAT-STR may use the `s-format' variable reference to refer to +any variable: + + (let ((x 1)) + (s-lex-format \"x is: ${x}\")) + +The values of the variables are interpolated with \"%s\" unless +the variable `s-lex-value-as-lisp' is `t' and then they are +interpolated with \"%S\"." + (declare (debug (form))) + (s-lex-fmt|expand format-str)) + +(defun s-count-matches (regexp s &optional start end) + "Count occurrences of `regexp' in `s'. + +`start', inclusive, and `end', exclusive, delimit the part of `s' to +match. `start' and `end' are both indexed starting at 1; the initial +character in `s' is index 1. + +This function starts looking for the next match from the end of the +previous match. Hence, it ignores matches that overlap a previously +found match. To count overlapping matches, use +`s-count-matches-all'." + (declare (side-effect-free t)) + (save-match-data + (with-temp-buffer + (insert s) + (goto-char (point-min)) + (count-matches regexp (or start 1) (or end (point-max)))))) + +(defun s-count-matches-all (regexp s &optional start end) + "Count occurrences of `regexp' in `s'. + +`start', inclusive, and `end', exclusive, delimit the part of `s' to +match. `start' and `end' are both indexed starting at 1; the initial +character in `s' is index 1. + +This function starts looking for the next match from the second +character of the previous match. Hence, it counts matches that +overlap a previously found match. To ignore matches that overlap a +previously found match, use `s-count-matches'." + (declare (side-effect-free t)) + (let* ((anchored-regexp (format "^%s" regexp)) + (match-count 0) + (i 0) + (narrowed-s (substring s (if start (1- start) 0) + (when end (1- end))))) + (save-match-data + (while (< i (length narrowed-s)) + (when (s-matches? anchored-regexp (substring narrowed-s i)) + (setq match-count (1+ match-count))) + (setq i (1+ i)))) + match-count)) + +(defun s-wrap (s prefix &optional suffix) + "Wrap string S with PREFIX and optionally SUFFIX. + +Return string S with PREFIX prepended. If SUFFIX is present, it +is appended, otherwise PREFIX is used as both prefix and +suffix." + (declare (pure t) (side-effect-free t)) + (concat prefix s (or suffix prefix))) + + +;;; Aliases + +(defalias 's-blank-p 's-blank?) +(defalias 's-blank-str-p 's-blank-str?) +(defalias 's-capitalized-p 's-capitalized?) +(defalias 's-contains-p 's-contains?) +(defalias 's-ends-with-p 's-ends-with?) +(defalias 's-equals-p 's-equals?) +(defalias 's-less-p 's-less?) +(defalias 's-lowercase-p 's-lowercase?) +(defalias 's-matches-p 's-matches?) +(defalias 's-mixedcase-p 's-mixedcase?) +(defalias 's-numeric-p 's-numeric?) +(defalias 's-prefix-p 's-starts-with?) +(defalias 's-prefix? 's-starts-with?) +(defalias 's-present-p 's-present?) +(defalias 's-starts-with-p 's-starts-with?) +(defalias 's-suffix-p 's-ends-with?) +(defalias 's-suffix? 's-ends-with?) +(defalias 's-uppercase-p 's-uppercase?) + + +(provide 's) +;;; s.el ends here diff --git a/request/curl-cookie-jar b/request/curl-cookie-jar new file mode 100644 index 0000000..c31d989 --- /dev/null +++ b/request/curl-cookie-jar @@ -0,0 +1,4 @@ +# Netscape HTTP Cookie File +# https://curl.se/docs/http-cookies.html +# This file was generated by libcurl! Edit at your own risk. + diff --git a/transient/history.el b/transient/history.el new file mode 100644 index 0000000..90b5a84 --- /dev/null +++ b/transient/history.el @@ -0,0 +1 @@ +nil \ No newline at end of file