Repository: baohaojun/org-jira Branch: master Commit: 5be5c438e596 Files: 15 Total size: 331.3 KB Directory structure: gitextract_6otzjjkx/ ├── .editorconfig ├── .gitignore ├── .travis.yml ├── Makefile ├── README.md ├── jiralib.el ├── org-jira-sdk.el ├── org-jira.el ├── t/ │ ├── .nosearch │ ├── batch-runner/ │ │ ├── dash.el │ │ ├── request.el │ │ └── s.el │ ├── jiralib-t.el │ └── org-jira-t.el └── todo.org ================================================ FILE CONTENTS ================================================ ================================================ FILE: .editorconfig ================================================ root = true [*] end_of_line = lf insert_final_newline = true charset = utf-8 trim_trailing_whitespace = true [*.{el}] indent_style = space ================================================ FILE: .gitignore ================================================ #.*# *#*# *.#* flycheck_* *.elc ================================================ FILE: .travis.yml ================================================ language: emacs-lisp sudo: false env: - EVM_EMACS=emacs-25.1-travis - EVM_EMACS=emacs-25.2-travis - EVM_EMACS=emacs-25.3-travis - EVM_EMACS=emacs-26.1-travis - EVM_EMACS=emacs-git-snapshot-travis script: - make test ================================================ FILE: Makefile ================================================ # Really just so we can run 'make test' easily all: test test: @emacs -batch \ -l ert \ -l t/batch-runner/s.el \ -l t/batch-runner/request.el \ -l t/batch-runner/dash.el \ -l jiralib.el \ -l org-jira-sdk.el \ -l org-jira.el \ -l t/org-jira-t.el \ -l t/jiralib-t.el \ -f ert-run-tests-batch-and-exit .PHONY: test ================================================ FILE: README.md ================================================ # org-jira mode [![Join the chat at https://gitter.im/org-jira/Lobby](https://badges.gitter.im/org-jira/Lobby.svg)](https://gitter.im/org-jira/Lobby?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![MELPA](http://melpa.org/packages/org-jira-badge.svg)](http://melpa.org/#/org-jira) Use Jira in Emacs org-mode. ## TOC **Table of Contents** - [org-jira mode](#org-jira-mode) - [TOC](#toc) - [Setup](#setup) - [Installation](#installation) - [Configuration](#configuration) - [Usage](#usage) - [Getting Started](#getting-started) - [Keybinds](#keybinds) - [Customization](#customization) - [Authorization workaround (NOT secure)](#authorization-workaround-not-secure) - [Optimizations](#optimizations) - [Optimizing available actions for status changes](#optimizing-available-actions-for-status-changes) - [About](#about) - [Maintainer](#maintainer) - [License](#license) ## Setup ### Installation To install, just grab it off of MELPA (ensure your ~/.emacs already has MELPA set up): ```lisp (require 'package) (add-to-list 'package-archives '("melpa" . "http://melpa.milkbox.net/packages/") t) (package-initialize) ``` Then run `M-x package-install RET org-jira RET` and you're done! ### Configuration In your ~/.emacs, you should set the variable as such: ```conf (setq jiralib-url "https://your-site.atlassian.net") ``` If you don't want to enter your credentials (login/password) each time you go to connect, you can add to your ~/.authinfo.gpg or ~/.authinfo file, in a format similar to: ```conf machine your-site.atlassian.net login you@example.com password yourPassword port 80 ``` _Please note that in the authinfo file, port 443 should be specified if your jiralib-url is https._ ## Usage ### Getting Started org-jira mode is easy to use, to get started (after installing this library) try running `M-x org-jira-get-issues`. You should see that it pulls in all issues that are assigned to you. Following that, you can try out some of the org-jira mode commands by visiting one of the files (they're named after your Jira project code, for example, 'EX.org' for a project named 'EX'). ### Keybinds Some of the important keybindings: ```lisp (define-key org-jira-map (kbd "C-c pg") 'org-jira-get-projects) (define-key org-jira-map (kbd "C-c ib") 'org-jira-browse-issue) (define-key org-jira-map (kbd "C-c ig") 'org-jira-get-issues) (define-key org-jira-map (kbd "C-c ih") 'org-jira-get-issues-headonly) (define-key org-jira-map (kbd "C-c iu") 'org-jira-update-issue) (define-key org-jira-map (kbd "C-c iw") 'org-jira-progress-issue) (define-key org-jira-map (kbd "C-c in") 'org-jira-progress-issue-next) (define-key org-jira-map (kbd "C-c ia") 'org-jira-assign-issue) (define-key org-jira-map (kbd "C-c ir") 'org-jira-refresh-issue) (define-key org-jira-map (kbd "C-c iR") 'org-jira-refresh-issues-in-buffer) (define-key org-jira-map (kbd "C-c ic") 'org-jira-create-issue) (define-key org-jira-map (kbd "C-c ik") 'org-jira-copy-current-issue-key) (define-key org-jira-map (kbd "C-c sc") 'org-jira-create-subtask) (define-key org-jira-map (kbd "C-c sg") 'org-jira-get-subtasks) (define-key org-jira-map (kbd "C-c cc") 'org-jira-add-comment) (define-key org-jira-map (kbd "C-c cu") 'org-jira-update-comment) (define-key org-jira-map (kbd "C-c wu") 'org-jira-update-worklogs-from-org-clocks) (define-key org-jira-map (kbd "C-c tj") 'org-jira-todo-to-jira) (define-key org-jira-map (kbd "C-c if") 'org-jira-get-issues-by-fixversion) ``` ### Customization You can define your own streamlined issue progress flow as such: ```lisp (defconst org-jira-progress-issue-flow '(("To Do" . "In Progress" ("In Progress" . "Done")))) ``` or using typical Emacs customize options, as its a defcustom. This will allow you to quickly progress an issue based on its current status, and what the next status should be. If your Jira is set up to display a status in the issue differently than what is shown in the button on Jira, your alist may look like this (use the labels shown in the org-jira Status when setting it up, or manually work out the workflows being used through standard `C-c iw` options/usage): ```lisp (defconst org-jira-progress-issue-flow '(("To Do" . "Start Progress") ("In Development" . "Ready For Review") ("Code Review" . "Done") ("Done" . "Reopen"))) ``` #### Authorization workaround (NOT secure) If your Jira instance has disabled basic auth, you can still get in by copying your web browser's cookie (open up developer console, and right click and 'Copy request as cURL', then copy/paste the cookie into the jiralib-token variable): ```lisp (defconst jiralib-token (cons "Cookie" . "eyJ, or file an issue here on https://github.com/ahungry/org-jira. ### License GPLv3 ================================================ FILE: jiralib.el ================================================ ;;; jiralib.el -- Provide connectivity to JIRA SOAP/REST services. ;; Copyright (C) 2016,2017 Matthew Carter ;; Copyright (C) 2011 Bao Haojun ;; original Copyright (C) 2009 Alex Harsanyi ;; Also, used some code from jira.el, which use xml-rpc instead of soap. ;; Thus Copyright (C) for jira.el related code: ;; Brian Zwahr ;; Dave Benjamin ;; Authors: ;; Matthew Carter ;; Bao Haojun ;; Alex Harsanyi ;; Maintainer: Matthew Carter ;; Version: 3.0.0 ;; Homepage: https://github.com/ahungry/org-jira ;; 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 this program. If not, see ;; or write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;; 02110-1301, USA. ;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com) ;; Created: December, 2009 ;; Keywords: soap, web-services, jira ;; Homepage: http://code.google.com/p/emacs-soap-client ;;; Commentary: ;; This file provides a programatic interface to JIRA. It provides access to ;; JIRA from other programs, but no user level functionality. ;; Jira References: ;; Primary reference (on current Jira, only REST is supported): ;; https://developer.atlassian.com/jiradev/jira-apis/jira-rest-apis ;; Full API list reference: ;; https://docs.atlassian.com/jira/REST/cloud/ ;; Legacy reference (unsupported and deprecated/unavailable): ;; http://confluence.atlassian.com/display/JIRA/Creating+a+SOAP+Client ;; JavaDoc for the Jira SOAP service ;; http://docs.atlassian.com/software/jira/docs/api/rpc-jira-plugin/latest/com/atlassian/jira/rpc/soap/JiraSoapService.html ;;; News: ;;;; Changes since 2.6.3: ;; - Add worklog import filter and control variable for external worklogs. ;; - Add the worklog related endpoint/calls. ;;;; Changes since 2.1.0: ;; - Remove os_username / os_password manual http request as part of sign in process ;; This produces sysadmin level warnings on Jira when these are used under the latest Jira. ;; - Remove unused function jiralib-link-issue ;; - Bring version up to match org-jira version so they can share tag ;;;; Changes since 2.0.0: ;; - Allow issue type query by project ;;;; Changes since 0.0.0: ;; - Converted many calls to async ;; - Converted many calls to make use of caching ;;; Code: (eval-when-compile (require 'cl)) (require 'soap-client) (require 'request) (require 'json) (require 'url-parse) (require 'url-util) (defconst jiralib-version "3.0.0" "Current version of jiralib.el.") (defgroup jiralib nil "Jiralib customization group." :group 'applications) (defgroup jiralib-faces nil "Faces for displaying Jiralib information." :group 'jiralib) (defcustom jiralib-use-restapi t "Use restapi instead of soap." :group 'jiralib :type 'boolean :initialize 'custom-initialize-set) (defcustom jiralib-host "" "User customizable host name of the Jiralib server. This will be used with USERNAME to compute password from .authinfo file. Will be calculated from jiralib-url if not set." :group 'jiralib :type 'string :initialize 'custom-initialize-set) (defface jiralib-issue-info-face '((t (:foreground "black" :background "yellow4"))) "Base face for issue information." :group 'jiralib-faces) (defface jiralib-issue-info-header-face '((t (:bold t :inherit 'jiralib-issue-info-face))) "Base face for issue headers." :group 'jiralib-faces) (defface jiralib-issue-summary-face '((t (:bold t))) "Base face for issue summary." :group 'jiralib-faces) (defface jiralib-comment-face '((t (:background "gray23"))) "Base face for comments." :group 'jiralib-faces) (defface jiralib-comment-header-face '((t (:bold t))) "Base face for comment headers." :group 'jiralib-faces) (defface jiralib-link-issue-face '((t (:underline t))) "Face for linked issues." :group 'jiralib-faces) (defface jiralib-link-project-face '((t (:underline t))) "Face for linked projects" :group 'jiralib-faces) (defface jiralib-link-filter-face '((t (:underline t))) "Face for linked filters" :group 'jiralib-faces) (defvar jiralib-mode-hook nil) (defvar jiralib-mode-map nil) (defvar jiralib-issue-regexp "\\<\\(?:[A-Za-z0-9]+\\)-[0-9]+\\>") (defcustom jiralib-wsdl-descriptor-url "" "The location for the WSDL descriptor for the JIRA service. This is specific to your local JIRA installation. The URL is typically: http://YOUR_INSTALLATION/rpc/soap/jirasoapservice-v2?wsdl The default value works if JIRA is located at a hostname named 'jira'." :type 'string :group 'jiralib) (defcustom jiralib-url "http://localhost:8081/" "The address of the jira host." :type 'string :group 'jiralib) (defcustom jiralib-agile-page-size 50 "Page size for agile API retrieve. Limited by server property jira.search.views.default.max" :type 'integer :group 'jiralib) (defvar jiralib-token nil "JIRA token used for authentication.") (defvar jiralib-rest-auth-head nil "JIRA restapi auth head.") (defvar jiralib-user-login-name nil "The name of the user logged into JIRA. This is maintained by `jiralib-login'.") (defvar jiralib-wsdl nil) (defcustom jiralib-worklog-import--filters-alist (list '(nil "WorklogUpdatedByCurrentUser" (lambda (wl) (let-alist wl (when (and wl (string-equal (downcase (or jiralib-user-login-name user-login-name)) (downcase .updateAuthor.name))) wl)))) '(nil "WorklogAuthoredByCurrentUser" (lambda (wl) (let-alist wl (when (and wl (string-equal (downcase (or jiralib-user-login-name user-login-name)) (downcase .author.name))) wl))))) "A list of triplets: ('Global-Enable 'Descriptive-Label 'Function-Definition) that apply worklog predicate filters during import. Example: (list '('t \"descriptive-predicate-label\" (lambda (x) x)))" :type '(repeat (list boolean string function)) :group 'org-jira) (defun jiralib-load-wsdl () "Load the JIRA WSDL descriptor." (setq jiralib-wsdl (soap-load-wsdl-from-url (if (string-equal jiralib-wsdl-descriptor-url "") (concat jiralib-url "/rpc/soap/jirasoapservice-v2?wsdl") jiralib-wsdl-descriptor-url)))) (defun jiralib-login (username password) "Login into JIRA as user USERNAME with PASSWORD. After a successful login, store the authentication token in `jiralib-token'." ;; NOTE that we cannot rely on `jiralib-call' because `jiralib-call' relies on ;; us ;-) (interactive (if (> 24 emacs-major-version) (let ((user (read-string "Username for Jira server login? ")) (password (read-passwd "Password for Jira server login? "))) (list user password)) (let ((found (nth 0 (auth-source-search :max 1 :host (if (string= jiralib-host "") (url-host (url-generic-parse-url jiralib-url)) jiralib-host) ;; secrets.el wouldn’t accept a number. :port (number-to-string (url-port (url-generic-parse-url jiralib-url))) :require '(:user :secret) :create t))) user secret) (when found (setq user (plist-get found :user) secret (let ((sec (plist-get found :secret))) (if (functionp sec) (funcall sec) sec))) (list user secret))))) (if jiralib-use-restapi (setq jiralib-token `("Authorization" . , (format "Basic %s" (base64-encode-string (concat username ":" password))))) (unless jiralib-wsdl (jiralib-load-wsdl)) (setq jiralib-token (car (soap-invoke jiralib-wsdl "jirasoapservice-v2" "login" username password)))) (setq jiralib-user-login-name username)) (defvar jiralib-complete-callback nil) (defun jiralib-call (method callback &rest params) "Invoke the Jira METHOD, then CALLBACK with supplied PARAMS. This function should be used for all JIRA interface calls, as the method ensures the user is logged in and invokes `soap-invoke' with the correct service name and authentication token. All JIRA interface methods take an authentication token as the first argument. The authentication token is supplied by this function, so PARAMS should omit this parameter. For example, the \"getIssue\" method takes two parameters: auth and key, however, when invoking it through `jiralib-call', the call should be: (jiralib-call \"getIssue\" KEY) CALLBACK should be the post processing function to run with the completed data from the request result, which can be accessed with: (getf data :data) as such, the CALLBACK should follow this type of form: (cl-function (lambda (&rest data &allow-other-keys) (print (getf data :data)))) If CALLBACK is set to nil then the request will occur with sync. This produces a noticeable slowdown and is not recommended by request.el, so if at all possible, it should be avoided." ;; @todo :auth: Probably pass this all the way down, but I think ;; it may be OK at the moment to just set the variable each time. (setq jiralib-complete-callback ;; Don't run with async if we don't have a login token yet. (if jiralib-token callback nil)) ;; If we don't have a regex set, ensure it is set BEFORE any async ;; calls are processing, or we're going to have a bad time. ;; This should only end up running once per session. (unless jiralib-issue-regexp (let ((projects (mapcar (lambda (e) (downcase (cdr (assoc 'key e)))) (append (jiralib--rest-call-it "/rest/api/2/project" :params '((expand . "description,lead,url,projectKeys"))) nil) ))) (when projects (setq jiralib-issue-regexp (concat "\\<" (regexp-opt projects) "-[0-9]+\\>"))))) (if (not jiralib-use-restapi) (car (apply 'jiralib--call-it method params)) (unless jiralib-token (call-interactively 'jiralib-login)) (case (intern method) ('getStatuses (jiralib--rest-call-it "/rest/api/2/status")) ('getIssueTypes (jiralib--rest-call-it "/rest/api/2/issuetype")) ('getIssueTypesByProject (let ((response (jiralib--rest-call-it (format "/rest/api/2/project/%s" (first params))))) (cl-coerce (cdr (assoc 'issueTypes response)) 'list))) ('getUser (jiralib--rest-call-it "/rest/api/2/user" :params `((username . ,(first params))))) ('getVersions (jiralib--rest-call-it (format "/rest/api/2/project/%s/versions" (first params)))) ;; Worklog calls ('getWorklogs (jiralib--rest-call-it (format "/rest/api/2/issue/%s/worklog" (first params)))) ('addWorklog (jiralib--rest-call-it (format "/rest/api/2/issue/%s/worklog" (first params)) :type "POST" :data (json-encode (second params)))) ('updateWorklog (jiralib--rest-call-it (format "/rest/api/2/issue/%s/worklog/%s" (first params) (second params)) :type "PUT" :data (json-encode (third params)))) ('addWorklogAndAutoAdjustRemainingEstimate (jiralib--rest-call-it (format "/rest/api/2/issue/%s/worklog" (first params)) :type "POST" :data (json-encode (second params)))) ('addComment (jiralib--rest-call-it (format "/rest/api/2/issue/%s/comment" (first params)) :type "POST" :data (json-encode (second params)))) ('createIssue ;; Creating the issue doesn't return it, a second call must be ;; made to pull it in by using the self key in response. (let ((response (jiralib--rest-call-it "/rest/api/2/issue" :type "POST" :data (json-encode (first params))))) (jiralib--rest-call-it (cdr (assoc 'self response)) :type "GET") )) ('createIssueWithParent (jiralib--rest-call-it )) ('editComment (jiralib--rest-call-it (format "/rest/api/2/issue/%s/comment/%s" (first params) (second params)) :data (json-encode `((body . ,(third params)))) :type "PUT")) ('getBoard (jiralib--rest-call-it (format "/rest/agile/1.0/board/%s" (first params)))) ('getBoards (apply 'jiralib--agile-call-it "/rest/agile/1.0/board" 'values params)) ('getComment (org-jira-find-value (jiralib--rest-call-it (format "/rest/api/2/issue/%s/comment/%s" (first params) (second params))) 'comments)) ('getComments (org-jira-find-value (jiralib--rest-call-it (format "/rest/api/2/issue/%s/comment" (first params))) 'comments)) ('getAttachmentsFromIssue (org-jira-find-value (jiralib--rest-call-it (format "/rest/api/2/issue/%s?fields=attachment" (first params))) 'comments)) ('getComponents (jiralib--rest-call-it (format "/rest/api/2/project/%s/components" (first params)))) ('getIssue (jiralib--rest-call-it (format "/rest/api/2/issue/%s" (first params)))) ('getIssuesFromBoard (apply 'jiralib--agile-call-it (format "rest/agile/1.0/board/%d/issue" (first params)) 'issues (cdr params))) ('getIssuesFromJqlSearch (append (cdr ( assoc 'issues (jiralib--rest-call-it "/rest/api/2/search" :type "POST" :data (json-encode `((jql . ,(first params)) (maxResults . ,(second params))))))) nil)) ('getPriorities (jiralib--rest-call-it "/rest/api/2/priority")) ('getProjects (jiralib--rest-call-it "rest/api/2/project")) ('getProjectsNoSchemes (append (jiralib--rest-call-it "/rest/api/2/project" :params '((expand . "description,lead,url,projectKeys"))) nil)) ('getResolutions (append (jiralib--rest-call-it "/rest/api/2/resolution") nil)) ('getAvailableActions (mapcar (lambda (trans) `(,(assoc 'name trans) ,(assoc 'id trans))) (cdadr (jiralib--rest-call-it (format "/rest/api/2/issue/%s/transitions" (first params)))))) ('getFieldsForAction (org-jira-find-value (car (let ((issue (first params)) (action (second params))) (seq-filter (lambda (trans) (or (string-equal action (org-jira-find-value trans 'id)) (string-equal action (org-jira-find-value trans 'name)))) (cdadr (jiralib--rest-call-it (format "/rest/api/2/issue/%s/transitions" (first params)) :params '((expand . "transitions.fields"))))))) 'fields)) ('progressWorkflowAction (jiralib--rest-call-it (format "/rest/api/2/issue/%s/transitions" (first params)) :type "POST" :data (json-encode `(,(car (second params)) ,(car (third params)))))) ('getUsers (jiralib--rest-call-it (format "/rest/api/2/user/assignable/search?project=%s&maxResults=10000" (first params)) :type "GET")) ('updateIssue (jiralib--rest-call-it (format "/rest/api/2/issue/%s" (first params)) :type "PUT" :data (json-encode `((fields . ,(second params))))))))) (defun jiralib--soap-call-it (&rest args) "Deprecated SOAP call endpoint. Will be removed soon. Pass ARGS to jiralib-call." (let ((jiralib-token nil) (jiralib-use-restapi nil)) (apply #'jiralib-call args))) (defun jiralib--rest-call-it (api &rest args) "Invoke the corresponding jira rest method API. Invoking COMPLETE-CALLBACK when the JIRALIB-COMPLETE-CALLBACK is non-nil, request finishes, and passing ARGS to REQUEST." (append (request-response-data (apply #'request (if (string-match "^http[s]*://" api) api ;; If an absolute path, use it (concat (replace-regexp-in-string "/*$" "/" jiralib-url) (replace-regexp-in-string "^/*" "" api))) :sync (not jiralib-complete-callback) :headers `(,jiralib-token ("Content-Type" . "application/json")) :parser 'json-read :complete jiralib-complete-callback args)) nil)) (defun jiralib--call-it (method &rest params) "Invoke the JIRA METHOD with supplied PARAMS. Internal use, returns a list of responses, of which only the first is normally used." (when (symbolp method) (setq method (symbol-name method))) (unless jiralib-token (call-interactively 'jiralib-login)) (condition-case data (apply 'soap-invoke jiralib-wsdl "jirasoapservice-v2" method jiralib-token params) (soap-error ;; If we are here, we had a token, but it expired. Re-login and try ;; again. (setq jiralib-token nil) (call-interactively 'jiralib-login) (apply 'soap-invoke jiralib-wsdl "jirasoapservice-v2" method jiralib-token params)))) ;;;; Some utility functions (defun jiralib-make-list (data field) "Map all assoc elements in DATA to the value of FIELD in that element." (loop for element in data collect (cdr (assoc field element)))) (defun jiralib-make-assoc-list (data key-field value-field) "Create an association list from a SOAP structure array. DATA is a list of association lists (a SOAP array-of type) KEY-FIELD is the field to use as the key in the returned alist VALUE-FIELD is the field to use as the value in the returned alist" (loop for element in data collect (cons (cdr (assoc key-field element)) (cdr (assoc value-field element))))) (defun jiralib-make-remote-field-values (fields) "Transform the (KEY . VALUE) list FIELDS into a RemoteFieldValue structure. Each (KEY . VALUE) pair is transformed into ((id . KEY) (values . (VALUE))) This method exists because Several JIRA methods require a RemoteFieldValue list, but it is easier to work with ALISTS in emacs-lisp" (let ((remote-field-values)) ;; we accept an ALIST of field-name field-values parameter, but we need to ;; construct a structure that encodes as a RemoteFieldValue which is what ;; updateIssue wants (dolist (field fields) (let ((name (car field)) (value (cdr field))) (when (symbolp name) (setq name (symbol-name name))) ;; Value must be an "array" (for which soap-client accepts lists) even ;; if it is just one value (unless (vectorp value) (setq value (vector value))) (push `((id . ,name) (values . ,value)) remote-field-values))) (apply 'vector (nreverse remote-field-values)))) ;;;; Wrappers around JIRA methods (defun jiralib--rest-api-for-issue-key (key) "Return jira rest api for issue KEY." (concat "rest/api/2/issue/" key)) (defun jiralib-update-issue (key fields &optional callback) "Update the issue with id KEY with the values in FIELDS, invoking CALLBACK." (jiralib-call "updateIssue" callback key (if jiralib-use-restapi fields (jiralib-make-remote-field-values fields)))) (defvar jiralib-status-codes-cache nil) (defun jiralib-get-statuses () "Return an assoc list mapping a status code to its name. NOTE: Status codes are stored as strings, not numbers. This function will only ask JIRA for the list of codes once, then will cache it." (unless jiralib-status-codes-cache (setq jiralib-status-codes-cache (jiralib-make-assoc-list (jiralib-call "getStatuses" nil) 'id 'name))) jiralib-status-codes-cache) (defvar jiralib-issue-types-cache nil) (defun jiralib-get-issue-types () "Return an assoc list mapping an issue type code to its name. NOTE: Issue type codes are stored as strings, not numbers. This function will only ask JIRA for the list of codes once, than will cache it. The issue types returned via getIssueTypes are all the ones available to the user, but not necessarily available to the given project. This endpoint is essentially a master reference for when issue types need a name lookup when given an id. For applying issue types to a given project that is being created, see the #'jiralib-get-issue-types-by-project call." (unless jiralib-issue-types-cache (setq jiralib-issue-types-cache (jiralib-make-assoc-list (jiralib-call "getIssueTypes" nil) 'id 'name))) jiralib-issue-types-cache) (defvar jiralib-issue-types-by-project-cache nil "An alist of available issue types.") (defun jiralib-get-issue-types-by-project (project) "Return the available issue types for PROJECT. PROJECT should be the key, such as `EX' or `DEMO'." (unless (assoc project jiralib-issue-types-by-project-cache) (push (cons project (jiralib-make-assoc-list (jiralib-call "getIssueTypesByProject" nil project) 'id 'name)) jiralib-issue-types-by-project-cache)) (cdr (assoc project jiralib-issue-types-by-project-cache))) (defvar jiralib-priority-codes-cache nil) (defun jiralib-get-priorities () "Return an assoc list mapping a priority code to its name. NOTE: Priority codes are stored as strings, not numbers. This function will only ask JIRA for the list of codes once, than will cache it." (unless jiralib-priority-codes-cache (setq jiralib-priority-codes-cache (jiralib-make-assoc-list (jiralib-call "getPriorities" nil) 'id 'name))) jiralib-priority-codes-cache) (defvar jiralib-resolution-code-cache nil) (defun jiralib-get-resolutions () "Return an assoc list mapping a resolution code to its name. NOTE: Resolution codes are stored as strings, not numbers. This function will only ask JIRA for the list of codes once, than will cache it." (unless jiralib-resolution-code-cache (setq jiralib-resolution-code-cache (jiralib-make-assoc-list (jiralib-call "getResolutions" nil) 'id 'name))) jiralib-resolution-code-cache) ;; NOTE: it is not such a good idea to use this, as it needs a JIRA ;; connection to construct the regexp (the user might be prompted for a JIRA ;; username and password). ;; ;; The best use of this function is to generate the regexp once-off and ;; persist it somewhere. ;; ;; FIXME: Probably just deprecate/remove this, we can assert we're on ;; an issue with a general regexp that matches the common format, vs ;; needing to know specific user project list. (defun jiralib-get-issue-regexp () "Return a regexp that will match an issue id. The regexp is constructed from the project keys in the JIRA database. An issue is assumed to be in the format KEY-NUMBER, where KEY is a project key and NUMBER is the issue number." (unless jiralib-issue-regexp (let ((projects (mapcar (lambda (e) (downcase (cdr (assoc 'key e)))) (jiralib-call "getProjectsNoSchemes" nil)))) (when projects (setq jiralib-issue-regexp (concat "\\<" (regexp-opt projects) "-[0-9]+\\>"))))) jiralib-issue-regexp) (defun jiralib-do-jql-search (jql &optional limit callback) "Run a JQL query and return the list of issues that matched. LIMIT is the maximum number of queries to return. Note that JIRA has an internal limit of how many queries to return, as such, it might not be possible to find *ALL* the issues that match a query." (unless (or limit (numberp limit)) (setq limit 100)) (jiralib-call "getIssuesFromJqlSearch" callback jql limit)) (defcustom jiralib-available-actions-cache-p t "Set to t to enable caching for jiralib-get-available-actions. If nil, will disable caching for this endpoint. Possible side-effects: - If the server has the project workflow updated, the cache saved here will be incorrect. - If the issue is not up to date with the remote, the wrong cache key may be queried." :type 'boolean :group 'jiralib) (defvar jiralib-available-actions-cache nil "An alist of available actions.") (defun jiralib-get-available-actions (issue-key &optional status) "Return the available workflow actions for ISSUE-KEY. This uses STATUS as the cache key. This runs the getAvailableActions SOAP method." (if (and jiralib-available-actions-cache-p status) (progn (unless (assoc status jiralib-available-actions-cache) (push (cons status (jiralib-make-assoc-list (mapcar (lambda (x) (let ((namestring (cdr (car x))) (id (cdr x))) (cons (cons 'name (org-jira-decode namestring)) id))) (jiralib-call "getAvailableActions" nil issue-key)) 'id 'name)) jiralib-available-actions-cache)) (cdr (assoc status jiralib-available-actions-cache))) (progn (jiralib-make-assoc-list (mapcar (lambda (x) (let ((namestring (cdr (car x))) (id (cdr x))) (cons (cons 'name (org-jira-decode namestring)) id))) (jiralib-call "getAvailableActions" nil issue-key)) 'id 'name)))) (defcustom jiralib-fields-for-action-cache-p t "Set to t to enable caching for jiralib-get-fields-for-action. If nil, will disable caching for this endpoint. Possible side-effects: - If many tasks have different workflows, you may want to disable this." :type 'boolean :group 'jiralib) (defvar jiralib-fields-for-action-cache nil "An alist of available fields.") (defun jiralib-get-fields-for-action-with-cache (issue-key action-id) "Return the required fields to change ISSUE-KEY to ACTION-ID." (if (and jiralib-fields-for-action-cache-p action-id) (progn (unless (assoc action-id jiralib-fields-for-action-cache) (push (cons action-id (jiralib-call "getFieldsForAction" nil issue-key action-id)) jiralib-fields-for-action-cache)) (cdr (assoc action-id jiralib-fields-for-action-cache))) (jiralib-call "getFieldsForAction" nil issue-key action-id))) (defun jiralib-get-fields-for-action (issue-key action-id) "Return the required fields to change ISSUE-KEY to ACTION-ID." (if jiralib-use-restapi (let ((fields (jiralib-get-fields-for-action-with-cache issue-key action-id))) (mapcar (lambda (field) (cons (symbol-name (car field)) (format "%s (required: %s)" (org-jira-find-value field 'name) (if (eq (org-jira-find-value field 'required) :json-false) "nil" "t")))) fields)) (jiralib-make-assoc-list (jiralib-get-fields-for-action-with-cache issue-key action-id) 'id 'name))) (defun jiralib-progress-workflow-action (issue-key action-id params &optional callback) "Progress issue with ISSUE-KEY to action ACTION-ID, and provide the needed PARAMS. When CALLBACK is present, this will run async." (if jiralib-use-restapi (jiralib-call "progressWorkflowAction" callback issue-key `((transition (id . ,action-id))) `((fields . ,params))) (jiralib-call "progressWorkflowAction" callback issue-key action-id (jiralib-make-remote-field-values params)))) (defun jiralib-format-datetime (&optional datetime) "Convert a mixed DATETIME format into the Jira required datetime format. This will produce a datetime string such as: 2010-02-05T14:30:00.000+0000 for being consumed in the Jira API. If DATETIME is not passed in, it will default to the current time." (let* ((defaults (format-time-string "%Y-%m-%d %H:%M:%S" (current-time))) (datetime (concat datetime (subseq defaults (length datetime)))) (parts (parse-time-string datetime))) (format "%04d-%02d-%02dT%02d:%02d:%02d.000+0000" (nth 5 parts) (nth 4 parts) (nth 3 parts) (nth 2 parts) (nth 1 parts) (nth 0 parts)))) (defvar jiralib-worklog-coming-soon-message "WORKLOG FEATURES ARE NOT IMPLEMENTED YET, COMING SOON!") (defun jiralib-add-worklog-and-autoadjust-remaining-estimate (issue-key start-date time-spent comment) "Log time spent on ISSUE-KEY to its worklog. The time worked begins at START-DATE and has a TIME-SPENT duration. JIRA will automatically update the remaining estimate by subtracting TIME-SPENT from it. START-DATE should be in the format 2010-02-05T14:30:00Z TIME-SPENT can be in one of the following formats: 10m, 120m hours; 10h, 120h days; 10d, 120d weeks. COMMENT will be added to this worklog." (let ((formatted-start-date (jiralib-format-datetime start-date))) (jiralib-call "addWorklogAndAutoAdjustRemainingEstimate" nil issue-key ;; Expects data such as: '{"timeSpent":"1h", "started":"2017-02-21T00:00:00.000+0000", "comment":"woot!"}' ;; and only that format will work (no loose formatting on the started date) `((started . ,formatted-start-date) (timeSpent . ,time-spent) (comment . ,comment))))) ;;;; Issue field accessors (defun jiralib-issue-key (issue) "Return the key of ISSUE." (cdr (assoc 'key issue))) (defun jiralib-issue-owner (issue) "Return the owner of ISSUE." (cdr (assq 'assignee issue))) (defun jiralib-issue-status (issue) "Return the status of ISSUE as a status string (not as a number!)." (let ((status-code (cdr (assq 'status issue)))) (cdr (assoc status-code (jiralib-get-statuses))))) (defun jiralib-custom-field-value (custom-field issue) "Return the value of CUSTOM-FIELD for ISSUE. Return nil if the field is not found" (catch 'found (dolist (field (cdr (assq 'customFieldValues issue))) (when (equal (cdr (assq 'customfieldId field)) custom-field) (throw 'found (cadr (assq 'values field))))))) (defvar jiralib-current-issue nil "This holds the currently selected issue.") (defvar jiralib-projects-list nil "This holds a list of projects and their details.") (defvar jiralib-types nil "This holds a list of issues types.") (defvar jiralib-priorities nil "This holds a list of priorities.") (defvar jiralib-user-fullnames nil "This holds a list of user fullnames.") (defun jiralib-get-project-name (key) "Return the name of the JIRA project with id KEY." (let ((projects jiralib-projects-list) (name nil)) (dolist (project projects) (if (equal (cdr (assoc 'key project)) key) (setf name (cdr (assoc 'name project))))) name)) (defun jiralib-get-type-name (id) "Return the name of the issue type with ID." (let ((types jiralib-types) (name nil)) (dolist (type types) (if (equal (cdr (assoc 'id type)) id) (setf name (cdr (assoc 'name type))))) name)) (defun jiralib-get-user-fullname (username) "Return the full name (display name) of the user with USERNAME." (if (assoc username jiralib-user-fullnames) (cdr (assoc username jiralib-user-fullnames)) (progn (let ((user (jiralib-get-user username))) (setf jiralib-user-fullnames (append jiralib-user-fullnames (list (cons username (cdr (assoc 'fullname user)))))) (cdr (assoc 'fullname user)))))) (defun jiralib-get-filter (filter-id) "Return a filter given its FILTER-ID." (cl-flet ((id-match (filter) (equal filter-id (cdr (assoc 'id filter))))) (cl-find-if 'id-match (jiralib-get-saved-filters)))) (defun jiralib-get-filter-alist () "Return an association list mapping filter names to IDs." (mapcar (lambda (filter) (cons (cdr (assoc 'name filter)) (cdr (assoc 'id filter)))) (jiralib-get-saved-filters))) (defun jiralib-add-comment (issue-key comment &optional callback) "Add to issue with ISSUE-KEY the given COMMENT, invoke CALLBACK." (jiralib-call "addComment" callback issue-key `((body . ,comment)))) (defun jiralib-edit-comment (issue-id comment-id comment &optional callback) "Edit ISSUE-ID's comment COMMENT-ID to reflect the new COMMENT, invoke CALLBACK." (if (not jiralib-use-restapi) (jiralib-call "editComment" callback `((id . ,comment-id) (body . ,comment))) (jiralib-call "editComment" callback issue-id comment-id comment))) (defun jiralib-create-issue (issue) "Create a new ISSUE in JIRALIB. ISSUE is a Hashtable object." (jiralib-call "createIssue" nil issue)) (defun jiralib-create-subtask (subtask parent-issue-id) "Create SUBTASK for issue with PARENT-ISSUE-ID. SUBTASK is a Hashtable object." (jiralib-call "createIssueWithParent" nil subtask parent-issue-id)) (defvar jiralib-subtask-types-cache nil) (defun jiralib-get-subtask-types () "Return an assoc list mapping an issue type code to its name. NOTE: Issue type codes are stored as strings, not numbers. This function will only ask JIRA for the list of codes once, than will cache it." (unless jiralib-subtask-types-cache (setq jiralib-subtask-types-cache (jiralib-make-assoc-list (jiralib-call "getSubTaskIssueTypes" nil) 'id 'name))) jiralib-subtask-types-cache) (defun jiralib-get-comment (issue-key comment-id &optional callback) "Return all comments associated with issue ISSUE-KEY, invoking CALLBACK." (jiralib-call "getComment" callback issue-key comment-id)) (defun jiralib-get-comments (issue-key &optional callback) "Return all comments associated with issue ISSUE-KEY, invoking CALLBACK." (jiralib-call "getComments" callback issue-key)) (defun jiralib-get-attachments (issue-key &optional callback) "Return all attachments associated with issue ISSUE-KEY, invoking CALLBACK." (jiralib-call "getAttachmentsFromIssue" callback issue-key)) (defun jiralib-get-worklogs (issue-key &optional callback) "Return all worklogs associated with issue ISSUE-KEY, invoking CALLBACK." (jiralib-call "getWorklogs" callback issue-key)) (defun jiralib-add-worklog (issue-id started time-spent-seconds comment &optional callback) "Add the worklog linked to ISSUE-ID. Requires STARTED (a jira datetime), TIME-SPENT-SECONDS (integer) and a COMMENT. CALLBACK will be invoked if passed in upon endpoint completion." ;; Call will fail if 0 seconds are set as the time, so always do at least one min. (setq time-spent-seconds (max 60 time-spent-seconds)) (let ((worklog `((started . ,started) ;; @todo :worklog: timeSpentSeconds changes into incorrect values ;; in the Jira API (for instance, 89600 = 1 day, but Jira thinks 3 days... ;; We should convert to a Xd Xh Xm format from our seconds ourselves. (timeSpentSeconds . ,time-spent-seconds) (comment . ,comment)))) (jiralib-call "addWorklog" callback issue-id worklog))) (defun jiralib-update-worklog (issue-id worklog-id started time-spent-seconds comment &optional callback) "Update the worklog linked to ISSUE-ID and WORKLOG-ID. Requires STARTED (a jira datetime), TIME-SPENT-SECONDS (integer) and a COMMENT. CALLBACK will be invoked if passed in upon endpoint completion." ;; Call will fail if 0 seconds are set as the time, so always do at least one min. (setq time-spent-seconds (max 60 time-spent-seconds)) (let ((worklog `((started . ,started) ;; @todo :worklog: timeSpentSeconds changes into incorrect values ;; in the Jira API (for instance, 89600 = 1 day, but Jira thinks 3 days... ;; We should convert to a Xd Xh Xm format from our seconds ourselves. (timeSpentSeconds . ,time-spent-seconds) (comment . ,comment)))) (jiralib-call "updateWorklog" callback issue-id worklog-id worklog))) (defvar jiralib-components-cache nil "An alist of project components.") (defun jiralib-get-components (project-key) "Return all components available in the project PROJECT-KEY." (unless (assoc project-key jiralib-components-cache) (push (cons project-key (jiralib-make-assoc-list (jiralib-call "getComponents" nil project-key) 'id 'name)) jiralib-components-cache)) (cdr (assoc project-key jiralib-components-cache))) (defun jiralib-get-issue (issue-key &optional callback) "Get the issue with key ISSUE-KEY, running CALLBACK after." (jiralib-call "getIssue" callback issue-key)) (defun jiralib-get-issues-from-filter (filter-id) "Get the issues from applying saved filter FILTER-ID." (message "jiralib-get-issues-from-filter is NOT IMPLEMENTED!! Do not use!") (jiralib-call "getIssuesFromFilter" nil filter-id)) (defun jiralib-get-issues-from-text-search (search-terms) "Find issues using free text search SEARCH-TERMS." (jiralib-call "getIssuesFromTextSearch" nil search-terms)) (defun jiralib-get-issues-from-text-search-with-project (project-keys search-terms max-num-results) "Find issues in projects PROJECT-KEYS, using free text search SEARCH-TERMS. Return no more than MAX-NUM-RESULTS." (jiralib-call "getIssuesFromTextSearchWithProject" nil (apply 'vector project-keys) search-terms max-num-results)) ;; Modified by Brian Zwahr to use getProjectsNoSchemes instead of getProjects (defun jiralib-get-projects () "Return a list of projects available to the user." (if jiralib-projects-list jiralib-projects-list (setq jiralib-projects-list (if jiralib-use-restapi (jiralib-call "getProjects" nil) (jiralib-call "getProjectsNoSchemes" nil))))) (defun jiralib-get-saved-filters () "Get all saved filters available for the currently logged in user." (jiralib-make-assoc-list (jiralib-call "getSavedFilters" nil) 'id 'name)) (defun jiralib-get-server-info () "Return the Server information such as baseUrl, version, edition, buildDate, buildNumber." (jiralib-call "getServerInfo" nil)) (defun jiralib-get-sub-task-issue-types () "Return all visible subtask issue types in the system." (jiralib-call "getSubTaskIssueTypes" nil)) (defun jiralib-get-user (username) "Return a user's information given their USERNAME." (cond ((eq 0 (length username)) nil) ;; Unassigned (t (jiralib-call "getUser" nil username)))) (defvar jiralib-users-cache nil "Cached list of users.") (defun jiralib-get-users (project-key) "Return assignable users information given the PROJECT-KEY." (unless jiralib-users-cache (setq jiralib-users-cache (jiralib-call "getUsers" nil project-key))) jiralib-users-cache) (defun jiralib-get-versions (project-key) "Return all versions available in project PROJECT-KEY." (jiralib-call "getVersions" nil project-key)) (defun jiralib-strip-cr (string) "Remove carriage returns from STRING." (when string (replace-regexp-in-string "\r" "" string))) (defun jiralib-worklog-import--filter-apply (worklog-obj &optional predicate-fn-lst unwrap-worklog-records-fn rewrap-worklog-records-fn) "Remove non-matching org-jira issue worklogs. Variables: WORKLOG-OBJ is the passed in object PREDICATE-FN-LST is the list of lambdas used as match predicates. UNWRAP-WORKLOG-RECORDS-FN is the function used to produce the list of worklog records from within the worklog-obj REWRAP-WORKLOG-RECORDS-FN is the function used to reshape the worklog records back into the form they were received in. Auxiliary Notes: Only the WORKLOG-OBJ variable is required. The value of PPREDICATE-FN-LST is filled from the jiralib-worklog-import--filters-alist variable by default. If PREDICATE-FN-LST is empty the unmodified value of WORKLOG-OBJ is returned. If PREDICATE-FN-LST contains multiple predicate functions, each predicate filters operates as a clause in an AND match. In effect, a worklog must match all predicates to be returned. The variable 'jiralib-user-login-name is used by many lambda filters." (let ((unwrap-worklog-records-fn) (rewrap-worklog-records-fn) (predicate-fn-lst) (worklogs worklog-obj) (predicate-fn)) ;; let-body (progn (setq unwrap-worklog-records-fn (if (and (boundp 'unwrap-worklog-records-fn) (functionp unwrap-worklog-records-fn)) unwrap-worklog-records-fn (lambda (x) (coerce x 'list)))) (setq rewrap-worklog-records-fn (if (and (boundp 'rewrap-worklog-records-fn) (functionp rewrap-worklog-records-fn)) rewrap-worklog-records-fn (lambda (x) (remove 'nil (coerce x 'vector))))) (setq predicate-fn-lst (if (and (boundp 'predicate-fn-lst) (not (null predicate-fn-lst)) (listp predicate-fn-lst)) predicate-fn-lst (mapcar 'caddr (remove 'nil (mapcar (lambda (x) (unless (null (car x)) x)) jiralib-worklog-import--filters-alist))))) ;; final condition/sanity checks before processing (cond ;; pass cases, don't apply filters, return unaltered worklog-obj ((or (not (boundp 'predicate-fn-lst)) (not (listp predicate-fn-lst)) (null predicate-fn-lst)) worklog-obj) ;; default-case, apply worklog filters and return only matching worklogs (t (setq worklogs (funcall unwrap-worklog-records-fn worklogs)) (while (setq predicate-fn (pop predicate-fn-lst)) (setq worklogs (mapcar predicate-fn worklogs))) (funcall rewrap-worklog-records-fn worklogs)))))) (defun jiralib-get-board (id &optional callback) "Return details on given board" (jiralib-call "getBoard" nil id)) (defun jiralib-get-boards () "Return list of jira boards" (jiralib-call "getBoards" nil)) (defun jiralib-get-board-issues (board-id &rest params) "Return list of jira issues in the specified jira board" (apply 'jiralib-call "getIssuesFromBoard" (cl-getf params :callback) board-id params)) (defun jiralib--agile-not-last-entry (num-entries total start-at limit) "Return true if need to retrieve next page from agile api" (and (> num-entries 0) (or (not limit) ; not required to be set (< limit 1) ; ignore invalid limit (> limit start-at)) (or (not total) ; not always returned (> total start-at)))) (defun jiralib--agile-limit-page-size (page-size start-at limit) (if (and limit (> (+ start-at page-size) limit)) (- limit start-at) page-size)) (defun jiralib--agile-rest-call-it (api max-results start-at limit query-params) (let ((callurl (format "%s?%s" api (url-build-query-string (append `((maxResults ,(jiralib--agile-limit-page-size max-results start-at limit)) (startAt ,start-at)) query-params))))) (jiralib--rest-call-it callurl))) (defun jiralib--agile-call-it (api values-key &rest params) "Invoke Jira agile method api and retrieve the results using paging. If JIRALIB-COMPLETE-CALLBACK is non-nil, then the call will be performed asynchronously and JIRALIB-COMPLETE-CALLBACK will be called when all data are retrieved. If JIRALIB-COMPLETE-CALLBACK is nil, then the call will be performed syncronously and this function will return the retrieved data. API - path to called API that must start with /rest/agile/1.0. VALUES-KEY - key of the actual reply data in the reply assoc list. PARAMS - optional additional parameters. :limit - limit total number of retrieved entries. :query-params - extra query parameters in the format of url-build-query-string. " (if jiralib-complete-callback (apply 'jiralib--agile-call-async api values-key params) (apply 'jiralib--agile-call-sync api values-key params))) (defun jiralib--agile-call-sync (api values-key &rest params) "Syncroniously invoke Jira agile method api retrieve all the results using paging and return results. VALUES-KEY - key of the actual reply data in the reply assoc list. PARAMS - extra parameters (as keyword arguments), the supported parameters are: :limit - limit total number of retrieved entries. :query-params - extra query parameters in the format of url-build-query-string. " (setq jiralib-complete-callback nil) (let ((not-last t) (start-at 0) (limit (getf params :limit)) (query-params (getf params :query-params)) ;; maximum page size, 50 is server side maximum (max-results jiralib-agile-page-size) (values ())) (while not-last (let* ((reply-alist (jiralib--agile-rest-call-it api max-results start-at limit query-params)) (values-array (cdr (assoc values-key reply-alist))) (num-entries (length values-array)) (total (cdr (assq 'total reply-alist)))) (setf values (append values (append values-array nil))) (setf start-at (+ start-at num-entries)) (setf not-last (jiralib--agile-not-last-entry num-entries total start-at limit)))) values)) (defun jiralib--agile-call-async (api values-key &rest params) "Asyncroniously invoke Jira agile method api, retrieve all the results using paging and call JIRALIB-COMPLETE_CALLBACK when all the data are retrieved. VALUES-KEY - key of the actual reply data in the reply assoc list. PARAMS - extra parameters (as keyword arguments), the supported parameters are: limit - limit total number of retrieved entries." (lexical-let ((start-at 0) (limit (getf params :limit)) (query-params (getf params :query-params)) ;; maximum page size, 50 is server side maximum (max-results jiralib-agile-page-size) (values-list ()) (vk values-key) (url api) ;; save the call back to be called later after the last page (complete-callback jiralib-complete-callback)) ;; setup new callback to be called after each page (setf jiralib-complete-callback (cl-function (lambda (&rest data &allow-other-keys) (condition-case err (let* ((reply-alist (cl-getf data :data)) (values-array (cdr (assoc vk reply-alist))) (num-entries (length values-array)) (total (cdr (assq 'total reply-alist)))) (setf values-list (append values-list (append values-array nil))) (setf start-at (+ start-at num-entries)) (message "jiralib agile retrieve: got %d values%s%s" start-at (if total " of " "") (if total (int-to-string total) "")) (if (jiralib--agile-not-last-entry num-entries total start-at limit) (jiralib--agile-rest-call-it url max-results start-at limit query-params) ;; last page: call originall callback (message "jiralib agile retrieve: calling callback") (setf jiralib-complete-callback complete-callback) (funcall jiralib-complete-callback :data (list (cons vk values-list))) (message "jiralib agile retrieve: all done"))) ('error (message (format "jiralib agile retrieve: caught error: %s" err))))))) (jiralib--agile-rest-call-it api max-results start-at limit query-params))) (provide 'jiralib) ;;; jiralib.el ends here ================================================ FILE: org-jira-sdk.el ================================================ ;;; org-jira-sdk.el -- SDK Layer for entities ;; Copyright (C) 2018 Matthew Carter ;; ;; Authors: ;; Matthew Carter ;; ;; Maintainer: Matthew Carter ;; URL: https://github.com/ahungry/org-jira ;; Version: 3.1.1 ;; Keywords: ahungry jira org bug tracker ;; Package-Requires: ((emacs "24.5") (cl-lib "0.5") (request "0.2.0") (s "0.0.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 this program. If not, see ;; or write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;; 02110-1301, USA. ;;; Commentary: ;; This provides an SDK wrapper for more strictly defining the entities we interact with. ;;; Code: (require 'jiralib) (require 'cl-lib) (require 's) (require 'eieio) (require 'dash) (require 'cl-generic) (defclass org-jira-sdk-record () ((id :initarg :id :type string :required t) (data :initarg :data :documentation "The area to hold a big alist of data.") (hydrate-fn :initform (lambda (id) (message "Not implemented.")))) "The ID of the record.") (defun org-jira-sdk-string-but-first (s) (cl-subseq s 1)) (defun org-jira-sdk-to-string (s) (format "%s" s)) (defun org-jira-sdk-to-prefixed-string (s) (format "org-jira-sdk-%s" s)) (defun org-jira-sdk-record-type-to-symbol (record-type) (-> record-type symbol-name org-jira-sdk-string-but-first org-jira-sdk-to-prefixed-string intern)) (defun org-jira-sdk-create-from-id (record-type id &optional parent-id callback) (let ((rec (funcall (org-jira-sdk-record-type-to-symbol record-type) :id (format "%s" id) :parent-id parent-id))) (with-slots (data) rec (setf data (org-jira-sdk-hydrate rec callback)) (org-jira-sdk-from-data rec)))) (defun org-jira-sdk-create-from-data (record-type data) (let ((rec (funcall (org-jira-sdk-record-type-to-symbol record-type) :data data))) (org-jira-sdk-from-data rec))) (cl-defmethod org-jira-sdk-hydrate ((rec org-jira-sdk-record) &optional callback) "Populate the record with data from the remote endpoint." (with-slots (id hydrate-fn) rec (funcall hydrate-fn id callback))) (cl-defgeneric org-jira-sdk-from-data ((rec org-jira-sdk-record))) (cl-defmethod org-jira-sdk-dump ((rec org-jira-sdk-record)) "A decent pretty print/object dump for working with the class items." (let ((slots (mapcar (lambda (slot) (aref slot 1)) (eieio-class-slots (eieio-object-class rec))))) (setq slots (cl-remove-if (lambda (s) (not (slot-boundp rec s))) slots)) (apply #'concat (mapcar (lambda (slot) (let ((slot (intern (org-jira-sdk-to-string slot)))) (format "\n%+16s: %s" slot (slot-value rec (intern (org-jira-sdk-to-string slot))))) ) slots)))) (defun org-jira-sdk-path (alist key-chain) "Query a nested path in some type of ALIST by traversing down the keys of KEY-CHAIN." (cl-reduce (lambda (a k) (alist-get k a)) key-chain :initial-value alist)) (defclass org-jira-sdk-issue (org-jira-sdk-record) ((assignee :type (or null string) :initarg :assignee) (components :type string :initarg :components) (created :type string :initarg :created) (description :type (or null string) :initarg :description) (duedate :type (or null string) :initarg :duedate) (headline :type string :initarg :headline) (id :type string :initarg :id) ; TODO: Probably remove me (issue-id :type string :initarg :issue-id :documentation "The common ID/key, such as EX-1.") (issue-id-int :type string :initarg :issue-id-int :documentation "The internal Jira ID, such as 12345.") (priority :type string :initarg :priority) (proj-key :type string :initarg :proj-key) (reporter :type (or null string) :initarg :reporter) (resolution :type (or null string) :initarg :resolution) (start-date :type (or null string) :initarg :start-date) (status :type string :initarg :status) (summary :type string :initarg :summary) (type :type string :initarg :type) (updated :type string :initarg :updated) (data :initarg :data :documentation "The remote Jira data object (alist).") (hydrate-fn :initform #'jiralib-get-issue :initarg :hydrate-fn)) "An issue on the end. ID of the form EX-1, or a numeric such as 10000.") (defclass org-jira-sdk-comment (org-jira-sdk-record) ((author :type string :initarg :author) (body :type string :initarg :body) (comment-id :type string :initarg :comment-id :documentation "The comment ID, such as 12345.") (created :type string :initarg :created) (headline :type string :initarg :headline) (parent-id :type string :initarg :parent-id :documentation "The parent issue-id such as EX-1.") (updated :type string :initarg :updated) (data :initarg :data :documentation "The reomte Jira data object (alist).") (hydrate-fn :initform #'jiralib-get-comment :initarg :hydrate-fn))) (defclass org-jira-sdk-board (org-jira-sdk-record) ((name :type string :initarg :name :required t) (url :type string :initarg :url :required t) (board-type :type string :initarg :board-type) (jql :type string :initarg :jql) (limit :type integer :initarg :limit) ;; unused (parent-id :type string :initarg :parent-id) (hydrate-fn :initform #'jiralib-get-board :initarg :hydrate-fn))) (cl-defmethod org-jira-sdk-hydrate ((rec org-jira-sdk-comment) &optional callback) "Populate the record with data from the remote endpoint." (with-slots (id proj-key hydrate-fn) rec (funcall hydrate-fn proj-key id callback))) (cl-defmethod org-jira-sdk-from-data ((rec org-jira-sdk-issue)) (cl-flet ((path (keys) (org-jira-sdk-path (oref rec data) keys))) (org-jira-sdk-issue :assignee (path '(fields assignee name)) :components (mapconcat (lambda (c) (org-jira-sdk-path c '(name))) (path '(fields components)) ", ") :created (path '(fields created)) ; confirm :description (or (path '(fields description)) "") :duedate (path '(fields duedate)) ; confirm :headline (path '(fields summary)) ; Duplicate of summary, maybe different. :id (path '(key)) :issue-id (path '(key)) :issue-id-int (path '(id)) :priority (path '(fields priority name)) :proj-key (path '(fields project key)) :reporter (path '(fields reporter name)) ; reporter could be an object of its own slot values :resolution (path '(fields resolution name)) ; confirm :start-date (path '(fields start-date)) ; confirm :status (org-jira-decode (path '(fields status name))) :summary (path '(fields summary)) :type (path '(fields issuetype name)) :updated (path '(fields updated)) ; confirm ;; TODO: Remove this ;; :data (oref rec data) ))) (cl-defmethod org-jira-sdk-from-data ((rec org-jira-sdk-comment)) (cl-flet ((path (keys) (org-jira-sdk-path (oref rec data) keys))) (org-jira-sdk-comment :author (path '(author displayName)) :body (path '(body)) :comment-id (path '(id)) :created (path '(created)) :headline (format "Comment: %s" (path '(author displayName))) :parent-id (if (slot-boundp rec 'parent-id) (oref rec parent-id) "") :updated (path '(updated)) ;; TODO: Remove this ;; :data (oref rec data) ))) (cl-defmethod org-jira-sdk-from-data ((rec org-jira-sdk-board)) (with-slots (data) rec (org-jira-sdk-board :id (int-to-string (alist-get 'id data)) :name (alist-get 'name data) :url (alist-get 'self data) ;; TODO: remove it? used by org-jira-sdk-create-from-id :parent-id "" :board-type (alist-get 'type data)))) ;; Issue (defun org-jira-sdk-create-issue-from-data (d) (org-jira-sdk-create-from-data :issue d)) (defun org-jira-sdk-create-issues-from-data-list (ds) (mapcar #'org-jira-sdk-create-issue-from-data ds)) ;; Comment (defun org-jira-sdk-create-comment-from-data (d) (org-jira-sdk-create-from-data :comment d)) (defun org-jira-sdk-create-comments-from-data-list (ds) (mapcar #'org-jira-sdk-create-comment-from-data ds)) (defun org-jira-sdk-isa-record? (i) (typep i 'org-jira-sdk-record)) (defun org-jira-sdk-isa-issue? (i) (typep i 'org-jira-sdk-issue)) (defun org-jira-sdk-isa-comment? (i) (typep i 'org-jira-sdk-comment)) ;; Board (defun org-jira-sdk-create-board-from-data (d) (org-jira-sdk-create-from-data :board d)) (defun org-jira-sdk-create-boards-from-data-list (ds) (mapcar #'org-jira-sdk-create-board-from-data ds)) (provide 'org-jira-sdk) ;;; org-jira-sdk.el ends here ================================================ FILE: org-jira.el ================================================ ;;; org-jira.el --- Syncing between Jira and Org-mode. -*- lexical-binding: t -*- ;; Copyright (C) 2016-2018 Matthew Carter ;; Copyright (C) 2011 Bao Haojun ;; ;; Authors: ;; Matthew Carter ;; Bao Haojun ;; ;; Maintainer: Matthew Carter ;; URL: https://github.com/ahungry/org-jira ;; Version: 4.0.0 ;; Keywords: ahungry jira org bug tracker ;; Package-Requires: ((emacs "24.5") (cl-lib "0.5") (request "0.2.0") (s "0.0.0") (dash "2.14.1")) ;; 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 this program. If not, see ;; or write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;; 02110-1301, USA. ;;; Commentary: ;; This provides an extension to org-mode for syncing issues with JIRA ;; issue servers. ;;; News: ;;;; Changes in 4.0.0: ;; - Introduce SDK type for handling records vs random alist structures. ;;;; Changes since 3.1.0: ;; - Fix how we were ruining the kill-ring with kill calls. ;;;; Changes since 3.0.0: ;; - Add new org-jira-add-comment call (C-c c c) ;;;; Changes since 2.8.0: ;; - New version 3.0.0 deprecates old filing mechanism and files ;; all of the changes under the top level ticket header. ;; - If you want other top level headers in the same file, this should ;; work now, as long as they come after the main project one. ;;;; Changes since 2.7.0: ;; - Clean up multi-buffer handling, disable attachments call until ;; - refresh is compatible with it. ;;;; Changes since 2.6.3: ;; - Insert worklog import filter in the existing org-jira-update-worklogs-for-current-issue function ;; - Sync up org-clocks and worklogs! Set org-jira-worklog-sync-p to nil to avoid. ;;;; Changes since 2.6.1: ;; - Fix bug with getting all issues when worklog is an error trigger. ;;;; Changes since 2.5.4: ;; - Added new org-jira-refresh-issues-in-buffer call and binding ;;;; Changes since 2.5.3: ;; - Re-introduce the commit that introduced a break into Emacs 25.1.1 list/array push ;; The commit caused updates/comment updates to fail when a blank list of components ;; was present - it will now handle both cases (full list, empty list). ;;;; Changes since 2.5.2: ;; - Revert a commit that introduced a break into Emacs 25.1.1 list/array push ;; The commit caused updates/comment updates to fail ;;;; Changes since 2.5.1: ;; - Only set duedate if a DEADLINE is present in the tags and predicate is t ;;;; Changes since 2.5.0: ;; - Allow overriding the org property names with new defcustom ;;;; Changes since 2.4.0: ;; - Fix many deprecation/warning issues ;; - Fix error with allow-other-keys not being wrapped in cl-function ;;;; Changes since 2.3.0: ;; - Integration with org deadline and Jira due date fields ;;;; Changes since 2.2.0: ;; - Selecting issue type based on project key for creating issues ;;;; Changes since 2.1.0: ;; - Allow changing to unassigned user ;; - Add new shortcut for quick assignment ;;;; Changes since 2.0.0: ;; - Change statusCategory to status value ;; - Clean out some redundant code ;; - Add ELPA tags in keywords ;;;; Changes since 1.0.1: ;; - Converted many calls to async ;; - Removed minor annoyances (position resets etc.) ;;; Code: (require 'org) (require 'org-clock) (require 'cl-lib) (require 'url) (require 'ls-lisp) (require 'dash) (require 's) (require 'jiralib) (require 'org-jira-sdk) (defconst org-jira-version "3.0.0" "Current version of org-jira.el.") (defgroup org-jira nil "Customization group for org-jira." :tag "Org JIRA" :group 'org) (defvar org-jira-working-dir "~/.org-jira" "Folder under which to store org-jira working files.") (defcustom org-jira-default-jql "assignee = currentUser() and resolution = unresolved ORDER BY priority DESC, created ASC" "Default jql for querying your Jira tickets." :group 'org-jira :type 'string) (defcustom org-jira-ignore-comment-user-list '("admin") "Jira usernames that should have comments ignored." :group 'org-jira :type '(repeat (string :tag "Jira username:"))) (defcustom org-jira-reverse-comment-order nil "If non-nil, order comments from most recent to least recent." :group 'org-jira :type 'boolean) (defcustom org-jira-done-states '("Closed" "Resolved" "Done") "Jira states that should be considered as DONE for `org-mode'." :group 'org-jira :type '(repeat (string :tag "Jira state name:"))) (defcustom org-jira-users '(("Full Name" . "username")) "A list of displayName and key pairs." :group 'org-jira :type 'list) (defcustom org-jira-progress-issue-flow '(("To Do" . "In Progress") ("In Progress" . "Done")) "Quickly define a common issue flow." :group 'org-jira :type 'list) (defcustom org-jira-property-overrides (list) "An assoc list of property tag overrides. The KEY . VAL pairs should both be strings. For instance, to change the :assignee: property in the org :PROPERTIES: block to :WorkedBy:, you can set this as such: (setq org-jira-property-overrides (list (cons \"assignee\" \"WorkedBy\"))) or simply: (add-to-list (quote org-jira-property-overrides) (cons (\"assignee\" \"WorkedBy\"))) This will work for most any of the properties, with the exception of ones with unique functionality, such as: - deadline - summary - description" :group 'org-jira :type 'list) (defcustom org-jira-serv-alist nil "Association list to set information for each jira server. Each element of the alist is a jira server name. The CAR of each element is a string, uniquely identifying the server. The CDR of each element is a well-formed property list with an even number of elements, alternating keys and values, specifying parameters for the server. (:property value :property value ... ) When a property is given a value in org-jira-serv-alist, its setting overrides the value of the corresponding user variable (if any) during syncing. Most properties are optional, but some should always be set: :url soap url of the jira server. :username username to be used. :host hostname of the jira server (TODO: compute it from ~url~). All the other properties are optional. They override the global variables. :password password to be used, will be prompted if missing." :group 'org-jira :type '(alist :value-type plist)) (defcustom org-jira-use-status-as-todo nil "Use the JIRA status as the TODO tag value." :group 'org-jira) (defcustom org-jira-coding-system nil "Use custom coding system on org-jira buffers." :group 'org-jira) (defcustom org-jira-deadline-duedate-sync-p t "Keep org deadline and jira duedate fields synced. You may wish to set this to nil if you track org deadlines in your buffer that you do not want to send back to your Jira instance." :group 'org-jira :type 'boolean) (defcustom org-jira-worklog-sync-p t "Keep org clocks and jira worklog fields synced. You may wish to set this to nil if you track org clocks in your buffer that you do not want to send back to your Jira instance." :group 'org-jira :type 'boolean) (defcustom org-jira-download-dir "~/Downloads" "Name of the default jira download library." :group 'org-jira :type 'string) (defcustom org-jira-download-ask-override t "Ask before overriding tile." :group 'org-jira :type 'boolean) (defcustom org-jira-jira-status-to-org-keyword-alist nil "Custom alist of jira status stored in car and `org-mode' keyword stored in cdr." :group 'org-jira :type '(alist :key-type string :value-type string)) (defcustom org-jira-priority-to-org-priority-omit-default-priority nil "Whether to omit insertion of priority when it matches the default. When set to t, will omit the insertion of the matched value from `org-jira-priority-to-org-priority-alist' when it matches the `org-default-priority'." :group 'org-jira :type 'boolean) (defcustom org-jira-priority-to-org-priority-alist nil "Alist mapping jira priority keywords to `org-mode' priority cookies. A sample value might be (list (cons \"High\" ?A) (cons \"Medium\" ?B) (cons \"Low\" ?C)). See `org-default-priority' for more info." :group 'org-jira :type '(alist :key-type string :value-type character)) (defcustom org-jira-boards-default-limit 50 "Default limit for number of issues retrieved from agile boards." :group 'org-jira :type 'integer) (defvar org-jira-serv nil "Parameters of the currently selected blog.") (defvar org-jira-serv-name nil "Name of the blog, to pick from `org-jira-serv-alist'.") (defvar org-jira-projects-list nil "List of jira projects.") (defvar org-jira-current-project nil "Currently selected (i.e., active project).") (defvar org-jira-issues-list nil "List of jira issues under the current project.") (defvar org-jira-server-rpc-url nil "Jira server soap URL.") (defvar org-jira-server-userid nil "Jira server user id.") (defvar org-jira-proj-id nil "Jira project ID.") (defvar org-jira-logged-in nil "Flag whether user is logged-in or not.") (defvar org-jira-buffer-name "*org-jira-%s*" "Name of the jira buffer.") (defvar org-jira-buffer-kill-prompt t "Ask before killing buffer.") (make-variable-buffer-local 'org-jira-buffer-kill-prompt) (defvar org-jira-mode-hook nil "Hook to run upon entry into mode.") (defvar org-jira-issue-id-history '() "Prompt history for issue id.") (defvar org-jira-fixversion-id-history '() "Prompt history for fixversion id.") (defvar org-jira-verbosity 'debug) (defun org-jira-log (s) (when (eq 'debug org-jira-verbosity) (message (format "%s" s)))) (defmacro ensure-on-issue (&rest body) "Make sure we are on an issue heading, before executing BODY." (declare (debug t) (indent 0)) `(save-excursion (save-restriction (widen) (unless (looking-at "^\\*\\* ") (search-backward-regexp "^\\*\\* " nil t)) ; go to top heading (let ((org-jira-id (org-jira-id))) (unless (and org-jira-id (string-match (jiralib-get-issue-regexp) (downcase org-jira-id))) (error "Not on an issue region!"))) ,@body))) (defmacro org-jira-with-callback (&rest body) "Simpler way to write the data callbacks." (declare (debug t) (indent 0)) `(lambda (&rest request-response) (declare (ignore cb-data)) (let ((cb-data (cl-getf request-response :data))) ,@body))) (defmacro org-jira-freeze-ui (&rest body) "Freeze the UI layout for the user as much as possible." (declare (debug t) (indent 0)) `(save-excursion (save-restriction (widen) (org-save-outline-visibility t (outline-show-all) ,@body)))) (defmacro ensure-on-issue-id (issue-id &rest body) "Just do some work on ISSUE-ID, execute BODY." (declare (debug t) (indent 1)) `(let* ((proj-key (replace-regexp-in-string "-.*" "" issue-id)) (project-file (expand-file-name (concat proj-key ".org") org-jira-working-dir)) (project-buffer (or (find-buffer-visiting project-file) (find-file project-file)))) (with-current-buffer project-buffer (org-jira-freeze-ui (let ((p (org-find-entry-with-id ,issue-id))) (unless p (error "Issue %s not found!" ,issue-id)) (goto-char p) (org-narrow-to-subtree) ,@body))))) (defmacro ensure-on-todo (&rest body) "Make sure we are on an todo heading, before executing BODY." (declare (debug t) (indent 0)) `(save-excursion (save-restriction (let ((continue t) (on-todo nil)) (while continue (when (org-get-todo-state) (setq continue nil on-todo t)) (unless (and continue (org-up-heading-safe)) (setq continue nil))) (if (not on-todo) (error "TODO not found") (org-narrow-to-subtree) ,@body))))) (defmacro ensure-on-comment (&rest body) "Make sure we are on a comment heading, before executing BODY." (declare (debug t) (indent 0)) `(save-excursion (org-back-to-heading) (forward-thing 'whitespace) (unless (looking-at "Comment:") (error "Not on a comment region!")) (save-restriction (org-narrow-to-subtree) ,@body))) (defmacro ensure-on-worklog (&rest body) "Make sure we are on a worklog heading, before executing BODY." (declare (debug t) (indent 0)) `(save-excursion (org-back-to-heading) (forward-thing 'whitespace) (unless (looking-at "Worklog:") (error "Not on a worklog region!")) (save-restriction (org-narrow-to-subtree) ,@body))) (defvar org-jira-entry-mode-map (let ((org-jira-map (make-sparse-keymap))) (define-key org-jira-map (kbd "C-c pg") 'org-jira-get-projects) (define-key org-jira-map (kbd "C-c bg") 'org-jira-get-boards) (define-key org-jira-map (kbd "C-c iv") 'org-jira-get-issues-by-board) (define-key org-jira-map (kbd "C-c ib") 'org-jira-browse-issue) (define-key org-jira-map (kbd "C-c ig") 'org-jira-get-issues) (define-key org-jira-map (kbd "C-c ih") 'org-jira-get-issues-headonly) ;;(define-key org-jira-map (kbd "C-c if") 'org-jira-get-issues-from-filter-headonly) ;;(define-key org-jira-map (kbd "C-c iF") 'org-jira-get-issues-from-filter) (define-key org-jira-map (kbd "C-c iu") 'org-jira-update-issue) (define-key org-jira-map (kbd "C-c iw") 'org-jira-progress-issue) (define-key org-jira-map (kbd "C-c in") 'org-jira-progress-issue-next) (define-key org-jira-map (kbd "C-c ia") 'org-jira-assign-issue) (define-key org-jira-map (kbd "C-c ir") 'org-jira-refresh-issue) (define-key org-jira-map (kbd "C-c iR") 'org-jira-refresh-issues-in-buffer) (define-key org-jira-map (kbd "C-c ic") 'org-jira-create-issue) (define-key org-jira-map (kbd "C-c ik") 'org-jira-copy-current-issue-key) (define-key org-jira-map (kbd "C-c sc") 'org-jira-create-subtask) (define-key org-jira-map (kbd "C-c sg") 'org-jira-get-subtasks) (define-key org-jira-map (kbd "C-c cc") 'org-jira-add-comment) (define-key org-jira-map (kbd "C-c cu") 'org-jira-update-comment) (define-key org-jira-map (kbd "C-c wu") 'org-jira-update-worklogs-from-org-clocks) (define-key org-jira-map (kbd "C-c tj") 'org-jira-todo-to-jira) (define-key org-jira-map (kbd "C-c if") 'org-jira-get-issues-by-fixversion) org-jira-map)) ;;;###autoload (define-minor-mode org-jira-mode "Toggle org-jira mode. With no argument, the mode is toggled on/off. Non-nil argument turns mode on. Nil argument turns mode off. Commands: \\{org-jira-entry-mode-map} Entry to this mode calls the value of `org-jira-mode-hook'." :init-value nil :lighter " jira" :group 'org-jira :keymap org-jira-entry-mode-map (if org-jira-mode (run-mode-hooks 'org-jira-mode-hook))) (defun org-jira-get-project-name (proj) (org-jira-find-value proj 'key)) (defun org-jira-find-value (l &rest keys) (let* (key exists) (while (and keys (listp l)) (setq key (car keys)) (setq exists nil) (mapc (lambda (item) (when (equal key (car item)) (setq exists t))) (if (and (listp l) (listp (car l))) l nil)) (setq keys (cdr keys)) (if exists (setq l (cdr (assoc key l))) (setq l (or (cdr (assoc key l)) l)))) l)) (defun org-jira-get-project-lead (proj) (org-jira-find-value proj 'lead 'name)) (defun org-jira-get-assignable-users (project-key) "Get the list of assignable users for PROJECT-KEY, adding user set jira-users first." (append '(("Unassigned" . "")) org-jira-users (mapcar (lambda (user) (cons (org-jira-decode (cdr (assoc 'displayName user))) (org-jira-decode (cdr (assoc 'name user))))) (jiralib-get-users project-key)))) (defun org-jira-entry-put (pom property value) "Similar to org-jira-entry-put, but with an optional alist of overrides. At point-or-marker POM, set PROPERTY to VALUE. Look at customizing org-jira-property-overrides if you want to change the property names this sets." (unless (stringp property) (setq property (symbol-name property))) (let ((property (or (assoc-default property org-jira-property-overrides) property))) (org-entry-put pom property (org-jira-decode value)))) (defun org-jira-kill-line () "Kill the line, without 'kill-line' side-effects of altering kill ring." (interactive) (delete-region (point) (line-end-position))) ;; Appropriated from org.el (defun org-jira-org-kill-line (&optional _arg) "Kill line, to tags or end of line." (cond ((or (not org-special-ctrl-k) (bolp) (not (org-at-heading-p))) (when (and (get-char-property (min (point-max) (point-at-eol)) 'invisible) org-ctrl-k-protect-subtree (or (eq org-ctrl-k-protect-subtree 'error) (not (y-or-n-p "Kill hidden subtree along with headline? ")))) (user-error "C-k aborted as it would kill a hidden subtree")) (call-interactively (if (bound-and-true-p visual-line-mode) 'kill-visual-line 'org-jira-kill-line))) ((looking-at ".*?\\S-\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$") (delete-region (point) (match-beginning 1)) (org-set-tags nil t)) (t (delete-region (point) (point-at-eol))))) ;;;###autoload (defun org-jira-get-projects () "Get list of projects." (interactive) (let ((projects-file (expand-file-name "projects-list.org" org-jira-working-dir))) (or (find-buffer-visiting projects-file) (find-file projects-file)) (org-jira-mode t) (save-excursion (let* ((oj-projs (jiralib-get-projects))) (mapc (lambda (proj) (let* ((proj-key (org-jira-find-value proj 'key)) (proj-headline (format "Project: [[file:%s.org][%s]]" proj-key proj-key))) (save-restriction (widen) (goto-char (point-min)) (outline-show-all) (setq p (org-find-exact-headline-in-buffer proj-headline)) (if (and p (>= p (point-min)) (<= p (point-max))) (progn (goto-char p) (org-narrow-to-subtree) (end-of-line)) (goto-char (point-max)) (unless (looking-at "^") (insert "\n")) (insert "* ") (org-jira-insert proj-headline) (org-narrow-to-subtree)) (org-jira-entry-put (point) "name" (org-jira-get-project-name proj)) (org-jira-entry-put (point) "key" (org-jira-find-value proj 'key)) (org-jira-entry-put (point) "lead" (org-jira-get-project-lead proj)) (org-jira-entry-put (point) "ID" (org-jira-find-value proj 'id)) (org-jira-entry-put (point) "url" (format "%s/browse/%s" (replace-regexp-in-string "/*$" "" jiralib-url) (org-jira-find-value proj 'key)))))) oj-projs))))) (defun org-jira-get-issue-components (issue) "Return the components the ISSUE belongs to." (mapconcat (lambda (comp) (org-jira-find-value comp 'name)) (org-jira-find-value issue 'fields 'components) ", ")) (defun org-jira-decode (data) "Decode text DATA. It must receive a coercion to string, as not every time will it be populated." (let ((coding-system (or org-jira-coding-system (when (boundp 'buffer-file-coding-system) buffer-file-coding-system 'utf-8)))) (decode-coding-string (string-make-unibyte (cl-coerce data 'string)) coding-system))) (defun org-jira-insert (&rest args) "Set coding to text provide by `ARGS' when insert in buffer." (insert (org-jira-decode (apply #'concat args)))) (defun org-jira-transform-time-format (jira-time-str) "Convert JIRA-TIME-STR to format \"%Y-%m-%d %T\". Example: \"2012-01-09T08:59:15.000Z\" becomes \"2012-01-09 16:59:15\", with the current timezone being +0800." (condition-case () (format-time-string "%Y-%m-%d %T" (apply 'encode-time (parse-time-string (replace-regexp-in-string "T\\|\\.000" " " jira-time-str)))) (error jira-time-str))) (defun org-jira--fix-encode-time-args (arg) "Fix ARG for 3 nil values at the head." (cl-loop for n from 0 to 2 by 1 do (when (not (nth n arg)) (setcar (nthcdr n arg) 0))) arg) (defun org-jira-time-format-to-jira (org-time-str) "Convert ORG-TIME-STR back to jira time format." (condition-case () (format-time-string "%Y-%m-%dT%T.000Z" (apply 'encode-time (org-jira--fix-encode-time-args (parse-time-string org-time-str))) t) (error org-time-str))) (defun org-jira-get-comment-val (key comment) "Return the value associated with KEY of COMMENT." (org-jira-get-issue-val key comment)) (defun org-jira-time-stamp-to-org-clock (time-stamp) "Convert TIME-STAMP into org-clock format." (format-time-string "%Y-%m-%d %a %H:%M" time-stamp)) (defun org-jira-date-strip-letter-t (date) "Convert DATE into a time stamp and then into org-clock format. Expects a date in format such as: 2017-02-26T00:08:00.000-0500 and returns in format 2017-02-26 00:08:00-0500." (replace-regexp-in-string "\\.000\\([-+]\\)" "\\1" (replace-regexp-in-string "^\\(.*?\\)T" "\\1 " date))) (defun org-jira-date-to-org-clock (date) "Convert DATE into a time stamp and then into org-clock format. Expects a date in format such as: 2017-02-26T00:08:00.000-0500." (org-jira-time-stamp-to-org-clock (date-to-time (org-jira-date-strip-letter-t date)))) (defun org-jira-worklogs-to-org-clocks (worklogs) "Get a list of WORKLOGS and convert to org-clocks." (mapcar (lambda (worklog) (let ((wl-start (cdr (assoc 'started worklog))) (wl-time (cdr (assoc 'timeSpentSeconds worklog))) (wl-end)) (setq wl-start (org-jira-date-to-org-clock wl-start)) (setq wl-end (org-jira-time-stamp-to-org-clock (time-add (date-to-time wl-start) wl-time))) (list wl-start wl-end (cdr (assoc 'comment worklog)) (cdr (assoc 'id worklog)) ) )) worklogs) ) (defun org-jira-format-clock (clock-entry) "Format a CLOCK-ENTRY given the (list start end). This format is typically generated from org-jira-worklogs-to-org-clocks call." (format "CLOCK: [%s]--[%s]" (car clock-entry) (cadr clock-entry))) (defun org-jira-insert-clock (clock-entry) "Insert a CLOCK-ENTRY given the (list start end). This format is typically generated from org-jira-worklogs-to-org-clocks call." (insert (org-jira-format-clock clock-entry)) (org-beginning-of-line) (org-ctrl-c-ctrl-c) ;; @todo Maybe not call directly? does it matter? - used to resync the clock estimate (org-end-of-line) (insert "\n") (insert (format " :id: %s\n" (cadddr clock-entry))) (when (caddr clock-entry) (insert (format " %s\n" (org-jira-decode (caddr clock-entry))))) ;; No comment is nil, so don't print it ) (defun org-jira-logbook-reset (issue-id &optional clocks) "Find logbook for ISSUE-ID, delete it. Re-create it with CLOCKS. This is used for worklogs." (interactive) (let ((existing-logbook-p nil)) ;; See if the LOGBOOK already exists or not. (ensure-on-issue-id issue-id (let ((drawer-name (or (org-clock-drawer-name) "LOGBOOK"))) (when (search-forward (format ":%s:" drawer-name) nil 1 1) (setq existing-logbook-p t)))) (ensure-on-issue-id issue-id (let ((drawer-name (or (org-clock-drawer-name) "LOGBOOK"))) (if existing-logbook-p (progn ;; If we had a logbook, drop it and re-create in a bit. (search-forward (format ":%s:" drawer-name) nil 1 1) (org-beginning-of-line) (delete-region (point) (search-forward ":END:" nil 1 1)) ) (progn ;; Otherwise, create a new one at the end of properties list (search-forward ":END:" nil 1 1) (forward-line))) (org-insert-drawer nil (format "%s" drawer-name)) ;; Doc says non-nil, but this requires nil (mapc #'org-jira-insert-clock clocks) ;; Clean up leftover newlines (we left 2 behind) (dotimes (n 2) (search-forward-regexp "^$" nil 1 1) (delete-region (point) (min (point-max) (1+ (point))))))))) (defun org-jira-get-worklog-val (key WORKLOG) "Return the value associated with KEY of WORKLOG." (org-jira-get-comment-val key WORKLOG)) (defun org-jira-get-issue-val (key issue) "Return the value associated with key KEY of issue ISSUE." (let ((tmp (or (org-jira-find-value issue 'fields key 'key) ""))) ;; For project, we need a key, not the name... (unless (stringp tmp) (setq tmp (org-jira-find-value issue key))) (unless (stringp tmp) (setq tmp (org-jira-find-value issue 'fields key 'displayName))) (unless (stringp tmp) (setq tmp "")) (cond ((eq key 'components) (org-jira-get-issue-components issue)) ((member key '(created updated startDate)) (org-jira-transform-time-format tmp)) ((eq key 'status) (if jiralib-use-restapi (org-jira-find-value issue 'fields 'status 'name) (org-jira-find-value (jiralib-get-statuses) tmp))) ((eq key 'resolution) (if jiralib-use-restapi tmp (if (string= tmp "") "" (org-jira-find-value (jiralib-get-resolutions) tmp)))) ((eq key 'type) (if jiralib-use-restapi (org-jira-find-value issue 'fields 'issuetype 'name) (org-jira-find-value (jiralib-get-issue-types) tmp))) ((eq key 'priority) (if jiralib-use-restapi (org-jira-find-value issue 'fields 'priority 'name) (org-jira-find-value (jiralib-get-priorities) tmp))) ((eq key 'description) (org-jira-strip-string tmp)) (t tmp)))) (defvar org-jira-jql-history nil) ;;;###autoload (defun org-jira-get-issue-list (&optional callback) "Get list of issues, using jql (jira query language), invoke CALLBACK after. Default is unresolved issues assigned to current login user; with a prefix argument you are given the chance to enter your own jql." (org-jira-log (format "I was called, was it with a callback? %s" (if callback "yes" "no"))) (let ((jql org-jira-default-jql)) (when current-prefix-arg (setq jql (read-string "Jql: " (if org-jira-jql-history (car org-jira-jql-history) "assignee = currentUser() and resolution = unresolved") 'org-jira-jql-history "assignee = currentUser() and resolution = unresolved"))) (list (jiralib-do-jql-search jql nil callback)))) (defun org-jira-get-issue-by-id (id) "Get an issue by its ID." (push id org-jira-issue-id-history) (let ((jql (format "id = %s" id))) (jiralib-do-jql-search jql))) (defun org-jira-get-issue-by-fixversion (fixversion-id) "Get an issue by its FIXVERSION-ID." (push fixversion-id org-jira-fixversion-id-history) (let ((jql (format "fixVersion = \"%s\"" fixversion-id))) (jiralib-do-jql-search jql))) ;;;###autoload (defun org-jira-get-summary () "Get issue summary from point and place next to issue id from jira" (interactive) (let ((jira-id (thing-at-point 'symbol))) (forward-symbol 1) (insert (format " - %s" (cdr (assoc 'summary (car (org-jira-get-issue-by-id jira-id)))))))) ;;;###autoload (defun org-jira-get-summary-url () "Get issue summary from point and place next to issue id from jira, and make issue id a link" (interactive) (let ((jira-id (thing-at-point 'symbol))) (insert (format "[[%s][%s]] - %s" (concatenate 'string jiralib-url "browse/" jira-id) jira-id (cdr (assoc 'summary (car (org-jira-get-issue-by-id jira-id)))))))) ;;;###autoload (defun org-jira-get-issues-headonly (issues) "Get list of ISSUES, head only. The default behavior is to return issues assigned to you and unresolved. With a prefix argument, allow you to customize the jql. See `org-jira-get-issue-list'." (interactive (org-jira-get-issue-list)) (let* ((issues-file (expand-file-name "issues-headonly.org" org-jira-working-dir)) (issues-headonly-buffer (or (find-buffer-visiting issues-file) (find-file issues-file)))) (with-current-buffer issues-headonly-buffer (widen) (delete-region (point-min) (point-max)) (mapc (lambda (issue) (let ((issue-id (org-jira-get-issue-key issue)) (issue-summary (org-jira-get-issue-summary issue))) (org-jira-insert (format "- [jira:%s] %s\n" issue-id issue-summary)))) issues)) (switch-to-buffer issues-headonly-buffer))) ;;;###autoload (defun org-jira-get-issue (id) "Get a JIRA issue, allowing you to enter the issue-id first." (interactive (list (read-string "Issue ID: " "" 'org-jira-issue-id-history))) (org-jira-get-issues (org-jira-get-issue-by-id id)) (let ((issue-pos (org-find-entry-with-id id))) (when issue-pos (goto-char issue-pos) (recenter 0)))) ;;;###autoload (defun org-jira-get-issues-by-fixversion (fixversion) "Get list of issues by FIXVERSION." (interactive (list (read-string "Fixversion ID: " "" 'org-jira-fixversion-id-history))) (org-jira-get-issues (org-jira-get-issue-by-fixversion fixversion))) ;;;###autoload (defun org-jira-get-issue-project (issue) (org-jira-find-value issue 'fields 'project 'key)) (defun org-jira-get-issue-key (issue) (org-jira-find-value issue 'key)) (defun org-jira-get-issue-summary (issue) (org-jira-find-value issue 'fields 'summary)) (defvar org-jira-get-issue-list-callback (cl-function (lambda (&key data &allow-other-keys) "Callback for async, DATA is the response from the request call. Will send a list of org-jira-sdk-issue objects to the list printer." (org-jira-log "Received data for org-jira-get-issue-list-callback.") (--> data (org-jira-sdk-path it '(issues)) (append it nil) ; convert the conses into a proper list. org-jira-sdk-create-issues-from-data-list org-jira-get-issues)))) ;;;###autoload (defun org-jira-get-issues (issues) "Get list of ISSUES into an org buffer. Default is get unfinished issues assigned to you, but you can customize jql with a prefix argument. See`org-jira-get-issue-list'" ;; If the user doesn't provide a default, async call to build an issue list ;; from the JQL style query (interactive (org-jira-get-issue-list org-jira-get-issue-list-callback)) (org-jira-log "Fetching issues...") (when (> (length issues) 0) (org-jira--render-issues-from-issue-list issues))) (defun org-jira--get-project-buffer (Issue) (with-slots (proj-key) Issue (let* ((project-file (expand-file-name (concat proj-key ".org") org-jira-working-dir)) (project-buffer (find-file-noselect project-file))) project-buffer))) (defun org-jira--render-issue (Issue) "Render single ISSUE." (org-jira-log "Rendering issue from issue list") (org-jira-sdk-dump Issue) (with-slots (proj-key issue-id summary status priority headline id) Issue (let (p) (with-current-buffer (org-jira--get-project-buffer Issue) (org-jira-freeze-ui (org-jira-mode t) (goto-char (point-min)) (unless (looking-at (format "^* %s-Tickets" proj-key)) (insert (format "* %s-Tickets\n" proj-key))) (setq p (org-find-entry-with-id issue-id)) (save-restriction (if (and p (>= p (point-min)) (<= p (point-max))) (progn (goto-char p) (forward-thing 'whitespace) (org-jira-kill-line)) (goto-char (point-max)) (unless (looking-at "^") (insert "\n")) (insert "** ")) (let ((status (org-jira-decode status))) (org-jira-insert (concat (org-jira-get-org-keyword-from-status status) " " (org-jira-get-org-priority-cookie-from-issue priority) headline))) (save-excursion (unless (search-forward "\n" (point-max) 1) (insert "\n"))) (org-narrow-to-subtree) (save-excursion (org-back-to-heading t) (org-set-tags-to (replace-regexp-in-string "-" "_" issue-id))) (mapc (lambda (entry) (let ((val (slot-value Issue entry))) (when (or (and val (not (string= val ""))) (eq entry 'assignee)) ;; Always show assignee (org-jira-entry-put (point) (symbol-name entry) val)))) '(assignee reporter type priority resolution status components created updated)) (org-jira-entry-put (point) "ID" issue-id) (org-jira-entry-put (point) "CUSTOM_ID" issue-id) ;; Insert the duedate as a deadline if it exists (when org-jira-deadline-duedate-sync-p (let ((duedate (oref Issue duedate))) (when (> (length duedate) 0) (org-deadline nil duedate)))) (mapc (lambda (heading-entry) (ensure-on-issue-id issue-id (let* ((entry-heading (concat (symbol-name heading-entry) (format ": [[%s][%s]]" (concat jiralib-url "/browse/" issue-id) issue-id)))) (setq p (org-find-exact-headline-in-buffer entry-heading)) (if (and p (>= p (point-min)) (<= p (point-max))) (progn (goto-char p) (org-narrow-to-subtree) (goto-char (point-min)) (forward-line 1) (delete-region (point) (point-max))) (if (org-goto-first-child) (org-insert-heading) (goto-char (point-max)) (org-insert-subheading t)) (org-jira-insert entry-heading "\n")) ;; Insert 2 spaces of indentation so Jira markup won't cause org-markup (org-jira-insert (replace-regexp-in-string "^" " " (format "%s" (slot-value Issue heading-entry))))))) '(description)) (org-jira-update-comments-for-issue issue-id) ;; FIXME: Re-enable when attachments are not erroring. ;;(org-jira-update-attachments-for-current-issue) ;; only sync worklog clocks when the user sets it to be so. (when org-jira-worklog-sync-p (org-jira-update-worklogs-for-issue issue-id)))))))) (defun org-jira--render-issues-from-issue-list (Issues) "Add the issues from ISSUES list into the org file(s). ISSUES is a list of `org-jira-sdk-issue' records." ;; FIXME: Some type of loading error - the first async callback does not know about ;; the issues existing as a class, so we may need to instantiate here if we have none. (when (eq 0 (->> Issues (cl-remove-if-not #'org-jira-sdk-isa-issue?) length)) (setq Issues (org-jira-sdk-create-issues-from-data-list Issues))) ;; First off, we never ever want to run on non-issues, so check our types early. (setq Issues (cl-remove-if-not #'org-jira-sdk-isa-issue? Issues)) (org-jira-log (format "About to render %d issues." (length Issues))) ;; If we have any left, we map over them. (mapc 'org-jira--render-issue Issues) (switch-to-buffer (org-jira--get-project-buffer (-last-item Issues)))) ;;;###autoload (defun org-jira-update-comment () "Update a comment for the current issue." (interactive) (let* ((issue-id (org-jira-get-from-org 'issue 'key)) (comment-id (org-jira-get-from-org 'comment 'id)) (comment (replace-regexp-in-string "^ " "" (org-jira-get-comment-body comment-id))) (callback-edit (cl-function (lambda (&key data &allow-other-keys) (org-jira-update-comments-for-current-issue)))) (callback-add (cl-function (lambda (&key data &allow-other-keys) ;; @todo :optim: Has to be a better way to do this than delete region (like update the unmarked one) (org-jira-delete-current-comment) (org-jira-update-comments-for-current-issue))))) (if comment-id (jiralib-edit-comment issue-id comment-id comment callback-edit) (jiralib-add-comment issue-id comment callback-add)))) (defun org-jira-add-comment (issue-id comment) "For ISSUE-ID, add a new COMMENT string to the issue region." (interactive (let* ((issue-id (org-jira-id)) (comment (read-string (format "Comment (%s): " issue-id)))) (list issue-id comment))) (lexical-let ((issue-id issue-id)) (ensure-on-issue-id issue-id (goto-char (point-max)) (jiralib-add-comment issue-id comment (cl-function (lambda (&key data &allow-other-keys) (ensure-on-issue-id issue-id (org-jira-update-comments-for-current-issue)))))))) (defun org-jira-org-clock-to-date (org-time) "Convert ORG-TIME formatted date into a plain date string." (format-time-string "%Y-%m-%dT%H:%M:%S.000%z" (date-to-time org-time))) (defun org-jira-worklog-time-from-org-time (org-time) "Take in an ORG-TIME and convert it into the portions of a worklog time. Expects input in format such as: [2017-04-05 Wed 01:00]--[2017-04-05 Wed 01:46] => 0:46" (let ((start (replace-regexp-in-string "^\\[\\(.*?\\)\\].*" "\\1" org-time)) (end (replace-regexp-in-string ".*--\\[\\(.*?\\)\\].*" "\\1" org-time))) `((started . ,(org-jira-org-clock-to-date start)) (time-spent-seconds . ,(time-to-seconds (time-subtract (date-to-time end) (date-to-time start))))))) (defun org-jira-org-clock-to-jira-worklog (org-time clock-content) "Given ORG-TIME and CLOCK-CONTENT, format a jira worklog entry." (let ((lines (split-string clock-content "\n")) worklog-id) ;; See if we look like we have an id (when (string-match ":id:" (first lines)) (setq worklog-id (replace-regexp-in-string "^.*:id: \\([0-9]*\\)$" "\\1" (first lines))) (when (> (string-to-number worklog-id) 0) ;; pop off the first id line if we found it valid (setq lines (cdr lines)))) (setq lines (reverse (cdr (reverse lines)))) ;; drop last line (let ((comment (org-trim (mapconcat 'identity lines "\n"))) (worklog-time (org-jira-worklog-time-from-org-time org-time))) `((worklog-id . ,worklog-id) (comment . ,comment) (started . ,(cdr (assoc 'started worklog-time))) (time-spent-seconds . ,(cdr (assoc 'time-spent-seconds worklog-time))) )))) ;;;###autoload (defun org-jira-update-worklogs-from-org-clocks () "Update or add a worklog based on the org clocks." (interactive) (let ((issue-id (org-jira-get-from-org 'issue 'key))) (ensure-on-issue-id issue-id (search-forward (format ":%s:" (or (org-clock-drawer-name) "LOGBOOK")) nil 1 1) (org-beginning-of-line) ;; (org-cycle 1) (while (search-forward "CLOCK: " nil 1 1) (let ((org-time (buffer-substring-no-properties (point) (point-at-eol)))) (forward-line) ;; See where the stuff ends (what point) (let (next-clock-point) (save-excursion (search-forward-regexp "\\(CLOCK\\|:END\\):" nil 1 1) (setq next-clock-point (point))) (let ((clock-content (buffer-substring-no-properties (point) next-clock-point))) ;; @todo :optim: This is inefficient, calling the resync on each update/insert event, ;; ideally we would track and only insert/update changed entries, as well ;; only call a resync once (when the entire list is processed, which will ;; basically require a dry run to see how many items we should be updating. ;; Update via jiralib call (let* ((worklog (org-jira-org-clock-to-jira-worklog org-time clock-content)) (comment-text (cdr (assoc 'comment worklog))) (comment-text (if (string= (org-trim comment-text) "") nil comment-text))) (if (cdr (assoc 'worklog-id worklog)) (jiralib-update-worklog issue-id (cdr (assoc 'worklog-id worklog)) (cdr (assoc 'started worklog)) (cdr (assoc 'time-spent-seconds worklog)) comment-text (cl-function (lambda (&key data &allow-other-keys) (org-jira-update-worklogs-for-issue issue-id)))) ;; else (jiralib-add-worklog issue-id (cdr (assoc 'started worklog)) (cdr (assoc 'time-spent-seconds worklog)) comment-text (cl-function (lambda (&key data &allow-other-keys) (org-jira-update-worklogs-for-issue issue-id)))) ) ))))) ))) (defun org-jira-update-worklog () "Update a worklog for the current issue." (interactive) (error "Deprecated, use org-jira-update-worklogs-from-org-clocks instead!") (let* ((issue-id (org-jira-get-from-org 'issue 'key)) (worklog-id (org-jira-get-from-org 'worklog 'id)) (timeSpent (org-jira-get-from-org 'worklog 'timeSpent)) (timeSpent (if timeSpent timeSpent (read-string "Input the time you spent (such as 3w 1d 2h): "))) (timeSpent (replace-regexp-in-string " \\(\\sw\\)\\sw*\\(,\\|$\\)" "\\1" timeSpent)) (startDate (org-jira-get-from-org 'worklog 'startDate)) (startDate (if startDate startDate (org-read-date nil nil nil "Input when did you start"))) (startDate (org-jira-time-format-to-jira startDate)) (comment (replace-regexp-in-string "^ " "" (org-jira-get-worklog-comment worklog-id))) (worklog `((comment . ,comment) (timeSpent . ,timeSpent) (timeSpentInSeconds . 10) (startDate . ,startDate))) (worklog (if worklog-id (cons `(id . ,(replace-regexp-in-string "^worklog-" "" worklog-id)) worklog) worklog))) (if worklog-id (jiralib-update-worklog worklog) (jiralib-add-worklog-and-autoadjust-remaining-estimate issue-id startDate timeSpent comment)) (org-jira-delete-current-worklog) (org-jira-update-worklogs-for-current-issue))) (defun org-jira-delete-current-comment () "Delete the current comment." (ensure-on-comment (delete-region (point-min) (point-max)))) (defun org-jira-delete-current-worklog () "Delete the current worklog." (ensure-on-worklog (delete-region (point-min) (point-max)))) ;;;###autoload (defun org-jira-copy-current-issue-key () "Copy the current issue's key into clipboard." (interactive) (let ((issue-id (org-jira-get-from-org 'issue 'key))) (with-temp-buffer (insert issue-id) (kill-region (point-min) (point-max))))) (defun org-jira-get-comment-id (comment) (org-jira-find-value comment 'id)) (defun org-jira-get-comment-author (comment) (org-jira-find-value comment 'author 'displayName)) (defun org-jira-isa-ignored-comment? (comment) (member-ignore-case (oref comment author) org-jira-ignore-comment-user-list)) (defun org-jira-maybe-reverse-comments (comments) (if org-jira-reverse-comment-order (reverse comments) comments)) (defun org-jira-extract-comments-from-data (data) (->> (append data nil) org-jira-sdk-create-comments-from-data-list org-jira-maybe-reverse-comments (cl-remove-if #'org-jira-isa-ignored-comment?))) (defun org-jira--render-comment (issue-id Comment) (with-slots (comment-id author headline created updated body) Comment (ensure-on-issue-id issue-id (setq p (org-find-entry-with-id comment-id)) (when (and p (>= p (point-min)) (<= p (point-max))) (goto-char p) (org-narrow-to-subtree) (delete-region (point-min) (point-max))) (goto-char (point-max)) (unless (looking-at "^") (insert "\n")) (insert "*** ") (org-jira-insert headline "\n") (org-narrow-to-subtree) (org-jira-entry-put (point) "ID" comment-id) (org-jira-entry-put (point) "created" created) (unless (string= created updated) (org-jira-entry-put (point) "updated" updated)) (goto-char (point-max)) ;; Insert 2 spaces of indentation so Jira markup won't cause org-markup (org-jira-insert (replace-regexp-in-string "^" " " (or body "")))))) (defun org-jira-update-comments-for-issue (issue-id) "Update the comments for the specified ISSUE-ID issue." (jiralib-get-comments issue-id (org-jira-with-callback (org-jira-log "In the callback for org-jira-update-comments-for-issue.") (--> (org-jira-find-value cb-data 'comments) (org-jira-extract-comments-from-data it) (mapc (lambda (Comment) (org-jira--render-comment issue-id Comment)) it))))) (defun org-jira-update-comments-for-current-issue () "Update comments for the current issue." (org-jira-log "About to update comments for current issue.") (-> (org-jira-get-from-org 'issue 'key) org-jira-update-comments-for-issue)) (defun org-jira-delete-subtree () "Derived from org-cut-subtree. Like that function, without mangling the user's clipboard for the purpose of wiping an old subtree." (let (beg end folded (beg0 (point))) (org-back-to-heading t) ; take what is really there (setq beg (point)) (skip-chars-forward " \t\r\n") (save-match-data (save-excursion (outline-end-of-heading) (setq folded (org-invisible-p)) (org-end-of-subtree t t))) ;; Include the end of an inlinetask (when (and (featurep 'org-inlinetask) (looking-at-p (concat (org-inlinetask-outline-regexp) "END[ \t]*$"))) (end-of-line)) (setq end (point)) (goto-char beg0) (when (> end beg) (setq org-subtree-clip-folded folded) (org-save-markers-in-region beg end) (delete-region beg end)))) (defun org-jira-update-attachments-for-current-issue () "Update the attachments for the current issue." (when jiralib-use-restapi (lexical-let ((issue-id (org-jira-get-from-org 'issue 'key))) ;; Run the call (jiralib-get-attachments issue-id (save-excursion (cl-function (lambda (&key data &allow-other-keys) ;; First, make sure we're in the proper buffer (logic copied from org-jira-get-issues. (let* ((proj-key (replace-regexp-in-string "-.*" "" issue-id)) (project-file (expand-file-name (concat proj-key ".org") org-jira-working-dir)) (project-buffer (or (find-buffer-visiting project-file) (find-file project-file)))) (with-current-buffer project-buffer ;; delete old attachment node (ensure-on-issue (if (org-goto-first-child) (while (org-goto-sibling) (forward-thing 'whitespace) (when (looking-at "Attachments:") (org-jira-delete-subtree))))) (let ((attachments (org-jira-find-value data 'fields 'attachment))) (when (not (zerop (length attachments))) (ensure-on-issue (if (org-goto-first-child) (progn (while (org-goto-sibling)) (org-insert-heading-after-current)) (org-insert-subheading nil)) (insert "Attachments:") (mapc (lambda (attachment) (let ((attachment-id (org-jira-get-comment-id attachment)) (author (org-jira-get-comment-author attachment)) (created (org-jira-transform-time-format (org-jira-find-value attachment 'created))) (size (org-jira-find-value attachment 'size)) (mimeType (org-jira-find-value attachment 'mimeType)) (content (org-jira-find-value attachment 'content)) (filename (org-jira-find-value attachment 'filename))) (if (looking-back "Attachments:") (org-insert-subheading nil) (org-insert-heading-respect-content)) (insert "[[" content "][" filename "]]") (org-narrow-to-subtree) (org-jira-entry-put (point) "ID" attachment-id) (org-jira-entry-put (point) "Author" author) (org-jira-entry-put (point) "Name" filename) (org-jira-entry-put (point) "Created" created) (org-jira-entry-put (point) "Size" (ls-lisp-format-file-size size t)) (org-jira-entry-put (point) "Content" content) (widen))) attachments))))))))))))) (defun org-jira-sort-org-clocks (clocks) "Given a CLOCKS list, sort it by start date descending." ;; Expects data such as this: ;; ((\"2017-02-26 Sun 00:08\" \"2017-02-26 Sun 01:08\" \"Hi\" \"10101\") ;; (\"2017-03-16 Thu 22:25\" \"2017-03-16 Thu 22:57\" \"Test\" \"10200\")) (sort clocks (lambda (a b) (> (time-to-seconds (date-to-time (car a))) (time-to-seconds (date-to-time (car b))))))) (defun org-jira-update-worklogs-for-current-issue () "Update the worklogs for the current issue." (-> (org-jira-get-from-org 'issue 'key) org-jira-update-worklogs-for-issue)) (defun org-jira-update-worklogs-for-issue (issue-id) "Update the worklogs for the current issue." ;; Run the call (jiralib-get-worklogs issue-id (org-jira-with-callback (ensure-on-issue-id issue-id (let ((worklogs (org-jira-find-value cb-data 'worklogs))) (org-jira-logbook-reset issue-id (org-jira-sort-org-clocks (org-jira-worklogs-to-org-clocks (jiralib-worklog-import--filter-apply worklogs))))))))) ;;;###autoload (defun org-jira-unassign-issue () "Update an issue to be unassigned." (interactive) (let ((issue-id (org-jira-parse-issue-id))) (org-jira-update-issue-details issue-id :assignee nil))) ;;;###autoload (defun org-jira-assign-issue () "Update an issue with interactive re-assignment." (interactive) (let ((issue-id (org-jira-parse-issue-id))) (if issue-id (let* ((project (replace-regexp-in-string "-[0-9]+" "" issue-id)) (jira-users (org-jira-get-assignable-users project)) (user (completing-read "Assignee: " (append (mapcar 'car jira-users) (mapcar 'cdr jira-users)))) (assignee (or (cdr (assoc user jira-users)) (cdr (rassoc user jira-users))))) (when (null assignee) (error "No assignee found, use org-jira-unassign-issue to make the issue unassigned")) (org-jira-update-issue-details issue-id :assignee assignee)) (error "Not on an issue")))) ;;;###autoload (defun org-jira-update-issue () "Update an issue." (interactive) (let ((issue-id (org-jira-parse-issue-id))) (if issue-id (org-jira-update-issue-details issue-id) (error "Not on an issue")))) ;;;###autoload (defun org-jira-todo-to-jira () "Convert an ordinary todo item to a jira ticket." (interactive) (ensure-on-todo (when (org-jira-parse-issue-id) (error "Already on jira ticket")) (save-excursion (org-jira-create-issue (org-jira-read-project) (org-jira-read-issue-type) (org-get-heading t t) (org-get-entry))) (delete-region (point-min) (point-max)))) ;;;###autoload (defun org-jira-get-subtasks () "Get subtasks for the current issue." (interactive) (ensure-on-issue (org-jira-get-issues-headonly (jiralib-do-jql-search (format "parent = %s" (org-jira-parse-issue-id)))))) (defvar org-jira-project-read-history nil) (defvar org-jira-boards-read-history nil) (defvar org-jira-components-read-history nil) (defvar org-jira-priority-read-history nil) (defvar org-jira-type-read-history nil) (defun org-jira-read-project () "Read project name." (completing-read "Project: " (jiralib-make-list (jiralib-get-projects) 'key) nil t nil 'org-jira-project-read-history (car org-jira-project-read-history))) (defun org-jira-read-board () "Read board name. Returns cons pair (name . integer-id)" (let* ((boards-alist (jiralib-make-assoc-list (jiralib-get-boards) 'name 'id)) (board-name (completing-read "Boards: " boards-alist nil t nil 'org-jira-boards-read-history (car org-jira-boards-read-history)))) (assoc board-name boards-alist))) (defun org-jira-read-component (project) "Read the components options for PROJECT such as EX." (completing-read "Components (choose Done to stop): " (append '("Done") (mapcar 'cdr (jiralib-get-components project))) nil t nil 'org-jira-components-read-history "Done")) ;; TODO: Finish this feature - integrate into org-jira-create-issue (defun org-jira-read-components (project) "Types: string PROJECT : string (csv of components). Get all the components for the PROJECT such as EX, that should be bound to an issue." (let (components component) (while (not (equal "Done" component)) (setq component (org-jira-read-component project)) (unless (equal "Done" component) (push component components))) components)) (defun org-jira-read-priority () "Read priority name." (completing-read "Priority: " (mapcar 'cdr (jiralib-get-priorities)) nil t nil 'org-jira-priority-read-history (car org-jira-priority-read-history))) (defun org-jira-read-issue-type (&optional project) "Read issue type name. PROJECT is the optional project key." (let* ((issue-types (mapcar 'cdr (if project (jiralib-get-issue-types-by-project project) (jiralib-get-issue-types)))) (initial-input (when (member (car org-jira-type-read-history) issue-types) org-jira-type-read-history))) (completing-read "Type: " issue-types nil t nil initial-input (car initial-input)))) (defun org-jira-read-subtask-type () "Read issue type name." (completing-read "Type: " (mapcar 'cdr (jiralib-get-subtask-types)) nil t nil 'org-jira-type-read-history (car org-jira-type-read-history))) (defun org-jira-get-issue-struct (project type summary description) "Create an issue struct for PROJECT, of TYPE, with SUMMARY and DESCRIPTION." (if (or (equal project "") (equal type "") (equal summary "")) (error "Must provide all information!")) (let* ((project-components (jiralib-get-components project)) (jira-users (org-jira-get-assignable-users project)) (user (completing-read "Assignee: " (mapcar 'car jira-users))) (priority (car (rassoc (org-jira-read-priority) (jiralib-get-priorities)))) (ticket-struct `((fields (project (key . ,project)) (issuetype (id . ,(car (rassoc type (if (and (boundp 'parent-id) parent-id) (jiralib-get-subtask-types) (jiralib-get-issue-types)))))) (summary . ,(format "%s%s" summary (if (and (boundp 'parent-id) parent-id) (format " (subtask of [jira:%s])" parent-id) ""))) (description . ,description) (priority (id . ,priority)) (assignee (name . ,(or (cdr (assoc user jira-users)) user))))))) ticket-struct)) ;;;###autoload (defun org-jira-create-issue (project type summary description) "Create an issue in PROJECT, of type TYPE, with given SUMMARY and DESCRIPTION." (interactive (let* ((project (org-jira-read-project)) (type (org-jira-read-issue-type project)) (summary (read-string "Summary: ")) (description (read-string "Description: "))) (list project type summary description))) (if (or (equal project "") (equal type "") (equal summary "")) (error "Must provide all information!")) (let* ((parent-id nil) (ticket-struct (org-jira-get-issue-struct project type summary description))) (org-jira-get-issues (list (jiralib-create-issue ticket-struct))))) ;;;###autoload (defun org-jira-create-subtask (project type summary description) "Create a subtask issue for PROJECT, of TYPE, with SUMMARY and DESCRIPTION." (interactive (ensure-on-issue (list (org-jira-read-project) (org-jira-read-subtask-type) (read-string "Summary: ") (read-string "Description: ")))) (if (or (equal project "") (equal type "") (equal summary "")) (error "Must provide all information!")) (let* ((parent-id (org-jira-parse-issue-id)) (ticket-struct (org-jira-get-issue-struct project type summary description))) (org-jira-get-issues (list (jiralib-create-subtask ticket-struct parent-id))))) (defun org-jira-strip-string (str) "Remove the beginning and ending white space for a string STR." (s-trim str)) (defun org-jira-get-issue-val-from-org (key) "Return the requested value by KEY from the current issue." (ensure-on-issue (cond ((eq key 'description) (org-goto-first-child) (forward-thing 'whitespace) (if (looking-at "description: ") (org-jira-strip-string (org-get-entry)) (error "Can not find description field for this issue"))) ((eq key 'summary) (ensure-on-issue (org-get-heading t t))) ;; org returns a time tuple, we need to convert it ((eq key 'deadline) (let ((encoded-time (org-get-deadline-time (point)))) (when encoded-time (cl-reduce (lambda (carry segment) (format "%s-%s" carry segment)) (reverse (cl-subseq (decode-time encoded-time) 3 6)))))) ;; default case, just grab the value in the properties block (t (when (symbolp key) (setq key (symbol-name key))) (setq key (or (assoc-default key org-jira-property-overrides) key)) (when (string= key "key") (setq key "ID")) ;; The variable `org-special-properties' will mess this up ;; if our search, such as 'priority' is within there, so ;; don't bother with it for this (since we only ever care ;; about the local properties, not any hierarchal or special ;; ones). (let ((org-special-properties nil)) (or (org-entry-get (point) key) "")))))) (defvar org-jira-actions-history nil) (defun org-jira-read-action (actions) "Read issue workflow progress ACTIONS." (let ((action (completing-read "Action: " (mapcar 'cdr actions) nil t nil 'org-jira-actions-history (car org-jira-actions-history)))) (car (rassoc action actions)))) (defvar org-jira-fields-history nil) (defun org-jira-read-field (fields) "Read (custom) FIELDS for workflow progress." (let ((field-desc (completing-read "More fields to set: " (cons "Thanks, no more fields are *required*." (mapcar 'org-jira-decode (mapcar 'cdr fields))) nil t nil 'org-jira-fields-history)) field-name) (setq field-name (car (rassoc field-desc fields))) (if field-name (intern field-name) field-name))) (defvar org-jira-rest-fields nil "Extra fields are held here for usage between two endpoints. Used in org-jira-read-resolution and org-jira-progress-issue calls.") (defvar org-jira-resolution-history nil) (defun org-jira-read-resolution () "Read issue workflow progress resolution." (if (not jiralib-use-restapi) (let ((resolution (completing-read "Resolution: " (mapcar 'cdr (jiralib-get-resolutions)) nil t nil 'org-jira-resolution-history (car org-jira-resolution-history)))) (car (rassoc resolution (jiralib-get-resolutions)))) (let* ((resolutions (org-jira-find-value org-jira-rest-fields 'resolution 'allowedValues)) (resolution-name (completing-read "Resolution: " (mapcar (lambda (resolution) (org-jira-find-value resolution 'name)) resolutions)))) (cons 'name resolution-name)))) ;; TODO: Refactor to just scoop all ids from buffer, run ensure-on-issue-id on ;; each using a map, and refresh them that way. That way we don't have to iterate ;; on the user headings etc. (defun org-jira-refresh-issues-in-buffer () "Iterate across all entries in current buffer, refreshing on issue :ID:. Where issue-id will be something such as \"EX-22\"." (interactive) (save-excursion (save-restriction (widen) (outline-show-all) (outline-hide-sublevels 2) (goto-char (point-min)) (outline-next-visible-heading 1) (while (not (org-next-line-empty-p)) (when (outline-on-heading-p t) ;; It's possible we could be on a non-org-jira headline, but ;; that should be an exceptional case and not necessitating a ;; fix atm. (org-jira-refresh-issue)) (outline-next-visible-heading 1))))) ;;;###autoload (defun org-jira-refresh-issue () "Refresh current issue from jira to org." (interactive) (ensure-on-issue (org-jira--refresh-issue (org-jira-id)))) (defun org-jira--refresh-issue (issue-id) "Refresh issue from jira to org using ISSUE-ID." (jiralib-get-issue issue-id (org-jira-with-callback (org-jira-log (format "Received refresh issue data for id: %s" issue-id)) (-> cb-data list org-jira-sdk-create-issues-from-data-list org-jira--render-issues-from-issue-list)))) (defun org-jira--refresh-issue-by-id (issue-id) "Refresh issue from jira to org using ISSUE-ID." (ensure-on-issue-id issue-id (org-jira--refresh-issue issue-id))) (defvar org-jira-fields-values-history nil) ;;;###autoload (defun org-jira-progress-issue () "Progress issue workflow." (interactive) (ensure-on-issue (let* ((issue-id (org-jira-id)) (actions (jiralib-get-available-actions issue-id (org-jira-get-issue-val-from-org 'status))) (action (org-jira-read-action actions)) (fields (jiralib-get-fields-for-action issue-id action)) (org-jira-rest-fields fields) (field-key) (custom-fields-collector nil) (custom-fields (progn ;; delete those elements in fields, which have ;; already been set in custom-fields-collector (while fields (setq fields (cl-remove-if (lambda (strstr) (cl-member-if (lambda (symstr) (string= (car strstr) (symbol-name (car symstr)))) custom-fields-collector)) fields)) (setq field-key (org-jira-read-field fields)) (if (not field-key) (setq fields nil) (setq custom-fields-collector (cons (funcall (if jiralib-use-restapi #'list #'cons) field-key (if (eq field-key 'resolution) (org-jira-read-resolution) (let ((field-value (completing-read (format "Please enter %s's value: " (cdr (assoc (symbol-name field-key) fields))) org-jira-fields-values-history nil nil nil 'org-jira-fields-values-history))) (if jiralib-use-restapi (cons 'name field-value) field-value)))) custom-fields-collector)))) custom-fields-collector))) (jiralib-progress-workflow-action issue-id action custom-fields (cl-function (lambda (&key data &allow-other-keys) (org-jira-refresh-issue))))))) (defun org-jira-progress-next-action (actions current-status) "Grab the user defined 'next' action from ACTIONS, given CURRENT-STATUS." (let* ((next-action-name (cdr (assoc current-status org-jira-progress-issue-flow))) (next-action-id (caar (cl-remove-if-not (lambda (action) (equal action next-action-name)) actions :key #'cdr)))) next-action-id)) ;;;###autoload (defun org-jira-progress-issue-next () "Progress issue workflow." (interactive) (ensure-on-issue (let* ((issue-id (org-jira-id)) (actions (jiralib-get-available-actions issue-id (org-jira-get-issue-val-from-org 'status))) (action (org-jira-progress-next-action actions (org-jira-get-issue-val-from-org 'status))) (fields (jiralib-get-fields-for-action issue-id action)) (org-jira-rest-fields fields) (field-key) (custom-fields-collector nil) (custom-fields (progn ;; delete those elements in fields, which have ;; already been set in custom-fields-collector (while fields (setq fields (cl-remove-if (lambda (strstr) (cl-member-if (lambda (symstr) (string= (car strstr) (symbol-name (car symstr)))) custom-fields-collector)) fields)) (setq field-key (org-jira-read-field fields)) (if (not field-key) (setq fields nil) (setq custom-fields-collector (cons (funcall (if jiralib-use-restapi #'list #'cons) field-key (if (eq field-key 'resolution) (org-jira-read-resolution) (let ((field-value (completing-read (format "Please enter %s's value: " (cdr (assoc (symbol-name field-key) fields))) org-jira-fields-values-history nil nil nil 'org-jira-fields-values-history))) (if jiralib-use-restapi (cons 'name field-value) field-value)))) custom-fields-collector)))) custom-fields-collector))) (if action (jiralib-progress-workflow-action issue-id action custom-fields (org-jira-with-callback (ensure-on-issue-id issue-id (org-jira-refresh-issue)))) (error "No action defined for that step!"))))) (defun org-jira-get-id-name-alist (name ids-to-names) "Find the id corresponding to NAME in IDS-TO-NAMES and return an alist with id and name as keys." (let ((id (car (rassoc name ids-to-names)))) `((id . ,id) (name . ,name)))) (defun org-jira-build-components-list (project-components org-issue-components) "Given PROJECT-COMPONENTS, attempt to build a list. If the PROJECT-COMPONENTS are nil, this should return: (list components []), which will translate into the JSON: {\"components\": []} otherwise it should return: (list components (list (cons id comp-id) (cons name item-name))), which will translate into the JSON: {\"components\": [{\"id\": \"comp-id\", \"name\": \"item\"}]}" (if (not project-components) (vector) ;; Return a blank array for JSON (apply 'list (cl-mapcan (lambda (item) (let ((comp-id (car (rassoc item project-components)))) (if comp-id `(((id . ,comp-id) (name . ,item))) nil))) (split-string org-issue-components ",\\s *"))))) (defun org-jira-strip-priority-tags (s) (->> s (replace-regexp-in-string "\\[#.*?\\]" "") s-trim)) (defun org-jira-update-issue-details (issue-id &rest rest) "Update the details of issue ISSUE-ID. REST will contain optional input." (ensure-on-issue-id issue-id ;; Set up a bunch of values from the org content (let* ((org-issue-components (org-jira-get-issue-val-from-org 'components)) (org-issue-description (s-trim (org-jira-get-issue-val-from-org 'description))) (org-issue-priority (org-jira-get-issue-val-from-org 'priority)) (org-issue-type (org-jira-get-issue-val-from-org 'type)) (org-issue-assignee (cl-getf rest :assignee (org-jira-get-issue-val-from-org 'assignee))) (project (replace-regexp-in-string "-[0-9]+" "" issue-id)) (project-components (jiralib-get-components project))) ;; Lets fire off a worklog update async with the main issue ;; update, why not? This is better to fire first, because it ;; doesn't auto-refresh any areas, while the end of the main ;; update does a callback that reloads the worklog entries (so, ;; we hope that wont occur until after this successfully syncs ;; up). Only do this sync if the user defcustom defines it as such. (when org-jira-worklog-sync-p (org-jira-update-worklogs-from-org-clocks)) ;; Send the update to jira (let ((update-fields (list (cons 'components (or (org-jira-build-components-list project-components org-issue-components) [])) (cons 'priority (org-jira-get-id-name-alist org-issue-priority (jiralib-get-priorities))) (cons 'description org-issue-description) (cons 'assignee (jiralib-get-user org-issue-assignee)) (cons 'summary (org-jira-strip-priority-tags (org-jira-get-issue-val-from-org 'summary))) (cons 'issuetype (org-jira-get-id-name-alist org-issue-type (jiralib-get-issue-types)))))) ;; If we enable duedate sync and we have a deadline present (when (and org-jira-deadline-duedate-sync-p (org-jira-get-issue-val-from-org 'deadline)) (setq update-fields (append update-fields (list (cons 'duedate (org-jira-get-issue-val-from-org 'deadline)))))) (jiralib-update-issue issue-id update-fields ;; This callback occurs on success (org-jira-with-callback (message (format "Issue '%s' updated!" issue-id)) (jiralib-get-issue issue-id (org-jira-with-callback (org-jira-log "Update get issue for refresh callback hit.") (-> cb-data list org-jira-get-issues)))) )) ))) (defun org-jira-parse-issue-id () "Get issue id from org text." (save-excursion (let ((continue t) issue-id) (while continue (when (string-match (jiralib-get-issue-regexp) (or (setq issue-id (org-entry-get (point) "ID")) "")) (setq continue nil)) (unless (and continue (org-up-heading-safe)) (setq continue nil))) issue-id))) (defun org-jira-get-from-org (type entry) "Get an org property from the current item. TYPE is the type to of the current item, and can be 'issue, or 'comment. ENTRY will vary, and is the name of the property to return. If it is a symbol, it will be converted to string." (when (symbolp entry) (setq entry (symbol-name entry))) (cond ((eq type 'issue) (org-jira-get-issue-val-from-org entry)) ((eq type 'comment) (org-jira-get-comment-val-from-org entry)) ((eq type 'worklog) (org-jira-get-worklog-val-from-org entry)) (t (error "Unknown type %s" type)))) (defun org-jira-get-comment-val-from-org (entry) "Get the JIRA issue field value ENTRY of the current comment item." (ensure-on-comment (when (symbolp entry) (setq entry (symbol-name entry))) (when (string= entry "id") (setq entry "ID")) (org-entry-get (point) entry))) (defun org-jira-get-worklog-val-from-org (entry) "Get the JIRA issue field value ENTRY of the current worklog item." (ensure-on-worklog (when (symbolp entry) (setq entry (symbol-name entry))) (when (string= entry "id") (setq entry "ID")) (org-entry-get (point) entry))) (defun org-jira-get-comment-body (&optional comment-id) "Get the comment body of the comment with id COMMENT-ID." (ensure-on-comment (goto-char (point-min)) ;; so that search for :END: won't fail (org-jira-entry-put (point) "ID" comment-id) (search-forward ":END:" nil 1 1) (forward-line) (org-jira-strip-string (buffer-substring-no-properties (point) (point-max))))) (defun org-jira-get-worklog-comment (&optional worklog-id) "Get the worklog comment of the worklog with id WORKLOG-ID." (ensure-on-worklog (goto-char (point-min)) ;; so that search for :END: won't fail (org-jira-entry-put (point) "ID" worklog-id) (search-forward ":END:" nil 1 1) (forward-line) (org-jira-strip-string (buffer-substring-no-properties (point) (point-max))))) (defun org-jira-id () "Get the ID entry for the current heading." (org-entry-get (point) "ID")) ;;;###autoload (defun org-jira-browse-issue () "Open the current issue in external browser." (interactive) (ensure-on-issue (browse-url (concat (replace-regexp-in-string "/*$" "" jiralib-url) "/browse/" (org-jira-id))))) (defun org-jira-url-copy-file (url newname) "Similar to url-copy-file but async." (lexical-let ((newname newname)) (url-retrieve url (lambda (status) (let ((buffer (current-buffer)) (handle nil) (filename (if (and (file-exists-p newname) org-jira-download-ask-override) (read-string "File already exists, select new name or press ENTER to override: " newname) newname))) (if (not buffer) (error "Opening input file: No such file or directory, %s" url)) (with-current-buffer buffer (setq handle (mm-dissect-buffer t))) (mm-save-part-to-file handle filename) (kill-buffer buffer) (mm-destroy-parts handle)))))) ;;;###autoload (defun org-jira-download-attachment () "Download the attachment under cursor." (interactive) (when jiralib-use-restapi (save-excursion (org-up-heading-safe) (org-back-to-heading) (forward-thing 'whitespace) (unless (looking-at "Attachments:") (error "Not on a attachment region!"))) (let ((filename (org-entry-get (point) "Name")) (url (org-entry-get (point) "Content")) (url-request-extra-headers `(,jiralib-token))) (org-jira-url-copy-file url (concat (file-name-as-directory org-jira-download-dir) filename))))) ;;;###autoload (defun org-jira-get-issues-from-filter (filter) "Get issues from the server-side stored filter named FILTER. Provide this command in case some users are not able to use client side jql (maybe because of JIRA server version?)." (interactive (list (completing-read "Filter: " (mapcar 'cdr (jiralib-get-saved-filters))))) (org-jira-get-issues (jiralib-get-issues-from-filter (car (rassoc filter (jiralib-get-saved-filters)))))) ;;;###autoload (defun org-jira-get-issues-from-filter-headonly (filter) "Get issues *head only* from saved filter named FILTER. See `org-jira-get-issues-from-filter'." (interactive (list (completing-read "Filter: " (mapcar 'cdr (jiralib-get-saved-filters))))) (org-jira-get-issues-headonly (jiralib-get-issues-from-filter (car (rassoc filter (jiralib-get-saved-filters)))))) (org-add-link-type "jira" 'org-jira-open) ;; This was only added in org 9.0, not sure all org users will have ;; that version, so keep the deprecated one from above for now. ;;(org-link-set-parameters "jira" ((:follow . 'org-jira-open))) (defun org-jira-open (path) "Open a Jira Link from PATH." (org-jira-get-issue path)) ;;;###autoload (defun org-jira-get-issues-by-board () "Get list of ISSUES from agile board." (interactive) (let* ((board (org-jira-read-board)) (board-id (cdr board))) (jiralib-get-board-issues board-id :callback org-jira-get-issue-list-callback :limit (org-jira-get-board-limit board-id) :query-params (org-jira--make-jql-queryparams board-id)))) (defun org-jira-get-board-limit (id) "Get limit for number of retrieved issues for a board id - integer board id" (let ((board (org-jira--get-board-from-buffer id))) (if (and board (slot-boundp board 'limit)) (oref board limit) org-jira-boards-default-limit))) (defun org-jira--make-jql-queryparams (board-id) "make GET query parameters for jql, returns nil if JQL query is not set" (let* ((board (org-jira--get-board-from-buffer board-id)) (jql (if (and board (slot-boundp board 'jql)) (oref board jql)))) (if (and jql (not (string-blank-p jql))) `((jql ,jql))))) ;;;###autoload (defun org-jira-get-issues-by-board-headonly () "Get list of ISSUES from agile board, head only." (interactive) (let* ((board (org-jira-read-board)) (board-id (cdr board))) (org-jira-get-issues-headonly (jiralib-get-board-issues board-id :limit (org-jira-get-board-limit board-id) :query-params (org-jira--make-jql-queryparams board-id))))) (defun org-jira--render-boards-from-list (boards) "Add the boards from list into the org file. boards - list of `org-jira-sdk-board' records." (mapc 'org-jira--render-board boards)) (defun org-jira--render-board (board) "Render single board" ;;(org-jira-sdk-dump board) (with-slots (id name url board-type jql limit) board (with-current-buffer (org-jira--get-boards-buffer) (org-jira-mode t) (org-jira-freeze-ui (org-save-outline-visibility t (save-restriction (outline-show-all) (widen) (goto-char (point-min)) (let* ((board-headline (format "Board: [[%s][%s]]" url name)) (headline-pos (org-find-exact-headline-in-buffer board-headline (current-buffer) t)) (entry-exists (and headline-pos (>= headline-pos (point-min)) (<= headline-pos (point-max)))) (limit-value (if (slot-boundp board 'limit) (int-to-string limit) nil)) (jql-value (if (slot-boundp board 'jql) jql nil))) (if entry-exists (progn (goto-char headline-pos) (org-narrow-to-subtree) (end-of-line)) (goto-char (point-max)) (unless (looking-at "^") (insert "\n")) (insert "* ") (org-jira-insert board-headline) (org-narrow-to-subtree)) (org-jira-entry-put (point) "name" name) (org-jira-entry-put (point) "type" board-type) (org-jira-entry-put (point) "url" url) ;; do not overwrite existing user properties with empty values (if (or (not entry-exists) limit-value) (org-jira-entry-put (point) "limit" limit-value)) (if (or (not entry-exists) jql-value) (org-jira-entry-put (point) "JQL" jql-value )) (org-jira-entry-put (point) "ID" id)))))))) (defun org-jira--get-boards-file () (expand-file-name "boards-list.org" org-jira-working-dir)) (defun org-jira--get-boards-buffer () "Return buffer for list of agile boards. Create one if it does not exist." (let* ((boards-file (org-jira--get-boards-file)) (existing-buffer (find-buffer-visiting boards-file))) (if existing-buffer existing-buffer (find-file-noselect boards-file)))) ;;;###autoload (defun org-jira-get-boards () "Get list of boards and their properies." (interactive) (let* ((datalist (jiralib-get-boards)) (boards (org-jira-sdk-create-boards-from-data-list datalist))) (org-jira--render-boards-from-list boards)) (switch-to-buffer (org-jira--get-boards-buffer))) (defun org-jira--get-board-from-buffer (id) "Parse board record from org file." (with-current-buffer (org-jira--get-boards-buffer) (org-jira-freeze-ui (let ((pos (org-find-property "ID" (int-to-string id)))) (if pos (progn (goto-char pos) (apply 'org-jira-sdk-board (reduce #'(lambda (acc entry) (let* ((pname (car entry)) (pval (cdr entry)) (pair (and pval (not (string-empty-p pval)) (cond ((equal pname "ID") (list :id pval)) ((equal pname "URL") (list :url pval)) ((equal pname "TYPE") (list :board-type pval)) ((equal pname "NAME") (list :name pval)) ((equal pname "LIMIT") (list :limit (string-to-number pval))) ((equal pname "JQL") (list :jql pval)) (t nil))))) (if pair (append pair acc) acc))) (org-entry-properties) :initial-value ())))))))) (defun org-jira-get-org-keyword-from-status (status) "Gets an 'org-mode' keyword corresponding to a given jira STATUS." (if org-jira-use-status-as-todo (upcase (replace-regexp-in-string " " "-" status)) (let ((known-keyword (assoc status org-jira-jira-status-to-org-keyword-alist))) (cond (known-keyword (cdr known-keyword)) ((member (org-jira-decode status) org-jira-done-states) "DONE") ("TODO"))))) (defun org-jira-get-org-priority-string (character) "Return an org-priority-string based on CHARACTER and user settings." (cond ((not character) "") ((and org-jira-priority-to-org-priority-omit-default-priority (eq character org-default-priority)) "") (t (format "[#%c] " character)))) (defun org-jira-get-org-priority-cookie-from-issue (priority) "Get the `org-mode' [#X] PRIORITY cookie." (let ((character (cdr (assoc priority org-jira-priority-to-org-priority-alist)))) (org-jira-get-org-priority-string character))) (provide 'org-jira) ;;; org-jira.el ends here ================================================ FILE: t/.nosearch ================================================ ================================================ FILE: t/batch-runner/dash.el ================================================ ;;; dash.el --- A modern list library for Emacs -*- lexical-binding: t -*- ;; Copyright (C) 2012-2016 Free Software Foundation, Inc. ;; Author: Magnar Sveen ;; Version: 2.14.1 ;; Package-Version: 20180726.1213 ;; Keywords: lists ;; 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: ;; A modern list api for Emacs. ;; ;; See documentation on https://github.com/magnars/dash.el#functions ;; ;; **Please note** The lexical binding in this file is not utilised at the ;; moment. We will take full advantage of lexical binding in an upcoming 3.0 ;; release of Dash. In the meantime, we've added the pragma to avoid a bug that ;; you can read more about in https://github.com/magnars/dash.el/issues/130. ;; ;;; Code: (defgroup dash () "Customize group for dash.el" :group 'lisp :prefix "dash-") (defun dash--enable-fontlock (symbol value) (when value (dash-enable-font-lock)) (set-default symbol value)) (defcustom dash-enable-fontlock nil "If non-nil, enable fontification of dash functions, macros and special values." :type 'boolean :set 'dash--enable-fontlock :group 'dash) (defmacro !cons (car cdr) "Destructive: Set CDR to the cons of CAR and CDR." `(setq ,cdr (cons ,car ,cdr))) (defmacro !cdr (list) "Destructive: Set LIST to the cdr of LIST." `(setq ,list (cdr ,list))) (defmacro --each (list &rest body) "Anaphoric form of `-each'." (declare (debug (form body)) (indent 1)) (let ((l (make-symbol "list"))) `(let ((,l ,list) (it-index 0)) (while ,l (let ((it (car ,l))) ,@body) (setq it-index (1+ it-index)) (!cdr ,l))))) (defmacro -doto (eval-initial-value &rest forms) "Eval a form, then insert that form as the 2nd argument to other forms. The EVAL-INITIAL-VALUE form is evaluated once. Its result is passed to FORMS, which are then evaluated sequentially. Returns the target form." (declare (indent 1)) (let ((retval (make-symbol "value"))) `(let ((,retval ,eval-initial-value)) ,@(mapcar (lambda (form) (if (sequencep form) `(,(-first-item form) ,retval ,@(cdr form)) `(funcall form ,retval))) forms) ,retval))) (defun -each (list fn) "Call FN with every item in LIST. Return nil, used for side-effects only." (--each list (funcall fn it))) (put '-each 'lisp-indent-function 1) (defalias '--each-indexed '--each) (defun -each-indexed (list fn) "Call (FN index item) for each item in LIST. In the anaphoric form `--each-indexed', the index is exposed as symbol `it-index'. See also: `-map-indexed'." (--each list (funcall fn it-index it))) (put '-each-indexed 'lisp-indent-function 1) (defmacro --each-while (list pred &rest body) "Anaphoric form of `-each-while'." (declare (debug (form form body)) (indent 2)) (let ((l (make-symbol "list")) (c (make-symbol "continue"))) `(let ((,l ,list) (,c t) (it-index 0)) (while (and ,l ,c) (let ((it (car ,l))) (if (not ,pred) (setq ,c nil) ,@body)) (setq it-index (1+ it-index)) (!cdr ,l))))) (defun -each-while (list pred fn) "Call FN with every item in LIST while (PRED item) is non-nil. Return nil, used for side-effects only." (--each-while list (funcall pred it) (funcall fn it))) (put '-each-while 'lisp-indent-function 2) (defmacro --dotimes (num &rest body) "Repeatedly executes BODY (presumably for side-effects) with symbol `it' bound to integers from 0 through NUM-1." (declare (debug (form body)) (indent 1)) (let ((n (make-symbol "num"))) `(let ((,n ,num) (it 0)) (while (< it ,n) ,@body (setq it (1+ it)))))) (defun -dotimes (num fn) "Repeatedly calls FN (presumably for side-effects) passing in integers from 0 through NUM-1." (--dotimes num (funcall fn it))) (put '-dotimes 'lisp-indent-function 1) (defun -map (fn list) "Return a new list consisting of the result of applying FN to the items in LIST." (mapcar fn list)) (defmacro --map (form list) "Anaphoric form of `-map'." (declare (debug (form form))) `(mapcar (lambda (it) ,form) ,list)) (defmacro --reduce-from (form initial-value list) "Anaphoric form of `-reduce-from'." (declare (debug (form form form))) `(let ((acc ,initial-value)) (--each ,list (setq acc ,form)) acc)) (defun -reduce-from (fn initial-value list) "Return the result of applying FN to INITIAL-VALUE and the first item in LIST, then applying FN to that result and the 2nd item, etc. If LIST contains no items, return INITIAL-VALUE and FN is not called. In the anaphoric form `--reduce-from', the accumulated value is exposed as symbol `acc'. See also: `-reduce', `-reduce-r'" (--reduce-from (funcall fn acc it) initial-value list)) (defmacro --reduce (form list) "Anaphoric form of `-reduce'." (declare (debug (form form))) (let ((lv (make-symbol "list-value"))) `(let ((,lv ,list)) (if ,lv (--reduce-from ,form (car ,lv) (cdr ,lv)) (let (acc it) ,form))))) (defun -reduce (fn list) "Return the result of applying FN to the first 2 items in LIST, then applying FN to that result and the 3rd item, etc. If LIST contains no items, FN must accept no arguments as well, and reduce return the result of calling FN with no arguments. If LIST has only 1 item, it is returned and FN is not called. In the anaphoric form `--reduce', the accumulated value is exposed as symbol `acc'. See also: `-reduce-from', `-reduce-r'" (if list (-reduce-from fn (car list) (cdr list)) (funcall fn))) (defun -reduce-r-from (fn initial-value list) "Replace conses with FN, nil with INITIAL-VALUE and evaluate the resulting expression. If LIST is empty, INITIAL-VALUE is returned and FN is not called. Note: this function works the same as `-reduce-from' but the operation associates from right instead of from left. See also: `-reduce-r', `-reduce'" (if (not list) initial-value (funcall fn (car list) (-reduce-r-from fn initial-value (cdr list))))) (defmacro --reduce-r-from (form initial-value list) "Anaphoric version of `-reduce-r-from'." (declare (debug (form form form))) `(-reduce-r-from (lambda (&optional it acc) ,form) ,initial-value ,list)) (defun -reduce-r (fn list) "Replace conses with FN and evaluate the resulting expression. The final nil is ignored. If LIST contains no items, FN must accept no arguments as well, and reduce return the result of calling FN with no arguments. If LIST has only 1 item, it is returned and FN is not called. The first argument of FN is the new item, the second is the accumulated value. Note: this function works the same as `-reduce' but the operation associates from right instead of from left. See also: `-reduce-r-from', `-reduce'" (cond ((not list) (funcall fn)) ((not (cdr list)) (car list)) (t (funcall fn (car list) (-reduce-r fn (cdr list)))))) (defmacro --reduce-r (form list) "Anaphoric version of `-reduce-r'." (declare (debug (form form))) `(-reduce-r (lambda (&optional it acc) ,form) ,list)) (defun -reductions-from (fn init list) "Return a list of the intermediate values of the reduction. See `-reduce-from' for explanation of the arguments. See also: `-reductions', `-reductions-r', `-reduce-r'" (nreverse (--reduce-from (cons (funcall fn (car acc) it) acc) (list init) list))) (defun -reductions (fn list) "Return a list of the intermediate values of the reduction. See `-reduce' for explanation of the arguments. See also: `-reductions-from', `-reductions-r', `-reduce-r'" (-reductions-from fn (car list) (cdr list))) (defun -reductions-r-from (fn init list) "Return a list of the intermediate values of the reduction. See `-reduce-r-from' for explanation of the arguments. See also: `-reductions-r', `-reductions', `-reduce'" (--reduce-r-from (cons (funcall fn it (car acc)) acc) (list init) list)) (defun -reductions-r (fn list) "Return a list of the intermediate values of the reduction. See `-reduce-r' for explanation of the arguments. See also: `-reductions-r-from', `-reductions', `-reduce'" (-reductions-r-from fn (-last-item list) (-butlast list))) (defmacro --filter (form list) "Anaphoric form of `-filter'. See also: `--remove'." (declare (debug (form form))) (let ((r (make-symbol "result"))) `(let (,r) (--each ,list (when ,form (!cons it ,r))) (nreverse ,r)))) (defun -filter (pred list) "Return a new list of the items in LIST for which PRED returns a non-nil value. Alias: `-select' See also: `-keep', `-remove'." (--filter (funcall pred it) list)) (defalias '-select '-filter) (defalias '--select '--filter) (defmacro --remove (form list) "Anaphoric form of `-remove'. See also `--filter'." (declare (debug (form form))) `(--filter (not ,form) ,list)) (defun -remove (pred list) "Return a new list of the items in LIST for which PRED returns nil. Alias: `-reject' See also: `-filter'." (--remove (funcall pred it) list)) (defalias '-reject '-remove) (defalias '--reject '--remove) (defun -remove-first (pred list) "Return a new list with the first item matching PRED removed. Alias: `-reject-first' See also: `-remove', `-map-first'" (let (front) (while (and list (not (funcall pred (car list)))) (push (car list) front) (!cdr list)) (if list (-concat (nreverse front) (cdr list)) (nreverse front)))) (defmacro --remove-first (form list) "Anaphoric form of `-remove-first'." (declare (debug (form form))) `(-remove-first (lambda (it) ,form) ,list)) (defalias '-reject-first '-remove-first) (defalias '--reject-first '--remove-first) (defun -remove-last (pred list) "Return a new list with the last item matching PRED removed. Alias: `-reject-last' See also: `-remove', `-map-last'" (nreverse (-remove-first pred (reverse list)))) (defmacro --remove-last (form list) "Anaphoric form of `-remove-last'." (declare (debug (form form))) `(-remove-last (lambda (it) ,form) ,list)) (defalias '-reject-last '-remove-last) (defalias '--reject-last '--remove-last) (defun -remove-item (item list) "Remove all occurences of ITEM from LIST. Comparison is done with `equal'." (declare (pure t) (side-effect-free t)) (--remove (equal it item) list)) (defmacro --keep (form list) "Anaphoric form of `-keep'." (declare (debug (form form))) (let ((r (make-symbol "result")) (m (make-symbol "mapped"))) `(let (,r) (--each ,list (let ((,m ,form)) (when ,m (!cons ,m ,r)))) (nreverse ,r)))) (defun -keep (fn list) "Return a new list of the non-nil results of applying FN to the items in LIST. If you want to select the original items satisfying a predicate use `-filter'." (--keep (funcall fn it) list)) (defun -non-nil (list) "Return all non-nil elements of LIST." (declare (pure t) (side-effect-free t)) (-remove 'null list)) (defmacro --map-indexed (form list) "Anaphoric form of `-map-indexed'." (declare (debug (form form))) (let ((r (make-symbol "result"))) `(let (,r) (--each ,list (!cons ,form ,r)) (nreverse ,r)))) (defun -map-indexed (fn list) "Return a new list consisting of the result of (FN index item) for each item in LIST. In the anaphoric form `--map-indexed', the index is exposed as symbol `it-index'. See also: `-each-indexed'." (--map-indexed (funcall fn it-index it) list)) (defmacro --map-when (pred rep list) "Anaphoric form of `-map-when'." (declare (debug (form form form))) (let ((r (make-symbol "result"))) `(let (,r) (--each ,list (!cons (if ,pred ,rep it) ,r)) (nreverse ,r)))) (defun -map-when (pred rep list) "Return a new list where the elements in LIST that do not match the PRED function are unchanged, and where the elements in LIST that do match the PRED function are mapped through the REP function. Alias: `-replace-where' See also: `-update-at'" (--map-when (funcall pred it) (funcall rep it) list)) (defalias '-replace-where '-map-when) (defalias '--replace-where '--map-when) (defun -map-first (pred rep list) "Replace first item in LIST satisfying PRED with result of REP called on this item. See also: `-map-when', `-replace-first'" (let (front) (while (and list (not (funcall pred (car list)))) (push (car list) front) (!cdr list)) (if list (-concat (nreverse front) (cons (funcall rep (car list)) (cdr list))) (nreverse front)))) (defmacro --map-first (pred rep list) "Anaphoric form of `-map-first'." `(-map-first (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list)) (defun -map-last (pred rep list) "Replace last item in LIST satisfying PRED with result of REP called on this item. See also: `-map-when', `-replace-last'" (nreverse (-map-first pred rep (reverse list)))) (defmacro --map-last (pred rep list) "Anaphoric form of `-map-last'." `(-map-last (lambda (it) ,pred) (lambda (it) (ignore it) ,rep) ,list)) (defun -replace (old new list) "Replace all OLD items in LIST with NEW. Elements are compared using `equal'. See also: `-replace-at'" (declare (pure t) (side-effect-free t)) (--map-when (equal it old) new list)) (defun -replace-first (old new list) "Replace the first occurence of OLD with NEW in LIST. Elements are compared using `equal'. See also: `-map-first'" (declare (pure t) (side-effect-free t)) (--map-first (equal old it) new list)) (defun -replace-last (old new list) "Replace the last occurence of OLD with NEW in LIST. Elements are compared using `equal'. See also: `-map-last'" (declare (pure t) (side-effect-free t)) (--map-last (equal old it) new list)) (defmacro --mapcat (form list) "Anaphoric form of `-mapcat'." (declare (debug (form form))) `(apply 'append (--map ,form ,list))) (defun -mapcat (fn list) "Return the concatenation of the result of mapping FN over LIST. Thus function FN should return a list." (--mapcat (funcall fn it) list)) (defun -flatten (l) "Take a nested list L and return its contents as a single, flat list. Note that because `nil' represents a list of zero elements (an empty list), any mention of nil in L will disappear after flattening. If you need to preserve nils, consider `-flatten-n' or map them to some unique symbol and then map them back. Conses of two atoms are considered \"terminals\", that is, they aren't flattened further. See also: `-flatten-n'" (declare (pure t) (side-effect-free t)) (if (and (listp l) (listp (cdr l))) (-mapcat '-flatten l) (list l))) (defmacro --iterate (form init n) "Anaphoric version of `-iterate'." (declare (debug (form form form))) `(-iterate (lambda (it) ,form) ,init ,n)) (defun -flatten-n (num list) "Flatten NUM levels of a nested LIST. See also: `-flatten'" (declare (pure t) (side-effect-free t)) (-last-item (--iterate (--mapcat (-list it) it) list (1+ num)))) (defun -concat (&rest lists) "Return a new list with the concatenation of the elements in the supplied LISTS." (declare (pure t) (side-effect-free t)) (apply 'append lists)) (defalias '-copy 'copy-sequence "Create a shallow copy of LIST. \(fn LIST)") (defun -splice (pred fun list) "Splice lists generated by FUN in place of elements matching PRED in LIST. FUN takes the element matching PRED as input. This function can be used as replacement for `,@' in case you need to splice several lists at marked positions (for example with keywords). See also: `-splice-list', `-insert-at'" (let (r) (--each list (if (funcall pred it) (let ((new (funcall fun it))) (--each new (!cons it r))) (!cons it r))) (nreverse r))) (defmacro --splice (pred form list) "Anaphoric form of `-splice'." `(-splice (lambda (it) ,pred) (lambda (it) ,form) ,list)) (defun -splice-list (pred new-list list) "Splice NEW-LIST in place of elements matching PRED in LIST. See also: `-splice', `-insert-at'" (-splice pred (lambda (_) new-list) list)) (defmacro --splice-list (pred new-list list) "Anaphoric form of `-splice-list'." `(-splice-list (lambda (it) ,pred) ,new-list ,list)) (defun -cons* (&rest args) "Make a new list from the elements of ARGS. The last 2 members of ARGS are used as the final cons of the result so if the final member of ARGS is not a list the result is a dotted list." (declare (pure t) (side-effect-free t)) (-reduce-r 'cons args)) (defun -snoc (list elem &rest elements) "Append ELEM to the end of the list. This is like `cons', but operates on the end of list. If ELEMENTS is non nil, append these to the list as well." (-concat list (list elem) elements)) (defmacro --first (form list) "Anaphoric form of `-first'." (declare (debug (form form))) (let ((n (make-symbol "needle"))) `(let (,n) (--each-while ,list (not ,n) (when ,form (setq ,n it))) ,n))) (defun -first (pred list) "Return the first x in LIST where (PRED x) is non-nil, else nil. To get the first item in the list no questions asked, use `car'. Alias: `-find'" (--first (funcall pred it) list)) (defalias '-find '-first) (defalias '--find '--first) (defmacro --some (form list) "Anaphoric form of `-some'." (declare (debug (form form))) (let ((n (make-symbol "needle"))) `(let (,n) (--each-while ,list (not ,n) (setq ,n ,form)) ,n))) (defun -some (pred list) "Return (PRED x) for the first LIST item where (PRED x) is non-nil, else nil. Alias: `-any'" (--some (funcall pred it) list)) (defalias '-any '-some) (defalias '--any '--some) (defmacro --last (form list) "Anaphoric form of `-last'." (declare (debug (form form))) (let ((n (make-symbol "needle"))) `(let (,n) (--each ,list (when ,form (setq ,n it))) ,n))) (defun -last (pred list) "Return the last x in LIST where (PRED x) is non-nil, else nil." (--last (funcall pred it) list)) (defalias '-first-item 'car "Return the first item of LIST, or nil on an empty list. See also: `-second-item', `-last-item'. \(fn LIST)") ;; Ensure that calls to `-first-item' are compiled to a single opcode, ;; just like `car'. (put '-first-item 'byte-opcode 'byte-car) (put '-first-item 'byte-compile 'byte-compile-one-arg) (defalias '-second-item 'cadr "Return the second item of LIST, or nil if LIST is too short. See also: `-third-item'. \(fn LIST)") (defalias '-third-item 'caddr "Return the third item of LIST, or nil if LIST is too short. See also: `-fourth-item'. \(fn LIST)") (defun -fourth-item (list) "Return the fourth item of LIST, or nil if LIST is too short. See also: `-fifth-item'." (declare (pure t) (side-effect-free t)) (car (cdr (cdr (cdr list))))) (defun -fifth-item (list) "Return the fifth item of LIST, or nil if LIST is too short. See also: `-last-item'." (declare (pure t) (side-effect-free t)) (car (cdr (cdr (cdr (cdr list)))))) ;; TODO: gv was introduced in 24.3, so we can remove the if statement ;; when support for earlier versions is dropped (eval-when-compile (require 'cl) (if (fboundp 'gv-define-simple-setter) (gv-define-simple-setter -first-item setcar) (require 'cl) (with-no-warnings (defsetf -first-item (x) (val) `(setcar ,x ,val))))) (defun -last-item (list) "Return the last item of LIST, or nil on an empty list." (declare (pure t) (side-effect-free t)) (car (last list))) ;; TODO: gv was introduced in 24.3, so we can remove the if statement ;; when support for earlier versions is dropped (eval-when-compile (if (fboundp 'gv-define-setter) (gv-define-setter -last-item (val x) `(setcar (last ,x) ,val)) (with-no-warnings (defsetf -last-item (x) (val) `(setcar (last ,x) ,val))))) (defun -butlast (list) "Return a list of all items in list except for the last." ;; no alias as we don't want magic optional argument (declare (pure t) (side-effect-free t)) (butlast list)) (defmacro --count (pred list) "Anaphoric form of `-count'." (declare (debug (form form))) (let ((r (make-symbol "result"))) `(let ((,r 0)) (--each ,list (when ,pred (setq ,r (1+ ,r)))) ,r))) (defun -count (pred list) "Counts the number of items in LIST where (PRED item) is non-nil." (--count (funcall pred it) list)) (defun ---truthy? (val) (declare (pure t) (side-effect-free t)) (not (null val))) (defmacro --any? (form list) "Anaphoric form of `-any?'." (declare (debug (form form))) `(---truthy? (--some ,form ,list))) (defun -any? (pred list) "Return t if (PRED x) is non-nil for any x in LIST, else nil. Alias: `-any-p', `-some?', `-some-p'" (--any? (funcall pred it) list)) (defalias '-some? '-any?) (defalias '--some? '--any?) (defalias '-any-p '-any?) (defalias '--any-p '--any?) (defalias '-some-p '-any?) (defalias '--some-p '--any?) (defmacro --all? (form list) "Anaphoric form of `-all?'." (declare (debug (form form))) (let ((a (make-symbol "all"))) `(let ((,a t)) (--each-while ,list ,a (setq ,a ,form)) (---truthy? ,a)))) (defun -all? (pred list) "Return t if (PRED x) is non-nil for all x in LIST, else nil. Alias: `-all-p', `-every?', `-every-p'" (--all? (funcall pred it) list)) (defalias '-every? '-all?) (defalias '--every? '--all?) (defalias '-all-p '-all?) (defalias '--all-p '--all?) (defalias '-every-p '-all?) (defalias '--every-p '--all?) (defmacro --none? (form list) "Anaphoric form of `-none?'." (declare (debug (form form))) `(--all? (not ,form) ,list)) (defun -none? (pred list) "Return t if (PRED x) is nil for all x in LIST, else nil. Alias: `-none-p'" (--none? (funcall pred it) list)) (defalias '-none-p '-none?) (defalias '--none-p '--none?) (defmacro --only-some? (form list) "Anaphoric form of `-only-some?'." (declare (debug (form form))) (let ((y (make-symbol "yes")) (n (make-symbol "no"))) `(let (,y ,n) (--each-while ,list (not (and ,y ,n)) (if ,form (setq ,y t) (setq ,n t))) (---truthy? (and ,y ,n))))) (defun -only-some? (pred list) "Return `t` if at least one item of LIST matches PRED and at least one item of LIST does not match PRED. Return `nil` both if all items match the predicate or if none of the items match the predicate. Alias: `-only-some-p'" (--only-some? (funcall pred it) list)) (defalias '-only-some-p '-only-some?) (defalias '--only-some-p '--only-some?) (defun -slice (list from &optional to step) "Return copy of LIST, starting from index FROM to index TO. FROM or TO may be negative. These values are then interpreted modulo the length of the list. If STEP is a number, only each STEPth item in the resulting section is returned. Defaults to 1." (declare (pure t) (side-effect-free t)) (let ((length (length list)) (new-list nil)) ;; to defaults to the end of the list (setq to (or to length)) (setq step (or step 1)) ;; handle negative indices (when (< from 0) (setq from (mod from length))) (when (< to 0) (setq to (mod to length))) ;; iterate through the list, keeping the elements we want (--each-while list (< it-index to) (when (and (>= it-index from) (= (mod (- from it-index) step) 0)) (push it new-list))) (nreverse new-list))) (defun -take (n list) "Return a new list of the first N items in LIST, or all items if there are fewer than N. See also: `-take-last'" (declare (pure t) (side-effect-free t)) (let (result) (--dotimes n (when list (!cons (car list) result) (!cdr list))) (nreverse result))) (defun -take-last (n list) "Return the last N items of LIST in order. See also: `-take'" (declare (pure t) (side-effect-free t)) (copy-sequence (last list n))) (defalias '-drop 'nthcdr "Return the tail of LIST without the first N items. See also: `-drop-last' \(fn N LIST)") (defun -drop-last (n list) "Remove the last N items of LIST and return a copy. See also: `-drop'" ;; No alias because we don't want magic optional argument (declare (pure t) (side-effect-free t)) (butlast list n)) (defmacro --take-while (form list) "Anaphoric form of `-take-while'." (declare (debug (form form))) (let ((r (make-symbol "result"))) `(let (,r) (--each-while ,list ,form (!cons it ,r)) (nreverse ,r)))) (defun -take-while (pred list) "Return a new list of successive items from LIST while (PRED item) returns a non-nil value." (--take-while (funcall pred it) list)) (defmacro --drop-while (form list) "Anaphoric form of `-drop-while'." (declare (debug (form form))) (let ((l (make-symbol "list"))) `(let ((,l ,list)) (while (and ,l (let ((it (car ,l))) ,form)) (!cdr ,l)) ,l))) (defun -drop-while (pred list) "Return the tail of LIST starting from the first item for which (PRED item) returns nil." (--drop-while (funcall pred it) list)) (defun -split-at (n list) "Return a list of ((-take N LIST) (-drop N LIST)), in no more than one pass through the list." (declare (pure t) (side-effect-free t)) (let (result) (--dotimes n (when list (!cons (car list) result) (!cdr list))) (list (nreverse result) list))) (defun -rotate (n list) "Rotate LIST N places to the right. With N negative, rotate to the left. The time complexity is O(n)." (declare (pure t) (side-effect-free t)) (if (> n 0) (append (last list n) (butlast list n)) (append (-drop (- n) list) (-take (- n) list)))) (defun -insert-at (n x list) "Return a list with X inserted into LIST at position N. See also: `-splice', `-splice-list'" (declare (pure t) (side-effect-free t)) (let ((split-list (-split-at n list))) (nconc (car split-list) (cons x (cadr split-list))))) (defun -replace-at (n x list) "Return a list with element at Nth position in LIST replaced with X. See also: `-replace'" (declare (pure t) (side-effect-free t)) (let ((split-list (-split-at n list))) (nconc (car split-list) (cons x (cdr (cadr split-list)))))) (defun -update-at (n func list) "Return a list with element at Nth position in LIST replaced with `(func (nth n list))`. See also: `-map-when'" (let ((split-list (-split-at n list))) (nconc (car split-list) (cons (funcall func (car (cadr split-list))) (cdr (cadr split-list)))))) (defmacro --update-at (n form list) "Anaphoric version of `-update-at'." (declare (debug (form form form))) `(-update-at ,n (lambda (it) ,form) ,list)) (defun -remove-at (n list) "Return a list with element at Nth position in LIST removed. See also: `-remove-at-indices', `-remove'" (declare (pure t) (side-effect-free t)) (-remove-at-indices (list n) list)) (defun -remove-at-indices (indices list) "Return a list whose elements are elements from LIST without elements selected as `(nth i list)` for all i from INDICES. See also: `-remove-at', `-remove'" (declare (pure t) (side-effect-free t)) (let* ((indices (-sort '< indices)) (diffs (cons (car indices) (-map '1- (-zip-with '- (cdr indices) indices)))) r) (--each diffs (let ((split (-split-at it list))) (!cons (car split) r) (setq list (cdr (cadr split))))) (!cons list r) (apply '-concat (nreverse r)))) (defmacro --split-with (pred list) "Anaphoric form of `-split-with'." (declare (debug (form form))) (let ((l (make-symbol "list")) (r (make-symbol "result")) (c (make-symbol "continue"))) `(let ((,l ,list) (,r nil) (,c t)) (while (and ,l ,c) (let ((it (car ,l))) (if (not ,pred) (setq ,c nil) (!cons it ,r) (!cdr ,l)))) (list (nreverse ,r) ,l)))) (defun -split-with (pred list) "Return a list of ((-take-while PRED LIST) (-drop-while PRED LIST)), in no more than one pass through the list." (--split-with (funcall pred it) list)) (defmacro -split-on (item list) "Split the LIST each time ITEM is found. Unlike `-partition-by', the ITEM is discarded from the results. Empty lists are also removed from the result. Comparison is done by `equal'. See also `-split-when'" (declare (debug (form form))) `(-split-when (lambda (it) (equal it ,item)) ,list)) (defmacro --split-when (form list) "Anaphoric version of `-split-when'." (declare (debug (form form))) `(-split-when (lambda (it) ,form) ,list)) (defun -split-when (fn list) "Split the LIST on each element where FN returns non-nil. Unlike `-partition-by', the \"matched\" element is discarded from the results. Empty lists are also removed from the result. This function can be thought of as a generalization of `split-string'." (let (r s) (while list (if (not (funcall fn (car list))) (push (car list) s) (when s (push (nreverse s) r)) (setq s nil)) (!cdr list)) (when s (push (nreverse s) r)) (nreverse r))) (defmacro --separate (form list) "Anaphoric form of `-separate'." (declare (debug (form form))) (let ((y (make-symbol "yes")) (n (make-symbol "no"))) `(let (,y ,n) (--each ,list (if ,form (!cons it ,y) (!cons it ,n))) (list (nreverse ,y) (nreverse ,n))))) (defun -separate (pred list) "Return a list of ((-filter PRED LIST) (-remove PRED LIST)), in one pass through the list." (--separate (funcall pred it) list)) (defun ---partition-all-in-steps-reversed (n step list) "Private: Used by -partition-all-in-steps and -partition-in-steps." (when (< step 1) (error "Step must be a positive number, or you're looking at some juicy infinite loops.")) (let ((result nil)) (while list (!cons (-take n list) result) (setq list (-drop step list))) result)) (defun -partition-all-in-steps (n step list) "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart. The last groups may contain less than N items." (declare (pure t) (side-effect-free t)) (nreverse (---partition-all-in-steps-reversed n step list))) (defun -partition-in-steps (n step list) "Return a new list with the items in LIST grouped into N-sized sublists at offsets STEP apart. If there are not enough items to make the last group N-sized, those items are discarded." (declare (pure t) (side-effect-free t)) (let ((result (---partition-all-in-steps-reversed n step list))) (while (and result (< (length (car result)) n)) (!cdr result)) (nreverse result))) (defun -partition-all (n list) "Return a new list with the items in LIST grouped into N-sized sublists. The last group may contain less than N items." (declare (pure t) (side-effect-free t)) (-partition-all-in-steps n n list)) (defun -partition (n list) "Return a new list with the items in LIST grouped into N-sized sublists. If there are not enough items to make the last group N-sized, those items are discarded." (declare (pure t) (side-effect-free t)) (-partition-in-steps n n list)) (defmacro --partition-by (form list) "Anaphoric form of `-partition-by'." (declare (debug (form form))) (let ((r (make-symbol "result")) (s (make-symbol "sublist")) (v (make-symbol "value")) (n (make-symbol "new-value")) (l (make-symbol "list"))) `(let ((,l ,list)) (when ,l (let* ((,r nil) (it (car ,l)) (,s (list it)) (,v ,form) (,l (cdr ,l))) (while ,l (let* ((it (car ,l)) (,n ,form)) (unless (equal ,v ,n) (!cons (nreverse ,s) ,r) (setq ,s nil) (setq ,v ,n)) (!cons it ,s) (!cdr ,l))) (!cons (nreverse ,s) ,r) (nreverse ,r)))))) (defun -partition-by (fn list) "Apply FN to each item in LIST, splitting it each time FN returns a new value." (--partition-by (funcall fn it) list)) (defmacro --partition-by-header (form list) "Anaphoric form of `-partition-by-header'." (declare (debug (form form))) (let ((r (make-symbol "result")) (s (make-symbol "sublist")) (h (make-symbol "header-value")) (b (make-symbol "seen-body?")) (n (make-symbol "new-value")) (l (make-symbol "list"))) `(let ((,l ,list)) (when ,l (let* ((,r nil) (it (car ,l)) (,s (list it)) (,h ,form) (,b nil) (,l (cdr ,l))) (while ,l (let* ((it (car ,l)) (,n ,form)) (if (equal ,h ,n) (when ,b (!cons (nreverse ,s) ,r) (setq ,s nil) (setq ,b nil)) (setq ,b t)) (!cons it ,s) (!cdr ,l))) (!cons (nreverse ,s) ,r) (nreverse ,r)))))) (defun -partition-by-header (fn list) "Apply FN to the first item in LIST. That is the header value. Apply FN to each item in LIST, splitting it each time FN returns the header value, but only after seeing at least one other value (the body)." (--partition-by-header (funcall fn it) list)) (defun -partition-after-pred (pred list) "Partition directly after each time PRED is true on an element of LIST." (when list (let ((rest (-partition-after-pred pred (cdr list)))) (if (funcall pred (car list)) ;;split after (car list) (cons (list (car list)) rest) ;;don't split after (car list) (cons (cons (car list) (car rest)) (cdr rest)))))) (defun -partition-before-pred (pred list) "Partition directly before each time PRED is true on an element of LIST." (nreverse (-map #'reverse (-partition-after-pred pred (reverse list))))) (defun -partition-after-item (item list) "Partition directly after each time ITEM appears in LIST." (-partition-after-pred (lambda (ele) (equal ele item)) list)) (defun -partition-before-item (item list) "Partition directly before each time ITEM appears in LIST." (-partition-before-pred (lambda (ele) (equal ele item)) list)) (defmacro --group-by (form list) "Anaphoric form of `-group-by'." (declare (debug t)) (let ((n (make-symbol "n")) (k (make-symbol "k")) (grp (make-symbol "grp"))) `(nreverse (-map (lambda (,n) (cons (car ,n) (nreverse (cdr ,n)))) (--reduce-from (let* ((,k (,@form)) (,grp (assoc ,k acc))) (if ,grp (setcdr ,grp (cons it (cdr ,grp))) (push (list ,k it) acc)) acc) nil ,list))))) (defun -group-by (fn list) "Separate LIST into an alist whose keys are FN applied to the elements of LIST. Keys are compared by `equal'." (--group-by (funcall fn it) list)) (defun -interpose (sep list) "Return a new list of all elements in LIST separated by SEP." (declare (pure t) (side-effect-free t)) (let (result) (when list (!cons (car list) result) (!cdr list)) (while list (setq result (cons (car list) (cons sep result))) (!cdr list)) (nreverse result))) (defun -interleave (&rest lists) "Return a new list of the first item in each list, then the second etc." (declare (pure t) (side-effect-free t)) (when lists (let (result) (while (-none? 'null lists) (--each lists (!cons (car it) result)) (setq lists (-map 'cdr lists))) (nreverse result)))) (defmacro --zip-with (form list1 list2) "Anaphoric form of `-zip-with'. The elements in list1 are bound as symbol `it', the elements in list2 as symbol `other'." (declare (debug (form form form))) (let ((r (make-symbol "result")) (l1 (make-symbol "list1")) (l2 (make-symbol "list2"))) `(let ((,r nil) (,l1 ,list1) (,l2 ,list2)) (while (and ,l1 ,l2) (let ((it (car ,l1)) (other (car ,l2))) (!cons ,form ,r) (!cdr ,l1) (!cdr ,l2))) (nreverse ,r)))) (defun -zip-with (fn list1 list2) "Zip the two lists LIST1 and LIST2 using a function FN. This function is applied pairwise taking as first argument element of LIST1 and as second argument element of LIST2 at corresponding position. The anaphoric form `--zip-with' binds the elements from LIST1 as symbol `it', and the elements from LIST2 as symbol `other'." (--zip-with (funcall fn it other) list1 list2)) (defun -zip (&rest lists) "Zip LISTS together. Group the head of each list, followed by the second elements of each list, and so on. The lengths of the returned groupings are equal to the length of the shortest input list. If two lists are provided as arguments, return the groupings as a list of cons cells. Otherwise, return the groupings as a list of lists. Please note! This distinction is being removed in an upcoming 3.0 release of Dash. If you rely on this behavior, use -zip-pair instead." (declare (pure t) (side-effect-free t)) (when lists (let (results) (while (-none? 'null lists) (setq results (cons (mapcar 'car lists) results)) (setq lists (mapcar 'cdr lists))) (setq results (nreverse results)) (if (= (length lists) 2) ;; to support backward compatability, return ;; a cons cell if two lists were provided (--map (cons (car it) (cadr it)) results) results)))) (defalias '-zip-pair '-zip) (defun -zip-fill (fill-value &rest lists) "Zip LISTS, with FILL-VALUE padded onto the shorter lists. The lengths of the returned groupings are equal to the length of the longest input list." (declare (pure t) (side-effect-free t)) (apply '-zip (apply '-pad (cons fill-value lists)))) (defun -unzip (lists) "Unzip LISTS. This works just like `-zip' but takes a list of lists instead of a variable number of arguments, such that (-unzip (-zip L1 L2 L3 ...)) is identity (given that the lists are the same length). See also: `-zip'" (apply '-zip lists)) (defun -cycle (list) "Return an infinite copy of LIST that will cycle through the elements and repeat from the beginning." (declare (pure t) (side-effect-free t)) (let ((newlist (-map 'identity list))) (nconc newlist newlist))) (defun -pad (fill-value &rest lists) "Appends FILL-VALUE to the end of each list in LISTS such that they will all have the same length." (let* ((annotations (-annotate 'length lists)) (n (-max (-map 'car annotations)))) (--map (append (cdr it) (-repeat (- n (car it)) fill-value)) annotations))) (defun -annotate (fn list) "Return a list of cons cells where each cell is FN applied to each element of LIST paired with the unmodified element of LIST." (-zip (-map fn list) list)) (defmacro --annotate (form list) "Anaphoric version of `-annotate'." (declare (debug (form form))) `(-annotate (lambda (it) ,form) ,list)) (defun dash--table-carry (lists restore-lists &optional re) "Helper for `-table' and `-table-flat'. If a list overflows, carry to the right and reset the list." (while (not (or (car lists) (equal lists '(nil)))) (setcar lists (car restore-lists)) (pop (cadr lists)) (!cdr lists) (!cdr restore-lists) (when re (push (nreverse (car re)) (cadr re)) (setcar re nil) (!cdr re)))) (defun -table (fn &rest lists) "Compute outer product of LISTS using function FN. The function FN should have the same arity as the number of supplied lists. The outer product is computed by applying fn to all possible combinations created by taking one element from each list in order. The dimension of the result is (length lists). See also: `-table-flat'" (let ((restore-lists (copy-sequence lists)) (last-list (last lists)) (re (make-list (length lists) nil))) (while (car last-list) (let ((item (apply fn (-map 'car lists)))) (push item (car re)) (setcar lists (cdar lists)) ;; silence byte compiler (dash--table-carry lists restore-lists re))) (nreverse (car (last re))))) (defun -table-flat (fn &rest lists) "Compute flat outer product of LISTS using function FN. The function FN should have the same arity as the number of supplied lists. The outer product is computed by applying fn to all possible combinations created by taking one element from each list in order. The results are flattened, ignoring the tensor structure of the result. This is equivalent to calling: (-flatten-n (1- (length lists)) (apply \\='-table fn lists)) but the implementation here is much more efficient. See also: `-flatten-n', `-table'" (let ((restore-lists (copy-sequence lists)) (last-list (last lists)) re) (while (car last-list) (let ((item (apply fn (-map 'car lists)))) (push item re) (setcar lists (cdar lists)) ;; silence byte compiler (dash--table-carry lists restore-lists))) (nreverse re))) (defun -partial (fn &rest args) "Take a function FN and fewer than the normal arguments to FN, and return a fn that takes a variable number of additional ARGS. When called, the returned function calls FN with ARGS first and then additional args." (apply 'apply-partially fn args)) (defun -elem-index (elem list) "Return the index of the first element in the given LIST which is equal to the query element ELEM, or nil if there is no such element." (declare (pure t) (side-effect-free t)) (car (-elem-indices elem list))) (defun -elem-indices (elem list) "Return the indices of all elements in LIST equal to the query element ELEM, in ascending order." (declare (pure t) (side-effect-free t)) (-find-indices (-partial 'equal elem) list)) (defun -find-indices (pred list) "Return the indices of all elements in LIST satisfying the predicate PRED, in ascending order." (apply 'append (--map-indexed (when (funcall pred it) (list it-index)) list))) (defmacro --find-indices (form list) "Anaphoric version of `-find-indices'." (declare (debug (form form))) `(-find-indices (lambda (it) ,form) ,list)) (defun -find-index (pred list) "Take a predicate PRED and a LIST and return the index of the first element in the list satisfying the predicate, or nil if there is no such element. See also `-first'." (car (-find-indices pred list))) (defmacro --find-index (form list) "Anaphoric version of `-find-index'." (declare (debug (form form))) `(-find-index (lambda (it) ,form) ,list)) (defun -find-last-index (pred list) "Take a predicate PRED and a LIST and return the index of the last element in the list satisfying the predicate, or nil if there is no such element. See also `-last'." (-last-item (-find-indices pred list))) (defmacro --find-last-index (form list) "Anaphoric version of `-find-last-index'." `(-find-last-index (lambda (it) ,form) ,list)) (defun -select-by-indices (indices list) "Return a list whose elements are elements from LIST selected as `(nth i list)` for all i from INDICES." (declare (pure t) (side-effect-free t)) (let (r) (--each indices (!cons (nth it list) r)) (nreverse r))) (defun -select-columns (columns table) "Select COLUMNS from TABLE. TABLE is a list of lists where each element represents one row. It is assumed each row has the same length. Each row is transformed such that only the specified COLUMNS are selected. See also: `-select-column', `-select-by-indices'" (declare (pure t) (side-effect-free t)) (--map (-select-by-indices columns it) table)) (defun -select-column (column table) "Select COLUMN from TABLE. TABLE is a list of lists where each element represents one row. It is assumed each row has the same length. The single selected column is returned as a list. See also: `-select-columns', `-select-by-indices'" (declare (pure t) (side-effect-free t)) (--mapcat (-select-by-indices (list column) it) table)) (defmacro -> (x &optional form &rest more) "Thread the expr through the forms. Insert X as the second item in the first form, making a list of it if it is not a list already. If there are more forms, insert the first form as the second item in second form, etc." (declare (debug (form &rest [&or symbolp (sexp &rest form)]))) (cond ((null form) x) ((null more) (if (listp form) `(,(car form) ,x ,@(cdr form)) (list form x))) (:else `(-> (-> ,x ,form) ,@more)))) (defmacro ->> (x &optional form &rest more) "Thread the expr through the forms. Insert X 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, insert the first form as the last item in second form, etc." (declare (debug ->)) (cond ((null form) x) ((null more) (if (listp form) `(,@form ,x) (list form x))) (:else `(->> (->> ,x ,form) ,@more)))) (defmacro --> (x &rest forms) "Starting with the value of X, thread each expression through FORMS. Insert X at the position signified by the symbol `it' in the first form. If there are more forms, insert the first form at the position signified by `it' in in second form, etc." (declare (debug (form body))) `(-as-> ,x it ,@forms)) (defmacro -as-> (value variable &rest forms) "Starting with VALUE, thread VARIABLE through FORMS. In the first form, bind VARIABLE to VALUE. In the second form, bind VARIABLE to the result of the first form, and so forth." (declare (debug (form symbolp body))) (if (null forms) `,value `(let ((,variable ,value)) (-as-> ,(if (symbolp (car forms)) (list (car forms) variable) (car forms)) ,variable ,@(cdr forms))))) (defmacro -some-> (x &optional form &rest more) "When expr is non-nil, thread it through the first form (via `->'), and when that result is non-nil, through the next form, etc." (declare (debug ->)) (if (null form) x (let ((result (make-symbol "result"))) `(-some-> (-when-let (,result ,x) (-> ,result ,form)) ,@more)))) (defmacro -some->> (x &optional form &rest more) "When expr is non-nil, thread it through the first form (via `->>'), and when that result is non-nil, through the next form, etc." (declare (debug ->)) (if (null form) x (let ((result (make-symbol "result"))) `(-some->> (-when-let (,result ,x) (->> ,result ,form)) ,@more)))) (defmacro -some--> (x &optional form &rest more) "When expr in non-nil, thread it through the first form (via `-->'), and when that result is non-nil, through the next form, etc." (declare (debug ->)) (if (null form) x (let ((result (make-symbol "result"))) `(-some--> (-when-let (,result ,x) (--> ,result ,form)) ,@more)))) (defun -grade-up (comparator list) "Grade elements of LIST using COMPARATOR relation, yielding a permutation vector such that applying this permutation to LIST sorts it in ascending order." ;; ugly hack to "fix" lack of lexical scope (let ((comp `(lambda (it other) (funcall ',comparator (car it) (car other))))) (->> (--map-indexed (cons it it-index) list) (-sort comp) (-map 'cdr)))) (defun -grade-down (comparator list) "Grade elements of LIST using COMPARATOR relation, yielding a permutation vector such that applying this permutation to LIST sorts it in descending order." ;; ugly hack to "fix" lack of lexical scope (let ((comp `(lambda (it other) (funcall ',comparator (car other) (car it))))) (->> (--map-indexed (cons it it-index) list) (-sort comp) (-map 'cdr)))) (defvar dash--source-counter 0 "Monotonic counter for generated symbols.") (defun dash--match-make-source-symbol () "Generate a new dash-source symbol. All returned symbols are guaranteed to be unique." (prog1 (make-symbol (format "--dash-source-%d--" dash--source-counter)) (setq dash--source-counter (1+ dash--source-counter)))) (defun dash--match-ignore-place-p (symbol) "Return non-nil if SYMBOL is a symbol and starts with _." (and (symbolp symbol) (eq (aref (symbol-name symbol) 0) ?_))) (defun dash--match-cons-skip-cdr (skip-cdr source) "Helper function generating idiomatic shifting code." (cond ((= skip-cdr 0) `(pop ,source)) (t `(prog1 ,(dash--match-cons-get-car skip-cdr source) (setq ,source ,(dash--match-cons-get-cdr (1+ skip-cdr) source)))))) (defun dash--match-cons-get-car (skip-cdr source) "Helper function generating idiomatic code to get nth car." (cond ((= skip-cdr 0) `(car ,source)) ((= skip-cdr 1) `(cadr ,source)) (t `(nth ,skip-cdr ,source)))) (defun dash--match-cons-get-cdr (skip-cdr source) "Helper function generating idiomatic code to get nth cdr." (cond ((= skip-cdr 0) source) ((= skip-cdr 1) `(cdr ,source)) (t `(nthcdr ,skip-cdr ,source)))) (defun dash--match-cons (match-form source) "Setup a cons matching environment and call the real matcher." (let ((s (dash--match-make-source-symbol)) (n 0) (m match-form)) (while (and (consp m) (dash--match-ignore-place-p (car m))) (setq n (1+ n)) (!cdr m)) (cond ;; when we only have one pattern in the list, we don't have to ;; create a temporary binding (--dash-source--) for the source ;; and just use the input directly ((and (consp m) (not (cdr m))) (dash--match (car m) (dash--match-cons-get-car n source))) ;; handle other special types ((> n 0) (dash--match m (dash--match-cons-get-cdr n source))) ;; this is the only entry-point for dash--match-cons-1, that's ;; why we can't simply use the above branch, it would produce ;; infinite recursion (t (cons (list s source) (dash--match-cons-1 match-form s)))))) (defun dash--match-cons-1 (match-form source &optional props) "Match MATCH-FORM against SOURCE. MATCH-FORM is a proper or improper list. Each element of MATCH-FORM is either a symbol, which gets bound to the respective value in source or another match form which gets destructured recursively. If the cdr of last cons cell in the list is `nil', matching stops there. SOURCE is a proper or improper list." (let ((skip-cdr (or (plist-get props :skip-cdr) 0))) (cond ((consp match-form) (cond ((cdr match-form) (cond ((and (symbolp (car match-form)) (memq (car match-form) '(&keys &plist &alist &hash))) (dash--match-kv (dash--match-kv-normalize-match-form match-form) (dash--match-cons-get-cdr skip-cdr source))) ((dash--match-ignore-place-p (car match-form)) (dash--match-cons-1 (cdr match-form) source (plist-put props :skip-cdr (1+ skip-cdr)))) (t (-concat (dash--match (car match-form) (dash--match-cons-skip-cdr skip-cdr source)) (dash--match-cons-1 (cdr match-form) source))))) (t ;; Last matching place, no need for shift (dash--match (car match-form) (dash--match-cons-get-car skip-cdr source))))) ((eq match-form nil) nil) (t ;; Handle improper lists. Last matching place, no need for shift (dash--match match-form (dash--match-cons-get-cdr skip-cdr source)))))) (defun dash--vector-tail (seq start) "Return the tail of SEQ starting at START." (cond ((vectorp seq) (let* ((re-length (- (length seq) start)) (re (make-vector re-length 0))) (--dotimes re-length (aset re it (aref seq (+ it start)))) re)) ((stringp seq) (substring seq start)))) (defun dash--match-vector (match-form source) "Setup a vector matching environment and call the real matcher." (let ((s (dash--match-make-source-symbol))) (cond ;; don't bind `s' if we only have one sub-pattern ((= (length match-form) 1) (dash--match (aref match-form 0) `(aref ,source 0))) ;; if the source is a symbol, we don't need to re-bind it ((symbolp source) (dash--match-vector-1 match-form source)) ;; don't bind `s' if we only have one sub-pattern which is not ignored ((let* ((ignored-places (mapcar 'dash--match-ignore-place-p match-form)) (ignored-places-n (length (-remove 'null ignored-places)))) (when (= ignored-places-n (1- (length match-form))) (let ((n (-find-index 'null ignored-places))) (dash--match (aref match-form n) `(aref ,source ,n)))))) (t (cons (list s source) (dash--match-vector-1 match-form s)))))) (defun dash--match-vector-1 (match-form source) "Match MATCH-FORM against SOURCE. MATCH-FORM is a vector. Each element of MATCH-FORM is either a symbol, which gets bound to the respective value in source or another match form which gets destructured recursively. If second-from-last place in MATCH-FORM is the symbol &rest, the next element of the MATCH-FORM is matched against the tail of SOURCE, starting at index of the &rest symbol. This is conceptually the same as the (head . tail) match for improper lists, where dot plays the role of &rest. SOURCE is a vector. If the MATCH-FORM vector is shorter than SOURCE vector, only the (length MATCH-FORM) places are bound, the rest of the SOURCE is discarded." (let ((i 0) (l (length match-form)) (re)) (while (< i l) (let ((m (aref match-form i))) (push (cond ((and (symbolp m) (eq m '&rest)) (prog1 (dash--match (aref match-form (1+ i)) `(dash--vector-tail ,source ,i)) (setq i l))) ((and (symbolp m) ;; do not match symbols starting with _ (not (eq (aref (symbol-name m) 0) ?_))) (list (list m `(aref ,source ,i)))) ((not (symbolp m)) (dash--match m `(aref ,source ,i)))) re) (setq i (1+ i)))) (-flatten-n 1 (nreverse re)))) (defun dash--match-kv-normalize-match-form (pattern) "Normalize kv PATTERN. This method normalizes PATTERN to the format expected by `dash--match-kv'. See `-let' for the specification." (let ((normalized (list (car pattern))) (skip nil) (fill-placeholder (make-symbol "--dash-fill-placeholder--"))) (-each (apply '-zip (-pad fill-placeholder (cdr pattern) (cddr pattern))) (lambda (pair) (let ((current (car pair)) (next (cdr pair))) (if skip (setq skip nil) (if (or (eq fill-placeholder next) (not (or (and (symbolp next) (not (keywordp next)) (not (eq next t)) (not (eq next nil))) (and (consp next) (not (eq (car next) 'quote))) (vectorp next)))) (progn (cond ((keywordp current) (push current normalized) (push (intern (substring (symbol-name current) 1)) normalized)) ((stringp current) (push current normalized) (push (intern current) normalized)) ((and (consp current) (eq (car current) 'quote)) (push current normalized) (push (cadr current) normalized)) (t (error "-let: found key `%s' in kv destructuring but its pattern `%s' is invalid and can not be derived from the key" current next))) (setq skip nil)) (push current normalized) (push next normalized) (setq skip t)))))) (nreverse normalized))) (defun dash--match-kv (match-form source) "Setup a kv matching environment and call the real matcher. kv can be any key-value store, such as plist, alist or hash-table." (let ((s (dash--match-make-source-symbol))) (cond ;; don't bind `s' if we only have one sub-pattern (&type key val) ((= (length match-form) 3) (dash--match-kv-1 (cdr match-form) source (car match-form))) ;; if the source is a symbol, we don't need to re-bind it ((symbolp source) (dash--match-kv-1 (cdr match-form) source (car match-form))) (t (cons (list s source) (dash--match-kv-1 (cdr match-form) s (car match-form))))))) (defun dash--match-kv-1 (match-form source type) "Match MATCH-FORM against SOURCE of type TYPE. MATCH-FORM is a proper list of the form (key1 place1 ... keyN placeN). Each placeK is either a symbol, which gets bound to the value of keyK retrieved from the key-value store, or another match form which gets destructured recursively. SOURCE is a key-value store of type TYPE, which can be a plist, an alist or a hash table. TYPE is a token specifying the type of the key-value store. Valid values are &plist, &alist and &hash." (-flatten-n 1 (-map (lambda (kv) (let* ((k (car kv)) (v (cadr kv)) (getter (cond ((or (eq type '&plist) (eq type '&keys)) `(plist-get ,source ,k)) ((eq type '&alist) `(cdr (assoc ,k ,source))) ((eq type '&hash) `(gethash ,k ,source))))) (cond ((symbolp v) (list (list v getter))) (t (dash--match v getter))))) (-partition 2 match-form)))) (defun dash--match-symbol (match-form source) "Bind a symbol. This works just like `let', there is no destructuring." (list (list match-form source))) (defun dash--match (match-form source) "Match MATCH-FORM against SOURCE. This function tests the MATCH-FORM and dispatches to specific matchers based on the type of the expression. Key-value stores are disambiguated by placing a token &plist, &alist or &hash as a first item in the MATCH-FORM." (cond ((symbolp match-form) (dash--match-symbol match-form source)) ((consp match-form) (cond ;; Handle the "x &as" bindings first. ((and (consp (cdr match-form)) (symbolp (car match-form)) (eq '&as (cadr match-form))) (let ((s (car match-form))) (cons (list s source) (dash--match (cddr match-form) s)))) ((memq (car match-form) '(&keys &plist &alist &hash)) (dash--match-kv (dash--match-kv-normalize-match-form match-form) source)) (t (dash--match-cons match-form source)))) ((vectorp match-form) ;; We support the &as binding in vectors too (cond ((and (> (length match-form) 2) (symbolp (aref match-form 0)) (eq '&as (aref match-form 1))) (let ((s (aref match-form 0))) (cons (list s source) (dash--match (dash--vector-tail match-form 2) s)))) (t (dash--match-vector match-form source)))))) (defun dash--normalize-let-varlist (varlist) "Normalize VARLIST so that every binding is a list. `let' allows specifying a binding which is not a list but simply the place which is then automatically bound to nil, such that all three of the following are identical and evaluate to nil. (let (a) a) (let ((a)) a) (let ((a nil)) a) This function normalizes all of these to the last form." (--map (if (consp it) it (list it nil)) varlist)) (defmacro -let* (varlist &rest body) "Bind variables according to VARLIST then eval BODY. VARLIST is a list of lists of the form (PATTERN SOURCE). Each PATTERN is matched against the SOURCE structurally. SOURCE is only evaluated once for each PATTERN. Each SOURCE can refer to the symbols already bound by this VARLIST. This is useful if you want to destructure SOURCE recursively but also want to name the intermediate structures. See `-let' for the list of all possible patterns." (declare (debug ((&rest [&or (sexp form) sexp]) body)) (indent 1)) (let* ((varlist (dash--normalize-let-varlist varlist)) (bindings (--mapcat (dash--match (car it) (cadr it)) varlist))) `(let* ,bindings ,@body))) (defmacro -let (varlist &rest body) "Bind variables according to VARLIST then eval BODY. VARLIST is a list of lists of the form (PATTERN SOURCE). Each PATTERN is matched against the SOURCE \"structurally\". SOURCE is only evaluated once for each PATTERN. Each PATTERN is matched recursively, and can therefore contain sub-patterns which are matched against corresponding sub-expressions of SOURCE. All the SOURCEs are evalled before any symbols are bound (i.e. \"in parallel\"). If VARLIST only contains one (PATTERN SOURCE) element, you can optionally specify it using a vector and discarding the outer-most parens. Thus (-let ((PATTERN SOURCE)) ..) becomes (-let [PATTERN SOURCE] ..). `-let' uses a convention of not binding places (symbols) starting with _ whenever it's possible. You can use this to skip over entries you don't care about. However, this is not *always* possible (as a result of implementation) and these symbols might get bound to undefined values. Following is the overview of supported patterns. Remember that patterns can be matched recursively, so every a, b, aK in the following can be a matching construct and not necessarily a symbol/variable. Symbol: a - bind the SOURCE to A. This is just like regular `let'. Conses and lists: (a) - bind `car' of cons/list to A (a . b) - bind car of cons to A and `cdr' to B (a b) - bind car of list to A and `cadr' to B (a1 a2 a3 ...) - bind 0th car of list to A1, 1st to A2, 2nd to A3 ... (a1 a2 a3 ... aN . rest) - as above, but bind the Nth cdr to REST. Vectors: [a] - bind 0th element of a non-list sequence to A (works with vectors, strings, bit arrays...) [a1 a2 a3 ...] - bind 0th element of non-list sequence to A0, 1st to A1, 2nd to A2, ... If the PATTERN is shorter than SOURCE, the values at places not in PATTERN are ignored. If the PATTERN is longer than SOURCE, an `error' is thrown. [a1 a2 a3 ... &rest rest] - as above, but bind the rest of the sequence to REST. This is conceptually the same as improper list matching (a1 a2 ... aN . rest) Key/value stores: (&plist key0 a0 ... keyN aN) - bind value mapped by keyK in the SOURCE plist to aK. If the value is not found, aK is nil. Uses `plist-get' to fetch values. (&alist key0 a0 ... keyN aN) - bind value mapped by keyK in the SOURCE alist to aK. If the value is not found, aK is nil. Uses `assoc' to fetch values. (&hash key0 a0 ... keyN aN) - bind value mapped by keyK in the SOURCE hash table to aK. If the value is not found, aK is nil. Uses `gethash' to fetch values. Further, special keyword &keys supports \"inline\" matching of plist-like key-value pairs, similarly to &keys keyword of `cl-defun'. (a1 a2 ... aN &keys key1 b1 ... keyN bK) This binds N values from the list to a1 ... aN, then interprets the cdr as a plist (see key/value matching above). A shorthand notation for kv-destructuring exists which allows the patterns be optionally left out and derived from the key name in the following fashion: - a key :foo is converted into `foo' pattern, - a key 'bar is converted into `bar' pattern, - a key \"baz\" is converted into `baz' pattern. That is, the entire value under the key is bound to the derived variable without any further destructuring. This is possible only when the form following the key is not a valid pattern (i.e. not a symbol, a cons cell or a vector). Otherwise the matching proceeds as usual and in case of an invalid spec fails with an error. Thus the patterns are normalized as follows: ;; derive all the missing patterns (&plist :foo 'bar \"baz\") => (&plist :foo foo 'bar bar \"baz\" baz) ;; we can specify some but not others (&plist :foo 'bar explicit-bar) => (&plist :foo foo 'bar explicit-bar) ;; nothing happens, we store :foo in x (&plist :foo x) => (&plist :foo x) ;; nothing happens, we match recursively (&plist :foo (a b c)) => (&plist :foo (a b c)) You can name the source using the syntax SYMBOL &as PATTERN. This syntax works with lists (proper or improper), vectors and all types of maps. (list &as a b c) (list 1 2 3) binds A to 1, B to 2, C to 3 and LIST to (1 2 3). Similarly: (bounds &as beg . end) (cons 1 2) binds BEG to 1, END to 2 and BOUNDS to (1 . 2). (items &as first . rest) (list 1 2 3) binds FIRST to 1, REST to (2 3) and ITEMS to (1 2 3) [vect &as _ b c] [1 2 3] binds B to 2, C to 3 and VECT to [1 2 3] (_ avoids binding as usual). (plist &as &plist :b b) (list :a 1 :b 2 :c 3) binds B to 2 and PLIST to (:a 1 :b 2 :c 3). Same for &alist and &hash. This is especially useful when we want to capture the result of a computation and destructure at the same time. Consider the form (function-returning-complex-structure) returning a list of two vectors with two items each. We want to capture this entire result and pass it to another computation, but at the same time we want to get the second item from each vector. We can achieve it with pattern (result &as [_ a] [_ b]) (function-returning-complex-structure) Note: Clojure programmers may know this feature as the \":as binding\". The difference is that we put the &as at the front because we need to support improper list binding." (declare (debug ([&or (&rest [&or (sexp form) sexp]) (vector [&rest [sexp form]])] body)) (indent 1)) (if (vectorp varlist) `(let* ,(dash--match (aref varlist 0) (aref varlist 1)) ,@body) (let* ((varlist (dash--normalize-let-varlist varlist)) (inputs (--map-indexed (list (make-symbol (format "input%d" it-index)) (cadr it)) varlist)) (new-varlist (--map (list (caar it) (cadr it)) (-zip varlist inputs)))) `(let ,inputs (-let* ,new-varlist ,@body))))) (defmacro -lambda (match-form &rest body) "Return a lambda which destructures its input as MATCH-FORM and executes BODY. Note that you have to enclose the MATCH-FORM in a pair of parens, such that: (-lambda (x) body) (-lambda (x y ...) body) has the usual semantics of `lambda'. Furthermore, these get translated into normal lambda, so there is no performance penalty. See `-let' for the description of destructuring mechanism." (declare (doc-string 2) (indent defun) (debug (&define sexp [&optional stringp] [&optional ("interactive" interactive)] def-body))) (cond ((not (consp match-form)) (signal 'wrong-type-argument "match-form must be a list")) ;; no destructuring, so just return regular lambda to make things faster ((-all? 'symbolp match-form) `(lambda ,match-form ,@body)) (t (let* ((inputs (--map-indexed (list it (make-symbol (format "input%d" it-index))) match-form))) ;; TODO: because inputs to the lambda are evaluated only once, ;; -let* need not to create the extra bindings to ensure that. ;; We should find a way to optimize that. Not critical however. `(lambda ,(--map (cadr it) inputs) (-let* ,inputs ,@body)))))) (defmacro -setq (&rest forms) "Bind each MATCH-FORM to the value of its VAL. MATCH-FORM destructuring is done according to the rules of `-let'. This macro allows you to bind multiple variables by destructuring the value, so for example: (-setq (a b) x (&plist :c c) plist) expands roughly speaking to the following code (setq a (car x) b (cadr x) c (plist-get plist :c)) Care is taken to only evaluate each VAL once so that in case of multiple assignments it does not cause unexpected side effects. \(fn [MATCH-FORM VAL]...)" (declare (debug (&rest sexp form)) (indent 1)) (when (= (mod (length forms) 2) 1) (error "Odd number of arguments")) (let* ((forms-and-sources ;; First get all the necessary mappings with all the ;; intermediate bindings. (-map (lambda (x) (dash--match (car x) (cadr x))) (-partition 2 forms))) ;; To preserve the logic of dynamic scoping we must ensure ;; that we `setq' the variables outside of the `let*' form ;; which holds the destructured intermediate values. For ;; this we generate for each variable a placeholder which is ;; bound to (lexically) the result of the destructuring. ;; Then outside of the helper `let*' form we bind all the ;; original variables to their respective placeholders. ;; TODO: There is a lot of room for possible optimization, ;; for start playing with `special-variable-p' to eliminate ;; unnecessary re-binding. (variables-to-placeholders (-mapcat (lambda (bindings) (-map (lambda (binding) (let ((var (car binding))) (list var (make-symbol (concat "--dash-binding-" (symbol-name var) "--"))))) (--filter (not (string-prefix-p "--" (symbol-name (car it)))) bindings))) forms-and-sources))) `(let ,(-map 'cadr variables-to-placeholders) (let* ,(-flatten-n 1 forms-and-sources) (setq ,@(-flatten (-map 'reverse variables-to-placeholders)))) (setq ,@(-flatten variables-to-placeholders))))) (defmacro -if-let* (vars-vals then &rest else) "If all VALS evaluate to true, bind them to their corresponding VARS and do THEN, otherwise do ELSE. VARS-VALS should be a list of (VAR VAL) pairs. Note: binding is done according to `-let*'. VALS are evaluated sequentially, and evaluation stops after the first nil VAL is encountered." (declare (debug ((&rest (sexp form)) form body)) (indent 2)) (->> vars-vals (--mapcat (dash--match (car it) (cadr it))) (--reduce-r-from (let ((var (car it)) (val (cadr it))) `(let ((,var ,val)) (if ,var ,acc ,@else))) then))) (defmacro -if-let (var-val then &rest else) "If VAL evaluates to non-nil, bind it to VAR and do THEN, otherwise do ELSE. Note: binding is done according to `-let'. \(fn (VAR VAL) THEN &rest ELSE)" (declare (debug ((sexp form) form body)) (indent 2)) `(-if-let* (,var-val) ,then ,@else)) (defmacro --if-let (val then &rest else) "If VAL evaluates to non-nil, bind it to symbol `it' and do THEN, otherwise do ELSE." (declare (debug (form form body)) (indent 2)) `(-if-let (it ,val) ,then ,@else)) (defmacro -when-let* (vars-vals &rest body) "If all VALS evaluate to true, bind them to their corresponding VARS and execute body. VARS-VALS should be a list of (VAR VAL) pairs. Note: binding is done according to `-let*'. VALS are evaluated sequentially, and evaluation stops after the first nil VAL is encountered." (declare (debug ((&rest (sexp form)) body)) (indent 1)) `(-if-let* ,vars-vals (progn ,@body))) (defmacro -when-let (var-val &rest body) "If VAL evaluates to non-nil, bind it to VAR and execute body. Note: binding is done according to `-let'. \(fn (VAR VAL) &rest BODY)" (declare (debug ((sexp form) body)) (indent 1)) `(-if-let ,var-val (progn ,@body))) (defmacro --when-let (val &rest body) "If VAL evaluates to non-nil, bind it to symbol `it' and execute body." (declare (debug (form body)) (indent 1)) `(--if-let ,val (progn ,@body))) (defvar -compare-fn nil "Tests for equality use this function or `equal' if this is nil. It should only be set using dynamic scope with a let, like: (let ((-compare-fn #\\='=)) (-union numbers1 numbers2 numbers3)") (defun -distinct (list) "Return a new list with all duplicates removed. The test for equality is done with `equal', or with `-compare-fn' if that's non-nil. Alias: `-uniq'" (let (result) (--each list (unless (-contains? result it) (!cons it result))) (nreverse result))) (defalias '-uniq '-distinct) (defun -union (list list2) "Return a new list containing the elements of LIST and elements of LIST2 that are not in LIST. The test for equality is done with `equal', or with `-compare-fn' if that's non-nil." ;; We fall back to iteration implementation if the comparison ;; function isn't one of `eq', `eql' or `equal'. (let* ((result (reverse list)) ;; TODO: get rid of this dynamic variable, pass it as an ;; argument instead. (-compare-fn (if (bound-and-true-p -compare-fn) -compare-fn 'equal))) (if (memq -compare-fn '(eq eql equal)) (let ((ht (make-hash-table :test -compare-fn))) (--each list (puthash it t ht)) (--each list2 (unless (gethash it ht) (!cons it result)))) (--each list2 (unless (-contains? result it) (!cons it result)))) (nreverse result))) (defun -intersection (list list2) "Return a new list containing only the elements that are members of both LIST and LIST2. The test for equality is done with `equal', or with `-compare-fn' if that's non-nil." (--filter (-contains? list2 it) list)) (defun -difference (list list2) "Return a new list with only the members of LIST that are not in LIST2. The test for equality is done with `equal', or with `-compare-fn' if that's non-nil." (--filter (not (-contains? list2 it)) list)) (defun -powerset (list) "Return the power set of LIST." (if (null list) '(()) (let ((last (-powerset (cdr list)))) (append (mapcar (lambda (x) (cons (car list) x)) last) last)))) (defun -permutations (list) "Return the permutations of LIST." (if (null list) '(()) (apply #'append (mapcar (lambda (x) (mapcar (lambda (perm) (cons x perm)) (-permutations (remove x list)))) list)))) (defun -inits (list) "Return all prefixes of LIST." (nreverse (-map 'reverse (-tails (nreverse list))))) (defun -tails (list) "Return all suffixes of LIST" (-reductions-r-from 'cons nil list)) (defun -common-prefix (&rest lists) "Return the longest common prefix of LISTS." (declare (pure t) (side-effect-free t)) (--reduce (--take-while (and acc (equal (pop acc) it)) it) lists)) (defun -contains? (list element) "Return non-nil if LIST contains ELEMENT. The test for equality is done with `equal', or with `-compare-fn' if that's non-nil. Alias: `-contains-p'" (not (null (cond ((null -compare-fn) (member element list)) ((eq -compare-fn 'eq) (memq element list)) ((eq -compare-fn 'eql) (memql element list)) (t (let ((lst list)) (while (and lst (not (funcall -compare-fn element (car lst)))) (setq lst (cdr lst))) lst)))))) (defalias '-contains-p '-contains?) (defun -same-items? (list list2) "Return true if LIST and LIST2 has the same items. The order of the elements in the lists does not matter. Alias: `-same-items-p'" (let ((length-a (length list)) (length-b (length list2))) (and (= length-a length-b) (= length-a (length (-intersection list list2)))))) (defalias '-same-items-p '-same-items?) (defun -is-prefix? (prefix list) "Return non-nil if PREFIX is prefix of LIST. Alias: `-is-prefix-p'" (declare (pure t) (side-effect-free t)) (--each-while list (equal (car prefix) it) (!cdr prefix)) (not prefix)) (defun -is-suffix? (suffix list) "Return non-nil if SUFFIX is suffix of LIST. Alias: `-is-suffix-p'" (declare (pure t) (side-effect-free t)) (-is-prefix? (reverse suffix) (reverse list))) (defun -is-infix? (infix list) "Return non-nil if INFIX is infix of LIST. This operation runs in O(n^2) time Alias: `-is-infix-p'" (declare (pure t) (side-effect-free t)) (let (done) (while (and (not done) list) (setq done (-is-prefix? infix list)) (!cdr list)) done)) (defalias '-is-prefix-p '-is-prefix?) (defalias '-is-suffix-p '-is-suffix?) (defalias '-is-infix-p '-is-infix?) (defun -sort (comparator list) "Sort LIST, stably, comparing elements using COMPARATOR. Return the sorted list. LIST is NOT modified by side effects. COMPARATOR is called with two elements of LIST, and should return non-nil if the first element should sort before the second." (sort (copy-sequence list) comparator)) (defmacro --sort (form list) "Anaphoric form of `-sort'." (declare (debug (form form))) `(-sort (lambda (it other) ,form) ,list)) (defun -list (&rest args) "Return a list with ARGS. If first item of ARGS is already a list, simply return ARGS. If not, return a list with ARGS as elements." (declare (pure t) (side-effect-free t)) (let ((arg (car args))) (if (listp arg) arg args))) (defun -repeat (n x) "Return a list with X repeated N times. Return nil if N is less than 1." (declare (pure t) (side-effect-free t)) (let (ret) (--dotimes n (!cons x ret)) ret)) (defun -sum (list) "Return the sum of LIST." (declare (pure t) (side-effect-free t)) (apply '+ list)) (defun -running-sum (list) "Return a list with running sums of items in LIST. LIST must be non-empty." (declare (pure t) (side-effect-free t)) (unless (consp list) (error "LIST must be non-empty")) (-reductions '+ list)) (defun -product (list) "Return the product of LIST." (declare (pure t) (side-effect-free t)) (apply '* list)) (defun -running-product (list) "Return a list with running products of items in LIST. LIST must be non-empty." (declare (pure t) (side-effect-free t)) (unless (consp list) (error "LIST must be non-empty")) (-reductions '* list)) (defun -max (list) "Return the largest value from LIST of numbers or markers." (declare (pure t) (side-effect-free t)) (apply 'max list)) (defun -min (list) "Return the smallest value from LIST of numbers or markers." (declare (pure t) (side-effect-free t)) (apply 'min list)) (defun -max-by (comparator list) "Take a comparison function COMPARATOR and a LIST and return the greatest element of the list by the comparison function. See also combinator `-on' which can transform the values before comparing them." (--reduce (if (funcall comparator it acc) it acc) list)) (defun -min-by (comparator list) "Take a comparison function COMPARATOR and a LIST and return the least element of the list by the comparison function. See also combinator `-on' which can transform the values before comparing them." (--reduce (if (funcall comparator it acc) acc it) list)) (defmacro --max-by (form list) "Anaphoric version of `-max-by'. The items for the comparator form are exposed as \"it\" and \"other\"." (declare (debug (form form))) `(-max-by (lambda (it other) ,form) ,list)) (defmacro --min-by (form list) "Anaphoric version of `-min-by'. The items for the comparator form are exposed as \"it\" and \"other\"." (declare (debug (form form))) `(-min-by (lambda (it other) ,form) ,list)) (defun -iterate (fun init n) "Return a list of iterated applications of FUN to INIT. This means a list of form: (init (fun init) (fun (fun init)) ...) N is the length of the returned list." (if (= n 0) nil (let ((r (list init))) (--dotimes (1- n) (push (funcall fun (car r)) r)) (nreverse r)))) (defun -fix (fn list) "Compute the (least) fixpoint of FN with initial input LIST. FN is called at least once, results are compared with `equal'." (let ((re (funcall fn list))) (while (not (equal list re)) (setq list re) (setq re (funcall fn re))) re)) (defmacro --fix (form list) "Anaphoric form of `-fix'." `(-fix (lambda (it) ,form) ,list)) (defun -unfold (fun seed) "Build a list from SEED using FUN. This is \"dual\" operation to `-reduce-r': while -reduce-r consumes a list to produce a single value, `-unfold' takes a seed value and builds a (potentially infinite!) list. FUN should return `nil' to stop the generating process, or a cons (A . B), where A will be prepended to the result and B is the new seed." (let ((last (funcall fun seed)) r) (while last (push (car last) r) (setq last (funcall fun (cdr last)))) (nreverse r))) (defmacro --unfold (form seed) "Anaphoric version of `-unfold'." (declare (debug (form form))) `(-unfold (lambda (it) ,form) ,seed)) (defun -cons-pair? (con) "Return non-nil if CON is true cons pair. That is (A . B) where B is not a list." (declare (pure t) (side-effect-free t)) (and (listp con) (not (listp (cdr con))))) (defun -cons-to-list (con) "Convert a cons pair to a list with `car' and `cdr' of the pair respectively." (declare (pure t) (side-effect-free t)) (list (car con) (cdr con))) (defun -value-to-list (val) "Convert a value to a list. If the value is a cons pair, make a list with two elements, `car' and `cdr' of the pair respectively. If the value is anything else, wrap it in a list." (declare (pure t) (side-effect-free t)) (cond ((-cons-pair? val) (-cons-to-list val)) (t (list val)))) (defun -tree-mapreduce-from (fn folder init-value tree) "Apply FN to each element of TREE, and make a list of the results. If elements of TREE are lists themselves, apply FN recursively to elements of these nested lists. Then reduce the resulting lists using FOLDER and initial value INIT-VALUE. See `-reduce-r-from'. This is the same as calling `-tree-reduce-from' after `-tree-map' but is twice as fast as it only traverse the structure once." (cond ((not tree) nil) ((-cons-pair? tree) (funcall fn tree)) ((listp tree) (-reduce-r-from folder init-value (mapcar (lambda (x) (-tree-mapreduce-from fn folder init-value x)) tree))) (t (funcall fn tree)))) (defmacro --tree-mapreduce-from (form folder init-value tree) "Anaphoric form of `-tree-mapreduce-from'." (declare (debug (form form form form))) `(-tree-mapreduce-from (lambda (it) ,form) (lambda (it acc) ,folder) ,init-value ,tree)) (defun -tree-mapreduce (fn folder tree) "Apply FN to each element of TREE, and make a list of the results. If elements of TREE are lists themselves, apply FN recursively to elements of these nested lists. Then reduce the resulting lists using FOLDER and initial value INIT-VALUE. See `-reduce-r-from'. This is the same as calling `-tree-reduce' after `-tree-map' but is twice as fast as it only traverse the structure once." (cond ((not tree) nil) ((-cons-pair? tree) (funcall fn tree)) ((listp tree) (-reduce-r folder (mapcar (lambda (x) (-tree-mapreduce fn folder x)) tree))) (t (funcall fn tree)))) (defmacro --tree-mapreduce (form folder tree) "Anaphoric form of `-tree-mapreduce'." (declare (debug (form form form))) `(-tree-mapreduce (lambda (it) ,form) (lambda (it acc) ,folder) ,tree)) (defun -tree-map (fn tree) "Apply FN to each element of TREE while preserving the tree structure." (cond ((not tree) nil) ((-cons-pair? tree) (funcall fn tree)) ((listp tree) (mapcar (lambda (x) (-tree-map fn x)) tree)) (t (funcall fn tree)))) (defmacro --tree-map (form tree) "Anaphoric form of `-tree-map'." (declare (debug (form form))) `(-tree-map (lambda (it) ,form) ,tree)) (defun -tree-reduce-from (fn init-value tree) "Use FN to reduce elements of list TREE. If elements of TREE are lists themselves, apply the reduction recursively. FN is first applied to INIT-VALUE and first element of the list, then on this result and second element from the list etc. The initial value is ignored on cons pairs as they always contain two elements." (cond ((not tree) nil) ((-cons-pair? tree) tree) ((listp tree) (-reduce-r-from fn init-value (mapcar (lambda (x) (-tree-reduce-from fn init-value x)) tree))) (t tree))) (defmacro --tree-reduce-from (form init-value tree) "Anaphoric form of `-tree-reduce-from'." (declare (debug (form form form))) `(-tree-reduce-from (lambda (it acc) ,form) ,init-value ,tree)) (defun -tree-reduce (fn tree) "Use FN to reduce elements of list TREE. If elements of TREE are lists themselves, apply the reduction recursively. FN is first applied to first element of the list and second element, then on this result and third element from the list etc. See `-reduce-r' for how exactly are lists of zero or one element handled." (cond ((not tree) nil) ((-cons-pair? tree) tree) ((listp tree) (-reduce-r fn (mapcar (lambda (x) (-tree-reduce fn x)) tree))) (t tree))) (defmacro --tree-reduce (form tree) "Anaphoric form of `-tree-reduce'." (declare (debug (form form))) `(-tree-reduce (lambda (it acc) ,form) ,tree)) (defun -tree-map-nodes (pred fun tree) "Call FUN on each node of TREE that satisfies PRED. If PRED returns nil, continue descending down this node. If PRED returns non-nil, apply FUN to this node and do not descend further." (if (funcall pred tree) (funcall fun tree) (if (and (listp tree) (not (-cons-pair? tree))) (-map (lambda (x) (-tree-map-nodes pred fun x)) tree) tree))) (defmacro --tree-map-nodes (pred form tree) "Anaphoric form of `-tree-map-nodes'." `(-tree-map-nodes (lambda (it) ,pred) (lambda (it) ,form) ,tree)) (defun -tree-seq (branch children tree) "Return a sequence of the nodes in TREE, in depth-first search order. BRANCH is a predicate of one argument that returns non-nil if the passed argument is a branch, that is, a node that can have children. CHILDREN is a function of one argument that returns the children of the passed branch node. Non-branch nodes are simply copied." (cons tree (when (funcall branch tree) (-mapcat (lambda (x) (-tree-seq branch children x)) (funcall children tree))))) (defmacro --tree-seq (branch children tree) "Anaphoric form of `-tree-seq'." `(-tree-seq (lambda (it) ,branch) (lambda (it) ,children) ,tree)) (defun -clone (list) "Create a deep copy of LIST. The new list has the same elements and structure but all cons are replaced with new ones. This is useful when you need to clone a structure such as plist or alist." (declare (pure t) (side-effect-free t)) (-tree-map 'identity list)) (defun dash-enable-font-lock () "Add syntax highlighting to dash functions, macros and magic values." (eval-after-load 'lisp-mode '(progn (let ((new-keywords '( "!cons" "!cdr" "-each" "--each" "-each-indexed" "--each-indexed" "-each-while" "--each-while" "-doto" "-dotimes" "--dotimes" "-map" "--map" "-reduce-from" "--reduce-from" "-reduce" "--reduce" "-reduce-r-from" "--reduce-r-from" "-reduce-r" "--reduce-r" "-reductions-from" "-reductions-r-from" "-reductions" "-reductions-r" "-filter" "--filter" "-select" "--select" "-remove" "--remove" "-reject" "--reject" "-remove-first" "--remove-first" "-reject-first" "--reject-first" "-remove-last" "--remove-last" "-reject-last" "--reject-last" "-remove-item" "-non-nil" "-keep" "--keep" "-map-indexed" "--map-indexed" "-splice" "--splice" "-splice-list" "--splice-list" "-map-when" "--map-when" "-replace-where" "--replace-where" "-map-first" "--map-first" "-map-last" "--map-last" "-replace" "-replace-first" "-replace-last" "-flatten" "-flatten-n" "-concat" "-mapcat" "--mapcat" "-copy" "-cons*" "-snoc" "-first" "--first" "-find" "--find" "-some" "--some" "-any" "--any" "-last" "--last" "-first-item" "-second-item" "-third-item" "-fourth-item" "-fifth-item" "-last-item" "-butlast" "-count" "--count" "-any?" "--any?" "-some?" "--some?" "-any-p" "--any-p" "-some-p" "--some-p" "-some->" "-some->>" "-some-->" "-all?" "-all-p" "--all?" "--all-p" "-every?" "--every?" "-all-p" "--all-p" "-every-p" "--every-p" "-none?" "--none?" "-none-p" "--none-p" "-only-some?" "--only-some?" "-only-some-p" "--only-some-p" "-slice" "-take" "-drop" "-drop-last" "-take-last" "-take-while" "--take-while" "-drop-while" "--drop-while" "-split-at" "-rotate" "-insert-at" "-replace-at" "-update-at" "--update-at" "-remove-at" "-remove-at-indices" "-split-with" "--split-with" "-split-on" "-split-when" "--split-when" "-separate" "--separate" "-partition-all-in-steps" "-partition-in-steps" "-partition-all" "-partition" "-partition-after-item" "-partition-after-pred" "-partition-before-item" "-partition-before-pred" "-partition-by" "--partition-by" "-partition-by-header" "--partition-by-header" "-group-by" "--group-by" "-interpose" "-interleave" "-unzip" "-zip-with" "--zip-with" "-zip" "-zip-fill" "-zip-pair" "-cycle" "-pad" "-annotate" "--annotate" "-table" "-table-flat" "-partial" "-elem-index" "-elem-indices" "-find-indices" "--find-indices" "-find-index" "--find-index" "-find-last-index" "--find-last-index" "-select-by-indices" "-select-columns" "-select-column" "-grade-up" "-grade-down" "->" "->>" "-->" "-as->" "-when-let" "-when-let*" "--when-let" "-if-let" "-if-let*" "--if-let" "-let*" "-let" "-lambda" "-distinct" "-uniq" "-union" "-intersection" "-difference" "-powerset" "-permutations" "-inits" "-tails" "-common-prefix" "-contains?" "-contains-p" "-same-items?" "-same-items-p" "-is-prefix-p" "-is-prefix?" "-is-suffix-p" "-is-suffix?" "-is-infix-p" "-is-infix?" "-sort" "--sort" "-list" "-repeat" "-sum" "-running-sum" "-product" "-running-product" "-max" "-min" "-max-by" "--max-by" "-min-by" "--min-by" "-iterate" "--iterate" "-fix" "--fix" "-unfold" "--unfold" "-cons-pair?" "-cons-to-list" "-value-to-list" "-tree-mapreduce-from" "--tree-mapreduce-from" "-tree-mapreduce" "--tree-mapreduce" "-tree-map" "--tree-map" "-tree-reduce-from" "--tree-reduce-from" "-tree-reduce" "--tree-reduce" "-tree-seq" "--tree-seq" "-tree-map-nodes" "--tree-map-nodes" "-clone" "-rpartial" "-juxt" "-applify" "-on" "-flip" "-const" "-cut" "-orfn" "-andfn" "-iteratefn" "-fixfn" "-prodfn" )) (special-variables '( "it" "it-index" "acc" "other" ))) (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "\\_<" (regexp-opt special-variables 'paren) "\\_>") 1 font-lock-variable-name-face)) 'append) (font-lock-add-keywords 'emacs-lisp-mode `((,(concat "(\\s-*" (regexp-opt new-keywords 'paren) "\\_>") 1 font-lock-keyword-face)) 'append)) (--each (buffer-list) (with-current-buffer it (when (and (eq major-mode 'emacs-lisp-mode) (boundp 'font-lock-mode) font-lock-mode) (font-lock-refresh-defaults))))))) (provide 'dash) ;;; dash.el ends here ================================================ FILE: t/batch-runner/request.el ================================================ ;;; request.el --- Compatible layer for URL request in Emacs -*- lexical-binding: t; -*- ;; Copyright (C) 2012 Takafumi Arakaki ;; Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012 ;; Free Software Foundation, Inc. ;; Author: Takafumi Arakaki ;; Package-Requires: ((emacs "24.4")) ;; Package-Version: 20170131.1747 ;; Version: 0.3.0 ;; This file is NOT part of GNU Emacs. ;; request.el 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. ;; request.el 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 request.el. ;; If not, see . ;;; Commentary: ;; Request.el is a HTTP request library with multiple backends. It ;; supports url.el which is shipped with Emacs and curl command line ;; program. User can use curl when s/he has it, as curl is more reliable ;; than url.el. Library author can use request.el to avoid imposing ;; external dependencies such as curl to users while giving richer ;; experience for users who have curl. ;; Following functions are adapted from GNU Emacs source code. ;; Free Software Foundation holds the copyright of them. ;; * `request--process-live-p' ;; * `request--url-default-expander' ;;; Code: (eval-when-compile (defvar url-http-method) (defvar url-http-response-status)) (require 'cl-lib) (require 'url) (require 'mail-utils) (defgroup request nil "Compatible layer for URL request in Emacs." :group 'comm :prefix "request-") (defconst request-version "0.3.0") ;;; Customize variables (defcustom request-storage-directory (concat (file-name-as-directory user-emacs-directory) "request") "Directory to store data related to request.el." :type 'directory) (defcustom request-curl "curl" "Executable for curl command." :type 'string) (defcustom request-curl-options nil "curl command options. List of strings that will be passed to every curl invocation. You can pass extra options here, like setting the proxy." :type '(repeat string)) (defcustom request-backend (if (executable-find request-curl) 'curl 'url-retrieve) "Backend to be used for HTTP request. Automatically set to `curl' if curl command is found." :type '(choice (const :tag "cURL backend" curl) (const :tag "url-retrieve backend" url-retrieve))) (defcustom request-timeout nil "Default request timeout in second. `nil' means no timeout." :type '(choice (integer :tag "Request timeout seconds") (boolean :tag "No timeout" nil))) (defcustom request-temp-prefix "emacs-request" "Prefix for temporary files created by Request." :type 'string :risky t) (defcustom request-log-level -1 "Logging level for request. One of `error'/`warn'/`info'/`verbose'/`debug'. -1 means no logging." :type '(choice (integer :tag "No logging" -1) (const :tag "Level error" error) (const :tag "Level warn" warn) (const :tag "Level info" info) (const :tag "Level Verbose" verbose) (const :tag "Level DEBUG" debug))) (defcustom request-message-level 'warn "Logging level for request. See `request-log-level'." :type '(choice (integer :tag "No logging" -1) (const :tag "Level error" error) (const :tag "Level warn" warn) (const :tag "Level info" info) (const :tag "Level Verbose" verbose) (const :tag "Level DEBUG" debug))) ;;; Utilities (defun request--safe-apply (function &rest arguments) (condition-case err (apply #'apply function arguments) ((debug error)))) (defun request--safe-call (function &rest arguments) (request--safe-apply function arguments)) ;; (defun request--url-no-cache (url) ;; "Imitate `cache=false' of `jQuery.ajax'. ;; See: http://api.jquery.com/jQuery.ajax/" ;; ;; FIXME: parse URL before adding ?_=TIME. ;; (concat url (format-time-string "?_=%s"))) (defmacro request--document-function (function docstring) "Document FUNCTION with DOCSTRING. Use this for defstruct accessor etc." (declare (indent defun) (doc-string 2)) `(put ',function 'function-documentation ,docstring)) (defun request--process-live-p (process) "Copied from `process-live-p' for backward compatibility (Emacs < 24). Adapted from lisp/subr.el. FSF holds the copyright of this function: Copyright (C) 1985-1986, 1992, 1994-1995, 1999-2012 Free Software Foundation, Inc." (memq (process-status process) '(run open listen connect stop))) ;;; Logging (defconst request--log-level-def '(;; debugging (blather . 60) (trace . 50) (debug . 40) ;; information (verbose . 30) (info . 20) ;; errors (warn . 10) (error . 0)) "Named logging levels.") (defun request--log-level-as-int (level) (if (integerp level) level (or (cdr (assq level request--log-level-def)) 0))) (defvar request-log-buffer-name " *request-log*") (defun request--log-buffer () (get-buffer-create request-log-buffer-name)) (defmacro request-log (level fmt &rest args) (declare (indent 1)) `(let ((level (request--log-level-as-int ,level)) (log-level (request--log-level-as-int request-log-level)) (msg-level (request--log-level-as-int request-message-level))) (when (<= level (max log-level msg-level)) (let ((msg (format "[%s] %s" ,level (condition-case err (format ,fmt ,@args) (error (format " !!! Logging error while executing: %S !!! Error: %S" ',args err)))))) (when (<= level log-level) (with-current-buffer (request--log-buffer) (setq buffer-read-only t) (let ((inhibit-read-only t)) (goto-char (point-max)) (insert msg "\n")))) (when (<= level msg-level) (message "REQUEST %s" msg)))))) ;;; HTTP specific utilities (defconst request--url-unreserved-chars '(?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?- ?_ ?. ?~) "`url-unreserved-chars' copied from Emacs 24.3 release candidate. This is used for making `request--urlencode-alist' RFC 3986 compliant for older Emacs versions.") (defun request--urlencode-alist (alist) ;; FIXME: make monkey patching `url-unreserved-chars' optional (let ((url-unreserved-chars request--url-unreserved-chars)) (cl-loop for sep = "" then "&" for (k . v) in alist concat sep concat (url-hexify-string (format "%s" k)) concat "=" concat (url-hexify-string (format "%s" v))))) ;;; Header parser (defun request--parse-response-at-point () "Parse the first header line such as \"HTTP/1.1 200 OK\"." (when (re-search-forward "\\=[ \t\n]*HTTP/\\([0-9\\.]+\\) +\\([0-9]+\\)" nil t) (list :version (match-string 1) :code (string-to-number (match-string 2))))) (defun request--goto-next-body () (re-search-forward "^\r\n")) ;;; Response object (cl-defstruct request-response "A structure holding all relevant information of a request." status-code history data error-thrown symbol-status url done-p settings ;; internal variables -buffer -raw-header -timer -backend -tempfiles) (defmacro request--document-response (function docstring) (declare (indent defun) (doc-string 2)) `(request--document-function ,function ,(concat docstring " .. This is an accessor for `request-response' object. \(fn RESPONSE)"))) (request--document-response request-response-status-code "Integer HTTP response code (e.g., 200).") (request--document-response request-response-history "Redirection history (a list of response object). The first element is the oldest redirection. You can use restricted portion of functions for the response objects in the history slot. It also depends on backend. Here is the table showing what functions you can use for the response objects in the history slot. ==================================== ============== ============== Slots Backends ------------------------------------ ----------------------------- \\ curl url-retrieve ==================================== ============== ============== request-response-url yes yes request-response-header yes no other functions no no ==================================== ============== ============== ") (request--document-response request-response-data "Response parsed by the given parser.") (request--document-response request-response-error-thrown "Error thrown during request. It takes the form of ``(ERROR-SYMBOL . DATA)``, which can be re-raised (`signal'ed) by ``(signal ERROR-SYMBOL DATA)``.") (request--document-response request-response-symbol-status "A symbol representing the status of request (not HTTP response code). One of success/error/timeout/abort/parse-error.") (request--document-response request-response-url "Final URL location of response.") (request--document-response request-response-done-p "Return t when the request is finished or aborted.") (request--document-response request-response-settings "Keyword arguments passed to `request' function. Some arguments such as HEADERS is changed to the one actually passed to the backend. Also, it has additional keywords such as URL which is the requested URL.") (defun request-response-header (response field-name) "Fetch the values of RESPONSE header field named FIELD-NAME. It returns comma separated values when the header has multiple field with the same name, as :RFC:`2616` specifies. Examples:: (request-response-header response \"content-type\") ; => \"text/html; charset=utf-8\" (request-response-header response \"unknown-field\") ; => nil " (let ((raw-header (request-response--raw-header response))) (when raw-header (with-temp-buffer (erase-buffer) (insert raw-header) ;; ALL=t to fetch all fields with the same name to get comma ;; separated value [#rfc2616-sec4]_. (mail-fetch-field field-name nil t))))) ;; .. [#rfc2616-sec4] RFC2616 says this is the right thing to do ;; (see http://tools.ietf.org/html/rfc2616.html#section-4.2). ;; Python's requests module does this too. ;;; Backend dispatcher (defconst request--backend-alist '((url-retrieve . ((request . request--url-retrieve) (request-sync . request--url-retrieve-sync) (terminate-process . delete-process) (get-cookies . request--url-retrieve-get-cookies))) (curl . ((request . request--curl) (request-sync . request--curl-sync) (terminate-process . interrupt-process) (get-cookies . request--curl-get-cookies)))) "Map backend and method name to actual method (symbol). It's alist of alist, of the following form:: ((BACKEND . ((METHOD . FUNCTION) ...)) ...) It would be nicer if I can use EIEIO. But as CEDET is included in Emacs by 23.2, using EIEIO means abandon older Emacs versions. It is probably necessary if I need to support more backends. But let's stick to manual dispatch for now.") ;; See: (view-emacs-news "23.2") (defun request--choose-backend (method) "Return `fucall'able object for METHOD of current `request-backend'." (assoc-default method (or (assoc-default request-backend request--backend-alist) (error "%S is not valid `request-backend'." request-backend)))) ;;; Cookie (defun request-cookie-string (host &optional localpart secure) "Return cookie string (like `document.cookie'). Example:: (request-cookie-string \"127.0.0.1\" \"/\") ; => \"key=value; key2=value2\" " (mapconcat (lambda (nv) (concat (car nv) "=" (cdr nv))) (request-cookie-alist host localpart secure) "; ")) (defun request-cookie-alist (host &optional localpart secure) "Return cookies as an alist. Example:: (request-cookie-alist \"127.0.0.1\" \"/\") ; => ((\"key\" . \"value\") ...) " (funcall (request--choose-backend 'get-cookies) host localpart secure)) ;;; Main (cl-defun request-default-error-callback (url &key symbol-status &allow-other-keys) (request-log 'error "Error (%s) while connecting to %s." symbol-status url)) (cl-defun request (url &rest settings &key (type "GET") (params nil) (data nil) (files nil) (parser nil) (headers nil) (success nil) (error nil) (complete nil) (timeout request-timeout) (status-code nil) (sync nil) (response (make-request-response)) (unix-socket nil)) "Send request to URL. Request.el has a single entry point. It is `request'. ==================== ======================================================== Keyword argument Explanation ==================== ======================================================== TYPE (string) type of request to make: POST/GET/PUT/DELETE PARAMS (alist) set \"?key=val\" part in URL DATA (string/alist) data to be sent to the server FILES (alist) files to be sent to the server (see below) PARSER (symbol) a function that reads current buffer and return data HEADERS (alist) additional headers to send with the request SUCCESS (function) called on success ERROR (function) called on error COMPLETE (function) called on both success and error TIMEOUT (number) timeout in second STATUS-CODE (alist) map status code (int) to callback SYNC (bool) If `t', wait until request is done. Default is `nil'. ==================== ======================================================== * Callback functions Callback functions STATUS, ERROR, COMPLETE and `cdr's in element of the alist STATUS-CODE take same keyword arguments listed below. For forward compatibility, these functions must ignore unused keyword arguments (i.e., it's better to use `&allow-other-keys' [#]_).:: (CALLBACK ; SUCCESS/ERROR/COMPLETE/STATUS-CODE :data data ; whatever PARSER function returns, or nil :error-thrown error-thrown ; (ERROR-SYMBOL . DATA), or nil :symbol-status symbol-status ; success/error/timeout/abort/parse-error :response response ; request-response object ...) .. [#] `&allow-other-keys' is a special \"markers\" available in macros in the CL library for function definition such as `cl-defun' and `cl-function'. Without this marker, you need to specify all arguments to be passed. This becomes problem when request.el adds new arguments when calling callback functions. If you use `&allow-other-keys' (or manually ignore other arguments), your code is free from this problem. See info node `(cl) Argument Lists' for more information. Arguments data, error-thrown, symbol-status can be accessed by `request-response-data', `request-response-error-thrown', `request-response-symbol-status' accessors, i.e.:: (request-response-data RESPONSE) ; same as data Response object holds other information which can be accessed by the following accessors: `request-response-status-code', `request-response-url' and `request-response-settings' * STATUS-CODE callback STATUS-CODE is an alist of the following format:: ((N-1 . CALLBACK-1) (N-2 . CALLBACK-2) ...) Here, N-1, N-2,... are integer status codes such as 200. * FILES FILES is an alist of the following format:: ((NAME-1 . FILE-1) (NAME-2 . FILE-2) ...) where FILE-N is a list of the form:: (FILENAME &key PATH BUFFER STRING MIME-TYPE) FILE-N can also be a string (path to the file) or a buffer object. In that case, FILENAME is set to the file name or buffer name. Example FILES argument:: `((\"passwd\" . \"/etc/passwd\") ; filename = passwd (\"scratch\" . ,(get-buffer \"*scratch*\")) ; filename = *scratch* (\"passwd2\" . (\"password.txt\" :file \"/etc/passwd\")) (\"scratch2\" . (\"scratch.txt\" :buffer ,(get-buffer \"*scratch*\"))) (\"data\" . (\"data.csv\" :data \"1,2,3\\n4,5,6\\n\"))) .. note:: FILES is implemented only for curl backend for now. As furl.el_ supports multipart POST, it should be possible to support FILES in pure elisp by making furl.el_ another backend. Contributions are welcome. .. _furl.el: http://code.google.com/p/furl-el/ * PARSER function PARSER function takes no argument and it is executed in the buffer with HTTP response body. The current position in the HTTP response buffer is at the beginning of the buffer. As the HTTP header is stripped off, the cursor is actually at the beginning of the response body. So, for example, you can pass `json-read' to parse JSON object in the buffer. To fetch whole response as a string, pass `buffer-string'. When using `json-read', it is useful to know that the returned type can be modified by `json-object-type', `json-array-type', `json-key-type', `json-false' and `json-null'. See docstring of each function for what it does. For example, to convert JSON objects to plist instead of alist, wrap `json-read' by `lambda' like this.:: (request \"http://...\" :parser (lambda () (let ((json-object-type 'plist)) (json-read))) ...) This is analogous to the `dataType' argument of jQuery.ajax_. Only this function can access to the process buffer, which is killed immediately after the execution of this function. * SYNC Synchronous request is functional, but *please* don't use it other than testing or debugging. Emacs users have better things to do rather than waiting for HTTP request. If you want a better way to write callback chains, use `request-deferred'. If you can't avoid using it (e.g., you are inside of some hook which must return some value), make sure to set TIMEOUT to relatively small value. Due to limitation of `url-retrieve-synchronously', response slots `request-response-error-thrown', `request-response-history' and `request-response-url' are unknown (always `nil') when using synchronous request with `url-retrieve' backend. * Note API of `request' is somewhat mixture of jQuery.ajax_ (Javascript) and requests.request_ (Python). .. _jQuery.ajax: http://api.jquery.com/jQuery.ajax/ .. _requests.request: http://docs.python-requests.org " (request-log 'debug "REQUEST") ;; FIXME: support CACHE argument (if possible) ;; (unless cache ;; (setq url (request--url-no-cache url))) (unless error (setq error (apply-partially #'request-default-error-callback url)) (setq settings (plist-put settings :error error))) (unless (or (stringp data) (null data) (assoc-string "Content-Type" headers t)) (setq data (request--urlencode-alist data)) (setq settings (plist-put settings :data data))) (when params (cl-assert (listp params) nil "PARAMS must be an alist. Given: %S" params) (setq url (concat url (if (string-match-p "\\?" url) "&" "?") (request--urlencode-alist params)))) (setq settings (plist-put settings :url url)) (setq settings (plist-put settings :response response)) (setf (request-response-settings response) settings) (setf (request-response-url response) url) (setf (request-response--backend response) request-backend) ;; Call `request--url-retrieve'(`-sync') or `request--curl'(`-sync'). (apply (if sync (request--choose-backend 'request-sync) (request--choose-backend 'request)) url settings) (when timeout (request-log 'debug "Start timer: timeout=%s sec" timeout) (setf (request-response--timer response) (run-at-time timeout nil #'request-response--timeout-callback response))) response) (defun request--clean-header (response) "Strip off carriage returns in the header of REQUEST." (request-log 'debug "-CLEAN-HEADER") (let ((buffer (request-response--buffer response)) (backend (request-response--backend response)) sep-regexp) (if (eq backend 'url-retrieve) ;; FIXME: make this workaround optional. ;; But it looks like sometimes `url-http-clean-headers' ;; fails to cleanup. So, let's be bit permissive here... (setq sep-regexp "^\r?$") (setq sep-regexp "^\r$")) (when (buffer-live-p buffer) (with-current-buffer buffer (request-log 'trace "(buffer-string) at %S =\n%s" buffer (buffer-string)) (goto-char (point-min)) (when (and (re-search-forward sep-regexp nil t) ;; Are \r characters stripped off already?: (not (equal (match-string 0) ""))) (while (re-search-backward "\r$" (point-min) t) (replace-match ""))))))) (defun request--cut-header (response) "Cut the first header part in the buffer of RESPONSE and move it to raw-header slot." (request-log 'debug "-CUT-HEADER") (let ((buffer (request-response--buffer response))) (when (buffer-live-p buffer) (with-current-buffer buffer (goto-char (point-min)) (when (re-search-forward "^$" nil t) (setf (request-response--raw-header response) (buffer-substring (point-min) (point))) (delete-region (point-min) (min (1+ (point)) (point-max)))))))) (defun request-untrampify-filename (file) "Return FILE as the local file name." (or (file-remote-p file 'localname) file)) (defun request--parse-data (response parser) "Run PARSER in current buffer if ERROR-THROWN is nil, then kill the current buffer." (request-log 'debug "-PARSE-DATA") (let ((buffer (request-response--buffer response))) (request-log 'debug "parser = %s" parser) (when (and (buffer-live-p buffer) parser) (with-current-buffer buffer (request-log 'trace "(buffer-string) at %S =\n%s" buffer (buffer-string)) (when (/= (request-response-status-code response) 204) (goto-char (point-min)) (setf (request-response-data response) (funcall parser))))))) (cl-defun request--callback (buffer &key parser success error complete timeout status-code response &allow-other-keys) (request-log 'debug "REQUEST--CALLBACK") (request-log 'debug "(buffer-string) =\n%s" (when (buffer-live-p buffer) (with-current-buffer buffer (buffer-string)))) ;; Sometimes BUFFER given as the argument is different from the ;; buffer already set in RESPONSE. That's why it is reset here. ;; FIXME: Refactor how BUFFER is passed around. (setf (request-response--buffer response) buffer) (request-response--cancel-timer response) (cl-symbol-macrolet ((error-thrown (request-response-error-thrown response)) (symbol-status (request-response-symbol-status response)) (data (request-response-data response)) (done-p (request-response-done-p response))) ;; Parse response header (request--clean-header response) (request--cut-header response) ;; Note: Try to do this even `error-thrown' is set. For example, ;; timeout error can occur while downloading response body and ;; header is there in that case. ;; Parse response body (request-log 'debug "error-thrown = %S" error-thrown) (condition-case err (request--parse-data response parser) (error ;; If there was already an error (e.g. server timeout) do not set the ;; status to `parse-error'. (unless error-thrown (setq symbol-status 'parse-error) (setq error-thrown err) (request-log 'error "Error from parser %S: %S" parser err)))) (kill-buffer buffer) (request-log 'debug "data = %s" data) ;; Determine `symbol-status' (unless symbol-status (setq symbol-status (if error-thrown 'error 'success))) (request-log 'debug "symbol-status = %s" symbol-status) ;; Call callbacks (let ((args (list :data data :symbol-status symbol-status :error-thrown error-thrown :response response))) (let* ((success-p (eq symbol-status 'success)) (cb (if success-p success error)) (name (if success-p "success" "error"))) (when cb (request-log 'debug "Executing %s callback." name) (request--safe-apply cb args))) (let ((cb (cdr (assq (request-response-status-code response) status-code)))) (when cb (request-log 'debug "Executing status-code callback.") (request--safe-apply cb args))) (when complete (request-log 'debug "Executing complete callback.") (request--safe-apply complete args))) (setq done-p t) ;; Remove temporary files ;; FIXME: Make tempfile cleanup more reliable. It is possible ;; callback is never called. (request--safe-delete-files (request-response--tempfiles response)))) (cl-defun request-response--timeout-callback (response) (request-log 'debug "-TIMEOUT-CALLBACK") (setf (request-response-symbol-status response) 'timeout) (setf (request-response-error-thrown response) '(error . ("Timeout"))) (let* ((buffer (request-response--buffer response)) (proc (and (buffer-live-p buffer) (get-buffer-process buffer)))) (when proc ;; This will call `request--callback': (funcall (request--choose-backend 'terminate-process) proc)) (cl-symbol-macrolet ((done-p (request-response-done-p response))) (unless done-p ;; This code should never be executed. However, it occurs ;; sometimes with `url-retrieve' backend. ;; FIXME: In Emacs 24.3.50 or later, this is always executed in ;; request-get-timeout test. Find out if it is fine. (request-log 'error "Callback is not called when stopping process! \ Explicitly calling from timer.") (when (buffer-live-p buffer) (cl-destructuring-bind (&key code &allow-other-keys) (with-current-buffer buffer (goto-char (point-min)) (request--parse-response-at-point)) (setf (request-response-status-code response) code))) (apply #'request--callback buffer (request-response-settings response)) (setq done-p t))))) (defun request-response--cancel-timer (response) (request-log 'debug "REQUEST-RESPONSE--CANCEL-TIMER") (cl-symbol-macrolet ((timer (request-response--timer response))) (when timer (cancel-timer timer) (setq timer nil)))) (defun request-abort (response) "Abort request for RESPONSE (the object returned by `request'). Note that this function invoke ERROR and COMPLETE callbacks. Callbacks may not be called immediately but called later when associated process is exited." (cl-symbol-macrolet ((buffer (request-response--buffer response)) (symbol-status (request-response-symbol-status response)) (done-p (request-response-done-p response))) (let ((process (get-buffer-process buffer))) (unless symbol-status ; should I use done-p here? (setq symbol-status 'abort) (setq done-p t) (when (and (processp process) ; process can be nil when buffer is killed (request--process-live-p process)) (funcall (request--choose-backend 'terminate-process) process)))))) ;;; Backend: `url-retrieve' (cl-defun request--url-retrieve-preprocess-settings (&rest settings &key type data files headers &allow-other-keys) (when files (error "`url-retrieve' backend does not support FILES.")) (when (and (equal type "POST") data (not (assoc-string "Content-Type" headers t))) (push '("Content-Type" . "application/x-www-form-urlencoded") headers) (setq settings (plist-put settings :headers headers))) settings) (cl-defun request--url-retrieve (url &rest settings &key type data timeout response &allow-other-keys &aux headers) (setq settings (apply #'request--url-retrieve-preprocess-settings settings)) (setq headers (plist-get settings :headers)) (let* ((url-request-extra-headers headers) (url-request-method type) (url-request-data data) (buffer (url-retrieve url #'request--url-retrieve-callback (nconc (list :response response) settings))) (proc (get-buffer-process buffer))) (setf (request-response--buffer response) buffer) (process-put proc :request-response response) (request-log 'debug "Start querying: %s" url) (set-process-query-on-exit-flag proc nil))) (cl-defun request--url-retrieve-callback (status &rest settings &key response url &allow-other-keys) ;;(declare (special url-http-method ;; url-http-response-status)) (request-log 'debug "-URL-RETRIEVE-CALLBACK") (request-log 'debug "status = %S" status) (request-log 'debug "url-http-method = %s" url-http-method) (request-log 'debug "url-http-response-status = %s" url-http-response-status) (setf (request-response-status-code response) url-http-response-status) (let ((redirect (plist-get status :redirect))) (when redirect (setf (request-response-url response) redirect))) ;; Construct history slot (cl-loop for v in (cl-loop with first = t with l = nil for (k v) on status by 'cddr when (eq k :redirect) if first do (setq first nil) else do (push v l) finally do (cons url l)) do (let ((r (make-request-response :-backend 'url-retrieve))) (setf (request-response-url r) v) (push r (request-response-history response)))) (cl-symbol-macrolet ((error-thrown (request-response-error-thrown response)) (status-error (plist-get status :error))) (when (and error-thrown status-error) (request-log 'warn "Error %S thrown already but got another error %S from \ `url-retrieve'. Ignoring it..." error-thrown status-error)) (unless error-thrown (setq error-thrown status-error))) (apply #'request--callback (current-buffer) settings)) (cl-defun request--url-retrieve-sync (url &rest settings &key type data timeout response &allow-other-keys &aux headers) (setq settings (apply #'request--url-retrieve-preprocess-settings settings)) (setq headers (plist-get settings :headers)) (let* ((url-request-extra-headers headers) (url-request-method type) (url-request-data data) (buffer (if timeout (with-timeout (timeout (setf (request-response-symbol-status response) 'timeout) (setf (request-response-done-p response) t) nil) (url-retrieve-synchronously url)) (url-retrieve-synchronously url)))) (setf (request-response--buffer response) buffer) ;; It seems there is no way to get redirects and URL here... (when buffer ;; Fetch HTTP response code (with-current-buffer buffer (goto-char (point-min)) (cl-destructuring-bind (&key version code) (request--parse-response-at-point) (setf (request-response-status-code response) code))) ;; Parse response body, etc. (apply #'request--callback buffer settings))) response) (defun request--url-retrieve-get-cookies (host localpart secure) (mapcar (lambda (c) (cons (url-cookie-name c) (url-cookie-value c))) (url-cookie-retrieve host localpart secure))) ;;; Backend: curl (defvar request--curl-cookie-jar nil "Override what the function `request--curl-cookie-jar' returns. Currently it is used only for testing.") (defun request--curl-cookie-jar () "Cookie storage for curl backend." (or request--curl-cookie-jar (expand-file-name "curl-cookie-jar" request-storage-directory))) (defconst request--curl-write-out-template (if (eq system-type 'windows-nt) "\\n(:num-redirects %{num_redirects} :url-effective %{url_effective})" "\\n(:num-redirects %{num_redirects} :url-effective \"%{url_effective}\")")) (defun request--curl-mkdir-for-cookie-jar () (ignore-errors (make-directory (file-name-directory (request--curl-cookie-jar)) t))) (cl-defun request--curl-command (url &key type data headers timeout response files* unix-socket &allow-other-keys &aux (cookie-jar (convert-standard-filename (expand-file-name (request--curl-cookie-jar))))) (append (list request-curl "--silent" "--include" "--location" ;; FIXME: test automatic decompression "--compressed" ;; FIMXE: this way of using cookie might be problem when ;; running multiple requests. "--cookie" cookie-jar "--cookie-jar" cookie-jar "--write-out" request--curl-write-out-template) request-curl-options (when unix-socket (list "--unix-socket" unix-socket)) (cl-loop for (name filename path mime-type) in files* collect "--form" collect (format "%s=@%s;filename=%s%s" name (request-untrampify-filename path) filename (if mime-type (format ";type=%s" mime-type) ""))) (when data (let ((tempfile (request--make-temp-file))) (push tempfile (request-response--tempfiles response)) (let ((file-coding-system-alist nil) (coding-system-for-write 'binary)) (with-temp-file tempfile (setq buffer-file-coding-system 'binary) (set-buffer-multibyte nil) (insert data))) (list "--data-binary" (concat "@" (request-untrampify-filename tempfile))))) (when type (list "--request" type)) (cl-loop for (k . v) in headers collect "--header" collect (format "%s: %s" k v)) (list url))) (defun request--curl-normalize-files-1 (files get-temp-file) (cl-loop for (name . item) in files collect (cl-destructuring-bind (filename &key file buffer data mime-type) (cond ((stringp item) (list (file-name-nondirectory item) :file item)) ((bufferp item) (list (buffer-name item) :buffer item)) (t item)) (unless (= (cl-loop for v in (list file buffer data) if v sum 1) 1) (error "Only one of :file/:buffer/:data must be given. Got: %S" (cons name item))) (cond (file (list name filename file mime-type)) (buffer (let ((tf (funcall get-temp-file))) (with-current-buffer buffer (write-region (point-min) (point-max) tf nil 'silent)) (list name filename tf mime-type))) (data (let ((tf (funcall get-temp-file))) (with-temp-buffer (erase-buffer) (insert data) (write-region (point-min) (point-max) tf nil 'silent)) (list name filename tf mime-type))))))) (defun request--make-temp-file () "Create a temporary file." (if (file-remote-p default-directory) (let ((tramp-temp-name-prefix request-temp-prefix) (vec (tramp-dissect-file-name default-directory))) (tramp-make-tramp-file-name (tramp-file-name-method vec) (tramp-file-name-user vec) (tramp-file-name-host vec) (tramp-make-tramp-temp-file vec) (tramp-file-name-hop vec))) (make-temp-file request-temp-prefix))) (defun request--curl-normalize-files (files) "Change FILES into a list of (NAME FILENAME PATH MIME-TYPE). This is to make `request--curl-command' cleaner by converting FILES to a homogeneous list. It returns a list (FILES* TEMPFILES) where FILES* is a converted FILES and TEMPFILES is a list of temporary file paths." (let (tempfiles noerror) (unwind-protect (let* ((get-temp-file (lambda () (let ((tf (request--make-temp-file))) (push tf tempfiles) tf))) (files* (request--curl-normalize-files-1 files get-temp-file))) (setq noerror t) (list files* tempfiles)) (unless noerror ;; Remove temporary files only when an error occurs (request--safe-delete-files tempfiles))))) (defun request--safe-delete-files (files) "Remove FILES but do not raise error when failed to do so." (mapc (lambda (f) (condition-case err (delete-file f) (error (request-log 'error "Failed delete file %s. Got: %S" f err)))) files)) (cl-defun request--curl (url &rest settings &key type data files headers timeout response &allow-other-keys) "cURL-based request backend. Redirection handling strategy ----------------------------- curl follows redirection when --location is given. However, all headers are printed when it is used with --include option. Number of redirects is printed out sexp-based message using --write-out option (see `request--curl-write-out-template'). This number is used for removing extra headers and parse location header from the last redirection header. Sexp at the end of buffer and extra headers for redirects are removed from the buffer before it is shown to the parser function. " (request--curl-mkdir-for-cookie-jar) (let* (;; Use pipe instead of pty. Otherwise, curl process hangs. (process-connection-type nil) ;; Avoid starting program in non-existing directory. (home-directory (if (file-remote-p default-directory) (let ((vec (tramp-dissect-file-name default-directory))) (tramp-make-tramp-file-name (tramp-file-name-method vec) (tramp-file-name-user vec) (tramp-file-name-host vec) "~/" (tramp-file-name-hop vec))) "~/")) (default-directory (expand-file-name home-directory)) (buffer (generate-new-buffer " *request curl*")) (command (cl-destructuring-bind (files* tempfiles) (request--curl-normalize-files files) (setf (request-response--tempfiles response) tempfiles) (apply #'request--curl-command url :files* files* :response response settings))) (proc (apply #'start-file-process "request curl" buffer command))) (request-log 'debug "Run: %s" (mapconcat 'identity command " ")) (setf (request-response--buffer response) buffer) (process-put proc :request-response response) (set-process-coding-system proc 'binary 'binary) (set-process-query-on-exit-flag proc nil) (set-process-sentinel proc #'request--curl-callback))) (defun request--curl-read-and-delete-tail-info () "Read a sexp at the end of buffer and remove it and preceding character. This function moves the point at the end of buffer by side effect. See also `request--curl-write-out-template'." (let (forward-sexp-function) (goto-char (point-max)) (forward-sexp -1) (let ((beg (1- (point)))) (prog1 (read (current-buffer)) (delete-region beg (point-max)))))) (defconst request--cookie-reserved-re (mapconcat (lambda (x) (concat "\\(^" x "\\'\\)")) '("comment" "commenturl" "discard" "domain" "max-age" "path" "port" "secure" "version" "expires") "\\|") "Uninterested keys in cookie. See \"set-cookie-av\" in http://www.ietf.org/rfc/rfc2965.txt") (defun request--consume-100-continue () "Remove \"HTTP/* 100 Continue\" header at the point." (cl-destructuring-bind (&key code &allow-other-keys) (save-excursion (request--parse-response-at-point)) (when (equal code 100) (delete-region (point) (progn (request--goto-next-body) (point))) ;; FIXME: Does this make sense? Is it possible to have multiple 100? (request--consume-100-continue)))) (defun request--consume-200-connection-established () "Remove \"HTTP/* 200 Connection established\" header at the point." (when (looking-at-p "HTTP/1\\.[0-1] 200 Connection established") (delete-region (point) (progn (request--goto-next-body) (point))))) (defun request--curl-preprocess () "Pre-process current buffer before showing it to user." (let (history) (cl-destructuring-bind (&key num-redirects url-effective) (request--curl-read-and-delete-tail-info) (goto-char (point-min)) (request--consume-100-continue) (request--consume-200-connection-established) (when (> num-redirects 0) (cl-loop with case-fold-search = t repeat num-redirects ;; Do not store code=100 headers: do (request--consume-100-continue) do (let ((response (make-request-response :-buffer (current-buffer) :-backend 'curl))) (request--clean-header response) (request--cut-header response) (push response history)))) (goto-char (point-min)) (nconc (list :num-redirects num-redirects :url-effective url-effective :history (nreverse history)) (request--parse-response-at-point))))) (defun request--curl-absolutify-redirects (start-url redirects) "Convert relative paths in REDIRECTS to absolute URLs. START-URL is the URL requested." (cl-loop for prev-url = start-url then url for url in redirects unless (string-match url-nonrelative-link url) do (setq url (url-expand-file-name url prev-url)) collect url)) (defun request--curl-absolutify-location-history (start-url history) "Convert relative paths in HISTORY to absolute URLs. START-URL is the URL requested." (when history (setf (request-response-url (car history)) start-url)) (cl-loop for url in (request--curl-absolutify-redirects start-url (mapcar (lambda (response) (request-response-header response "location")) history)) for response in (cdr history) do (setf (request-response-url response) url))) (defun request--curl-callback (proc event) (let* ((buffer (process-buffer proc)) (response (process-get proc :request-response)) (symbol-status (request-response-symbol-status response)) (settings (request-response-settings response))) (request-log 'debug "REQUEST--CURL-CALLBACK event = %s" event) (request-log 'debug "REQUEST--CURL-CALLBACK proc = %S" proc) (request-log 'debug "REQUEST--CURL-CALLBACK buffer = %S" buffer) (request-log 'debug "REQUEST--CURL-CALLBACK symbol-status = %S" symbol-status) (cond ((and (memq (process-status proc) '(exit signal)) (/= (process-exit-status proc) 0)) (setf (request-response-error-thrown response) (cons 'error event)) (apply #'request--callback buffer settings)) ((equal event "finished\n") (cl-destructuring-bind (&key version code num-redirects history error url-effective) (condition-case err (with-current-buffer buffer (request--curl-preprocess)) ((debug error) (list :error err))) (request--curl-absolutify-location-history (plist-get settings :url) history) (setf (request-response-status-code response) code) (setf (request-response-url response) url-effective) (setf (request-response-history response) history) (setf (request-response-error-thrown response) (or error (when (>= code 400) `(error . (http ,code))))) (apply #'request--callback buffer settings)))))) (cl-defun request--curl-sync (url &rest settings &key response &allow-other-keys) ;; To make timeout work, use polling approach rather than using ;; `call-process'. (let (finished) (prog1 (apply #'request--curl url :complete (lambda (&rest _) (setq finished t)) settings) (let ((proc (get-buffer-process (request-response--buffer response)))) (while (and (not finished) (request--process-live-p proc)) (accept-process-output proc)))))) (defun request--curl-get-cookies (host localpart secure) (request--netscape-get-cookies (request--curl-cookie-jar) host localpart secure)) ;;; Netscape cookie.txt parser (defun request--netscape-cookie-parse () "Parse Netscape/Mozilla cookie format." (goto-char (point-min)) (let ((tsv-re (concat "^\\(#HttpOnly_\\)?" (cl-loop repeat 6 concat "\\([^\t\n]+\\)\t") "\\(.*\\)")) cookies) (while (not (eobp)) ;; HttpOnly cookie starts with '#' but its line is not comment line(#60) (cond ((and (looking-at-p "^#") (not (looking-at-p "^#HttpOnly_"))) t) ((looking-at-p "^$") t) ((looking-at tsv-re) (let ((cookie (cl-loop for i from 1 to 8 collect (match-string i)))) (push cookie cookies)))) (forward-line 1)) (setq cookies (nreverse cookies)) (cl-loop for (http-only domain flag path secure expiration name value) in cookies collect (list domain (equal flag "TRUE") path (equal secure "TRUE") (null (not http-only)) (string-to-number expiration) name value)))) (defun request--netscape-filter-cookies (cookies host localpart secure) (cl-loop for (domain flag path secure-1 http-only expiration name value) in cookies when (and (equal domain host) (equal path localpart) (or secure (not secure-1))) collect (cons name value))) (defun request--netscape-get-cookies (filename host localpart secure) (when (file-readable-p filename) (with-temp-buffer (erase-buffer) (insert-file-contents filename) (request--netscape-filter-cookies (request--netscape-cookie-parse) host localpart secure)))) (provide 'request) ;;; request.el ends here ================================================ FILE: t/batch-runner/s.el ================================================ ;;; s.el --- The long lost Emacs string manipulation library. ;; Copyright (C) 2012-2015 Magnar Sveen ;; Author: Magnar Sveen ;; Version: 1.12.0 ;; Package-Version: 20171102.227 ;; 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." (save-match-data (declare (pure t) (side-effect-free t)) (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-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-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 ((search-length (min (length s1) (length s2))) (i 0)) (while (and (< i search-length) (= (aref s1 i) (aref s2 i))) (setq i (1+ i))) (substring s1 0 i))) (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) "If S is longer than LEN, cut it down to LEN - 3 and add ... at the end." (declare (pure t) (side-effect-free t)) (if (> (length s) len) (format "%s..." (substring s 0 (- len 3))) 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 (make-string (floor extra 2) ? )))) (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-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) (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)) (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 the first word's first character to upper case and the rest to lower case in S." (declare (side-effect-free t)) (concat (upcase (substring s 0 1)) (downcase (substring s 1)))) (defun s-titleize (s) "Convert each word's first character to upper case and the rest to lower case in S. 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))) (let ((m (match-end subexp-depth))) (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. If it 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 (= 0 (length s)) (list "") (save-match-data (let (i) (setq i (string-match regexp s 1)) (if i (cons (substring s 0 i) (s-slice-at regexp (substring s i))) (list s)))))) (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-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. " (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-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 ================================================ FILE: t/jiralib-t.el ================================================ ;;; jiralib-t.el --- ERT tests ;; Copyright (C) 2017 Matthew Carter ;; ;; Authors: ;; Matthew Carter ;; ;; Maintainer: Matthew Carter ;; URL: https://github.com/ahungry/org-jira ;; Version: 2.6.2 ;; Keywords: ahungry jira org bug tracker ;; Package-Requires: ((emacs "24.5") (cl-lib "0.5") (request "0.2.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 this program. If not, see ;; or write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;; 02110-1301, USA. ;;; Commentary: ;; This tests the extension to org-mode for syncing issues with JIRA ;; issue servers. ;;; News: ;;;; Changes since 0.0.0: ;; - Add some basic tests ;;; Code: (require 'jiralib) (ert-deftest jiralib-format-datetime-test () (should (string= "2017-01-01T00:00:00.000+0000" (jiralib-format-datetime "2017-01-01 00:00:00")))) (provide 'jiralib-t) ;;; jiralib-t.el ends here ================================================ FILE: t/org-jira-t.el ================================================ ;;; org-jira-t.el --- ERT tests ;; Copyright (C) 2017 Matthew Carter ;; ;; Authors: ;; Matthew Carter ;; ;; Maintainer: Matthew Carter ;; URL: https://github.com/ahungry/org-jira ;; Version: 2.6.2 ;; Keywords: ahungry jira org bug tracker ;; Package-Requires: ((emacs "24.5") (cl-lib "0.5") (request "0.2.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 this program. If not, see ;; or write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA ;; 02110-1301, USA. ;;; Commentary: ;; This tests the extension to org-mode for syncing issues with JIRA ;; issue servers. ;;; News: ;;;; Changes since 0.0.0: ;; - Add some basic tests ;;; Code: (require 'org-jira) (set-time-zone-rule t) (ert-deftest org-jira-date-strip-letter-t-test () (should (string= "2017-01-01 00:00:00+0000" (org-jira-date-strip-letter-t "2017-01-01T00:00:00.000+0000"))) ) (ert-deftest org-jira-date-to-org-clock-test () (should (string= "2017-01-01 Sun 00:00" (org-jira-date-to-org-clock "2017-01-01T00:00:00.000+0000"))) (should (string= "2017-02-05 Sun 00:00" (org-jira-date-to-org-clock "2017-02-05T00:00:00.000+0000"))) ) (ert-deftest org-jira-org-clock-to-date-test () (should (string= "2017-01-01T00:00:00.000+0000" (org-jira-org-clock-to-date "2017-01-01 Sun 00:00"))) ) (ert-deftest org-jira-time-stamp-to-org-clock-test () (should (string= "2017-01-01 Sun 00:05" (org-jira-time-stamp-to-org-clock '(22632 18348)))) ) (defvar org-jira-worklog-fixture-response '((startAt . 0) (maxResults . 2) (total . 2) (worklogs . [((self . "https://example.com/rest/api/2/issue/10402/worklog/10101") (author (self . "https://example.com/rest/api/2/user?username=admin") (name . "admin") (key . "admin") (accountId . "omitted") (emailAddress . "m@example.com") (avatarUrls (48x48 . "https://avatar-cdn.atlassian.com/12345?s=48&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D48%26noRedirect%3Dtrue") (24x24 . "https://avatar-cdn.atlassian.com/12345?s=24&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D24%26noRedirect%3Dtrue") (16x16 . "https://avatar-cdn.atlassian.com/12345?s=16&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D16%26noRedirect%3Dtrue") (32x32 . "https://avatar-cdn.atlassian.com/12345?s=32&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D32%26noRedirect%3Dtrue")) (displayName . "Matthew Carter") (active . t) (timeZone . "America/New_York")) (updateAuthor (self . "https://example.com/rest/api/2/user?username=admin") (name . "admin") (key . "admin") (accountId . "omitted") (emailAddress . "m@example.com") (avatarUrls (48x48 . "https://avatar-cdn.atlassian.com/12345?s=48&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D48%26noRedirect%3Dtrue") (24x24 . "https://avatar-cdn.atlassian.com/12345?s=24&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D24%26noRedirect%3Dtrue") (16x16 . "https://avatar-cdn.atlassian.com/12345?s=16&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D16%26noRedirect%3Dtrue") (32x32 . "https://avatar-cdn.atlassian.com/12345?s=32&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D32%26noRedirect%3Dtrue")) (displayName . "Matthew Carter") (active . t) (timeZone . "America/New_York")) (comment . "Some comment here") (created . "2017-02-27T23:47:04.261+0000") (updated . "2017-02-27T23:47:04.261+0000") (started . "2017-02-26T00:08:00.000+0000") (timeSpent . "1h") (timeSpentSeconds . 3600) (id . "10101") (issueId . "10402")) ((self . "https://example.com/rest/api/2/issue/10402/worklog/10200") (author (self . "https://example.com/rest/api/2/user?username=admin") (name . "admin") (key . "admin") (accountId . "omitted") (emailAddress . "m@example.com") (avatarUrls (48x48 . "https://avatar-cdn.atlassian.com/12345?s=48&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D48%26noRedirect%3Dtrue") (24x24 . "https://avatar-cdn.atlassian.com/12345?s=24&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D24%26noRedirect%3Dtrue") (16x16 . "https://avatar-cdn.atlassian.com/12345?s=16&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D16%26noRedirect%3Dtrue") (32x32 . "https://avatar-cdn.atlassian.com/12345?s=32&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D32%26noRedirect%3Dtrue")) (displayName . "Matthew Carter") (active . t) (timeZone . "America/New_York")) (updateAuthor (self . "https://example.com/rest/api/2/user?username=admin") (name . "admin") (key . "admin") (accountId . "omitted") (emailAddress . "m@example.com") (avatarUrls (48x48 . "https://avatar-cdn.atlassian.com/12345?s=48&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D48%26noRedirect%3Dtrue") (24x24 . "https://avatar-cdn.atlassian.com/12345?s=24&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D24%26noRedirect%3Dtrue") (16x16 . "https://avatar-cdn.atlassian.com/12345?s=16&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D16%26noRedirect%3Dtrue") (32x32 . "https://avatar-cdn.atlassian.com/12345?s=32&d=https%3A%2F%2Fsecure.gravatar.com%2Favatar%2F12345%3Fd%3Dmm%26s%3D32%26noRedirect%3Dtrue")) (displayName . "Matthew Carter") (active . t) (timeZone . "America/New_York")) (comment . "Add 32 minutes") (created . "2017-03-16T23:25:45.396+0000") (updated . "2017-03-16T23:25:45.396+0000") (started . "2017-03-16T22:25:00.000+0000") (timeSpent . "32m") (timeSpentSeconds . 1920) (id . "10200") (issueId . "10402"))])) "A sample response, as served from the #'jiralib-get-worklogs call.") ;; (ert-deftest org-jira-worklogs-to-org-clocks-test () ;; (let ((result (org-jira-worklogs-to-org-clocks ;; (cdr (assoc 'worklogs org-jira-worklog-fixture-response))))) ;; (should ;; (string= "2017-02-26 Sun 00:08" ;; (caar result))) ;; (should ;; (string= "2017-02-26 Sun 01:08" ;; (cadar result))) ;; (should ;; (string= "2017-03-16 Thu 22:25" ;; (caadr result))) ;; (should ;; (string= "2017-03-16 Thu 22:57" ;; (cadadr result))) ;; )) (ert-deftest org-jira-format-clock-test () (should (string= "CLOCK: [2017-02-26 Sun 00:08]--[2017-02-26 Sun 01:08]" (org-jira-format-clock '("2017-02-26 Sun 00:08" "2017-02-26 Sun 01:08"))))) (ert-deftest org-jira-org-clock-to-jira-worklog-test () (let ((result (org-jira-org-clock-to-jira-worklog "[2017-04-05 Wed 01:00]--[2017-04-05 Wed 01:46] => 0:46" " :id: 10101 Success! CLOCK:"))) (should (string= "10101" (cdr (assoc 'worklog-id result)))) (should (string= "Success!" (cdr (assoc 'comment result)))) (should (string= "2017-04-05T01:00:00.000+0000" (cdr (assoc 'started result)))) (should (= 2760.0 (cdr (assoc 'time-spent-seconds result)))) )) (ert-deftest org-jira-org-clock-to-jira-worklog-no-id-test () (let ((result (org-jira-org-clock-to-jira-worklog "[2017-04-05 Wed 01:00]--[2017-04-05 Wed 01:46] => 0:46" "My sweet comment! CLOCK:"))) (should (equal nil (cdr (assoc 'worklog-id result)))) (should (string= "My sweet comment!" (cdr (assoc 'comment result)))) (should (string= "2017-04-05T01:00:00.000+0000" (cdr (assoc 'started result)))) (should (= 2760.0 (cdr (assoc 'time-spent-seconds result)))) )) (ert-deftest org-jira-sort-org-clocks-test () (let* ((clocks '(("2017-02-26 Sun 00:08" "2017-02-26 Sun 01:08" "Some comment here" "10101") ("2017-03-16 Thu 22:25" "2017-03-16 Thu 22:57" "Add 32 minutes" "10200")) ) (result (org-jira-sort-org-clocks clocks))) (should (string= "2017-03-16 Thu 22:25" (car (car result)))) )) (ert-deftest org-jira-strip-string-test () (should (string= "dog" (org-jira-strip-string " dog ")))) ;; This test sort of sucks, as its just confirming we get back some strings. (ert-deftest org-jira-decode-test () (should (string= "" (org-jira-decode nil))) (should (string= "dog" (org-jira-decode "dog")))) (ert-deftest org-jira-t-get-org-priority-string () (let ((org-jira-priority-to-org-priority-omit-default-priority nil) (org-default-priority ?B)) (should (string= "[#B] " (org-jira-get-org-priority-string ?B))) (setq org-jira-priority-to-org-priority-omit-default-priority t) (should (string= "" (org-jira-get-org-priority-string ?B))) (should (string= "" (org-jira-get-org-priority-string nil))) ) ) (ert-deftest org-jira-t-strip-priority-tags () (should (string= "good and clean" (org-jira-strip-priority-tags "[#C] good and clean"))) (should (string= "food and clean" (org-jira-strip-priority-tags " [#C] [#D] food and clean "))) ) (provide 'org-jira-t) ;;; org-jira-t.el ends here ================================================ FILE: todo.org ================================================ * Worklog ** TODO Sync up Estimate/Remaining Estimate in Worklog or Property With the dynamic org clocking, integrate with how org clock tracks estimates would be a good idea.