From: David Kastrup <dak@gnu.org>
Date: Fri, 26 Apr 2013 12:20:28 +0000 (+0200)
Subject: Issue 3293: Add point-and-click to SVG output
X-Git-Tag: release/2.17.24-1~5
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=9621fd600e1153146ebd4326f40eef4491396a97;p=lilypond.git

Issue 3293: Add point-and-click to SVG output
---

diff --git a/scm/output-svg.scm b/scm/output-svg.scm
index 8e2c532a3b..1df5a53d70 100644
--- a/scm/output-svg.scm
+++ b/scm/output-svg.scm
@@ -473,13 +473,38 @@
   (if (not (ly:get-option 'svg-woff)) embedded-glyph-string woff-glyph-string))
 
 (define (grob-cause offset grob)
-  "")
+  (and (ly:get-option 'point-and-click)
+       (let* ((cause (ly:grob-property grob 'cause))
+              (music-origin (if (ly:stream-event? cause)
+                                (ly:event-property cause 'origin)))
+              (point-and-click (ly:get-option 'point-and-click)))
+         (and (ly:input-location? music-origin)
+              (cond ((boolean? point-and-click) point-and-click)
+                    ((symbol? point-and-click)
+                     (ly:in-event-class? cause point-and-click))
+                    (else (any (lambda (t)
+                                 (ly:in-event-class? cause t))
+                               point-and-click)))
+              (let* ((location (ly:input-file-line-char-column music-origin))
+                     (raw-file (car location))
+                     (file (if (is-absolute? raw-file)
+                               raw-file
+                               (string-append (ly-getcwd) "/" raw-file))))
+                
+                (ly:format "<a style=\"color:inherit;\" xlink:href=\"textedit://~a:~a:~a:~a\">\n"
+                           ;; Backslashes are not valid
+                           ;; file URI path separators.
+                           (ly:string-percent-encode
+                            (ly:string-substitute "\\" "/" file))
+                           
+                           (cadr location)
+                           (caddr location)
+                           (1+ (cadddr location))))))))
 
 (define (named-glyph font name)
   (fontify font name))
 
-(define (no-origin)
-  "")
+(define (no-origin) "</a>\n")
 
 (define* (path thick commands #:optional (cap 'round) (join 'round) (fill? #f))
   (define (convert-path-exps exps)