]> git.donarmstrong.com Git - lilypond.git/blob - lily/general-scheme.cc
Release: bump VERSION_DEVEL.
[lilypond.git] / lily / general-scheme.cc
1 /*
2   This file is part of LilyPond, the GNU music typesetter.
3
4   Copyright (C) 1998--2014 Jan Nieuwenhuizen <janneke@gnu.org>
5   Han-Wen Nienhuys <hanwen@xs4all.nl>
6
7   LilyPond is free software: you can redistribute it and/or modify
8   it under the terms of the GNU General Public License as published by
9   the Free Software Foundation, either version 3 of the License, or
10   (at your option) any later version.
11
12   LilyPond is distributed in the hope that it will be useful,
13   but WITHOUT ANY WARRANTY; without even the implied warranty of
14   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15   GNU General Public License for more details.
16
17   You should have received a copy of the GNU General Public License
18   along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
19 */
20
21 #include "config.hh"
22
23 #include <cstdio>
24 #include <ctype.h>
25 #include <cstring>  /* memset */
26 #include <glib.h>
27 using namespace std;
28
29 #include "dimensions.hh"
30 #include "file-name.hh"
31 #include "file-path.hh"
32 #include "international.hh"
33 #include "libc-extension.hh"
34 #include "lily-guile.hh"
35 #include "main.hh"
36 #include "misc.hh"
37 #include "program-option.hh"
38 #include "relocate.hh"
39 #include "string-convert.hh"
40 #include "version.hh"
41 #include "warn.hh"
42
43 /* Declaration of log function(s) */
44 SCM ly_progress (SCM, SCM);
45
46 LY_DEFINE (ly_start_environment, "ly:start-environment",
47            0, 0, 0, (),
48            "Return the environment (a list of strings) that was in"
49            " effect at program start.")
50 {
51   SCM l = SCM_EOL;
52   SCM *tail = &l;
53
54   for (vsize i = 0; i < start_environment_global.size (); i++)
55     {
56       *tail = scm_cons (ly_string2scm (start_environment_global[i]),
57                         SCM_EOL);
58       tail = SCM_CDRLOC (*tail);
59     }
60
61   return l;
62 }
63
64 LY_DEFINE (ly_find_file, "ly:find-file",
65            1, 0, 0, (SCM name),
66            "Return the absolute file name of @var{name},"
67            " or @code{#f} if not found.")
68 {
69   LY_ASSERT_TYPE (scm_is_string, name, 1);
70
71   string nm = ly_scm2string (name);
72   string file_name = global_path.find (nm);
73   if (file_name.empty ())
74     return SCM_BOOL_F;
75
76   return ly_string2scm (file_name);
77 }
78
79 /*
80   Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
81   buffering.)
82 */
83 LY_DEFINE (ly_gulp_file, "ly:gulp-file",
84            1, 1, 0, (SCM name, SCM size),
85            "Read @var{size} characters from the file @var{name},"
86            " and return its contents in a string."
87            "  If @var{size} is undefined, the entire file is read."
88            "  The file is looked up using the search path.")
89 {
90   LY_ASSERT_TYPE (scm_is_string, name, 1);
91   int sz = INT_MAX;
92   if (size != SCM_UNDEFINED)
93     {
94       LY_ASSERT_TYPE (scm_is_number, size, 2);
95       sz = scm_to_int (size);
96     }
97
98   string contents = gulp_file_to_string (ly_scm2string (name), true, sz);
99   return scm_from_locale_stringn (contents.c_str (), contents.length ());
100 }
101
102 LY_DEFINE (ly_dir_p, "ly:dir?",
103            1, 0, 0, (SCM s),
104            "Is @var{s} a direction?  Valid directions are @w{@code{-1}},"
105            " @code{0}, or@tie{}@code{1}, where @w{@code{-1}} represents"
106            " left or down, @code{1}@tie{}represents right or up, and @code{0}"
107            " represents a neutral direction.")
108 {
109   if (scm_is_integer (s))
110     {
111       int i = scm_to_int (s);
112       return (i >= -1 && i <= 1) ? SCM_BOOL_T : SCM_BOOL_F;
113     }
114   return SCM_BOOL_F;
115 }
116
117 LY_DEFINE (ly_assoc_get, "ly:assoc-get",
118            2, 2, 0,
119            (SCM key, SCM alist, SCM default_value, SCM strict_checking),
120            "Return value if @var{key} in @var{alist}, else @var{default-value}"
121            " (or @code{#f} if not specified).  If @var{strict-checking} is set"
122            " to @code{#t} and @var{key} is not in @var{alist}, a programming_error"
123            " is output.")
124 {
125   LY_ASSERT_TYPE (ly_cheap_is_list, alist, 2);
126
127   SCM handle = scm_assoc (key, alist);
128   if (scm_is_pair (handle))
129     return scm_cdr (handle);
130
131   if (default_value == SCM_UNDEFINED)
132     default_value = SCM_BOOL_F;
133
134   if (strict_checking == SCM_BOOL_T)
135     {
136       string key_string = ly_scm2string
137                           (scm_object_to_string (key, SCM_UNDEFINED));
138       string default_value_string = ly_scm2string
139                                     (scm_object_to_string (default_value,
140                                                            SCM_UNDEFINED));
141       programming_error ("Cannot find key `"
142                          + key_string
143                          + "' in alist, setting to `"
144                          + default_value_string + "'.");
145     }
146
147   return default_value;
148 }
149
150 LY_DEFINE (ly_string_substitute, "ly:string-substitute",
151            3, 0, 0, (SCM a, SCM b, SCM s),
152            "Replace string@tie{}@var{a} by string@tie{}@var{b} in"
153            " string@tie{}@var{s}.")
154 {
155   LY_ASSERT_TYPE (scm_is_string, s, 1);
156   LY_ASSERT_TYPE (scm_is_string, b, 2);
157   LY_ASSERT_TYPE (scm_is_string, s, 3);
158
159   string ss = ly_scm2string (s);
160   replace_all (&ss, ly_scm2string (a),
161                ly_scm2string (b));
162
163   return ly_string2scm (ss);
164 }
165
166 bool
167 is_not_escape_character (Byte c)
168 {
169   switch (c)
170     {
171     case '-':
172     case '.':
173     case '/':
174     case '0'...'9':
175     case ':':
176     case 'A'...'Z':
177     case '_':
178     case 'a'...'z':
179       return true;
180     }
181
182   return false;
183 }
184
185 LY_DEFINE (ly_string_percent_encode, "ly:string-percent-encode",
186            1, 0, 0, (SCM str),
187            "Encode all characters in string @var{str} with hexadecimal"
188            " percent escape sequences, with the following exceptions:"
189            " characters @w{@code{-},} @code{.}, @code{/}, and @code{_}; and"
190            " characters in ranges @code{0-9}, @code{A-Z}, and @code{a-z}.")
191 {
192   LY_ASSERT_TYPE (scm_is_string, str, 1);
193
194   string orig_str = ly_scm2string (str);
195   string new_str = "";
196
197   vsize i = 0;
198   vsize n = orig_str.size ();
199
200   while (i < n)
201     {
202       Byte cur = orig_str[i];
203
204       if (is_not_escape_character (cur))
205         new_str += cur;
206       else
207         {
208           new_str += '%';
209           new_str += String_convert::bin2hex (cur);
210         }
211
212       i++;
213     }
214
215   return ly_string2scm (new_str);
216 }
217
218 LY_DEFINE (ly_number_2_string, "ly:number->string",
219            1, 0, 0, (SCM s),
220            "Convert @var{s} to a string without generating many decimals.")
221 {
222   LY_ASSERT_TYPE (scm_is_number, s, 1);
223
224   char str[400];                        // ugh.
225
226   if (scm_exact_p (s) == SCM_BOOL_F)
227     {
228       Real r (scm_to_double (s));
229       if (isinf (r) || isnan (r))
230         {
231           programming_error ("infinity or NaN encountered while converting Real number, "
232                              "setting to zero");
233
234           r = 0.0;
235         }
236
237       snprintf (str, sizeof (str), "%.4f", r);
238     }
239   else
240     snprintf (str, sizeof (str), "%d", int (scm_to_int (s)));
241
242   return scm_from_locale_string (str);
243 }
244
245 LY_DEFINE (ly_version, "ly:version", 0, 0, 0, (),
246            "Return the current lilypond version as a list, e.g.,"
247            " @code{(1 3 127 uu1)}.")
248 {
249   char const *vs = "\'(" MAJOR_VERSION " " MINOR_VERSION " " PATCH_LEVEL " " MY_PATCH_LEVEL ")";
250
251   return scm_c_eval_string ((char *)vs);
252 }
253
254 LY_DEFINE (ly_unit, "ly:unit", 0, 0, 0, (),
255            "Return the unit used for lengths as a string.")
256 {
257   return scm_from_locale_string (INTERNAL_UNIT);
258 }
259
260 LY_DEFINE (ly_dimension_p, "ly:dimension?", 1, 0, 0, (SCM d),
261            "Return @var{d} as a number.  Used to distinguish length"
262            " variables from normal numbers.")
263 {
264   return scm_number_p (d);
265 }
266
267 /*
268   Debugging mem leaks:
269 */
270 LY_DEFINE (ly_protects, "ly:protects",
271            0, 0, 0, (),
272            "Return hash of protected objects.")
273 {
274   //scm_protects is available only in Guile versions before 2.1.
275 #if SCM_MAJOR_VERSION < 2 || SCM_MAJOR_VERSION == 2 && SCM_MINOR_VERSION < 1
276   return scm_protects;
277 #else
278   return programming_error ("ly:protects is not supported in Guile 2.1");
279 #endif
280 }
281
282 LY_DEFINE (ly_gettext, "ly:gettext",
283            1, 0, 0, (SCM original),
284            "A Scheme wrapper function for @code{gettext}.")
285 {
286   LY_ASSERT_TYPE (scm_is_string, original, 1);
287   return ly_string2scm (_ (ly_scm2string (original).c_str ()));
288 }
289
290 LY_DEFINE (ly_output_formats, "ly:output-formats",
291            0, 0, 0, (),
292            "Formats passed to @option{--format} as a list of strings,"
293            " used for the output.")
294 {
295   vector<string> output_formats = string_split (output_format_global, ',');
296
297   SCM lst = SCM_EOL;
298   int output_formats_count = output_formats.size ();
299   for (int i = 0; i < output_formats_count; i++)
300     lst = scm_cons (ly_string2scm (output_formats[i]), lst);
301
302   return lst;
303 }
304
305 LY_DEFINE (ly_wide_char_2_utf_8, "ly:wide-char->utf-8",
306            1, 0, 0, (SCM wc),
307            "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8.")
308 {
309   char buf[5];
310
311   LY_ASSERT_TYPE (scm_is_integer, wc, 1);
312   unsigned wide_char = (unsigned) scm_to_int (wc);
313   char *p = buf;
314
315   if (wide_char < 0x0080)
316     *p++ = (char)wide_char;
317   else if (wide_char < 0x0800)
318     {
319       *p++ = (char) (((wide_char >> 6)) | 0xC0);
320       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
321     }
322   else if (wide_char < 0x10000)
323     {
324       *p++ = (char) (((wide_char >> 12)) | 0xE0);
325       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
326       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
327     }
328   else
329     {
330       *p++ = (char) (((wide_char >> 18)) | 0xF0);
331       *p++ = (char) (((wide_char >> 12) & 0x3F) | 0x80);
332       *p++ = (char) (((wide_char >> 6) & 0x3F) | 0x80);
333       *p++ = (char) (((wide_char) & 0x3F) | 0x80);
334     }
335   *p = 0;
336
337   return scm_from_locale_string (buf);
338 }
339
340 LY_DEFINE (ly_effective_prefix, "ly:effective-prefix",
341            0, 0, 0, (),
342            "Return effective prefix.")
343 {
344   return ly_string2scm (lilypond_datadir);
345 }
346
347 LY_DEFINE (ly_chain_assoc_get, "ly:chain-assoc-get",
348            2, 2, 0, (SCM key, SCM achain, SCM default_value, SCM strict_checking),
349            "Return value for @var{key} from a list of alists @var{achain}."
350            "  If no entry is found, return @var{default-value} or @code{#f} if"
351            " @var{default-value} is not specified.  With @var{strict-checking}"
352            " set to @code{#t}, a programming_error is output in such cases.")
353 {
354   if (scm_is_pair (achain))
355     {
356       SCM handle = scm_assoc (key, scm_car (achain));
357       if (scm_is_pair (handle))
358         return scm_cdr (handle);
359       else
360         return ly_chain_assoc_get (key, scm_cdr (achain), default_value);
361     }
362
363   if (strict_checking == SCM_BOOL_T)
364     {
365       string key_string = ly_scm2string
366                           (scm_object_to_string (key, SCM_UNDEFINED));
367       string default_value_string = ly_scm2string
368                                     (scm_object_to_string (default_value,
369                                                            SCM_UNDEFINED));
370       programming_error ("Cannot find key `"
371                          + key_string
372                          + "' in achain, setting to `"
373                          + default_value_string + "'.");
374     }
375
376   return default_value == SCM_UNDEFINED ? SCM_BOOL_F : default_value;
377 }
378
379 LY_DEFINE (ly_stderr_redirect, "ly:stderr-redirect",
380            1, 1, 0, (SCM file_name, SCM mode),
381            "Redirect stderr to @var{file-name}, opened with @var{mode}.")
382 {
383   LY_ASSERT_TYPE (scm_is_string, file_name, 1);
384
385   string m = "w";
386   string f = ly_scm2string (file_name);
387   FILE *stderrfile;
388   if (scm_is_string (mode))
389     m = ly_scm2string (mode);
390   /* dup2 and (fileno (current-error-port)) do not work with mingw'c
391      gcc -mwindows.  */
392   fflush (stderr);
393   stderrfile = freopen (f.c_str (), m.c_str (), stderr);
394   if (!stderrfile)
395     error (_f ("failed redirecting stderr to `%s'", f.c_str ()));
396   return SCM_UNSPECIFIED;
397 }
398
399 static SCM
400 accumulate_symbol (void * /* closure */,
401                    SCM key,
402                    SCM /* val */,
403                    SCM result)
404 {
405   return scm_cons (key, result);
406 }
407
408 LY_DEFINE (ly_hash_table_keys, "ly:hash-table-keys",
409            1, 0, 0, (SCM tab),
410            "Return a list of keys in @var{tab}.")
411 {
412   return scm_internal_hash_fold ((scm_t_hash_fold_fn) &accumulate_symbol,
413                                  NULL, SCM_EOL, tab);
414 }
415
416 LY_DEFINE (ly_camel_case_2_lisp_identifier, "ly:camel-case->lisp-identifier",
417            1, 0, 0, (SCM name_sym),
418            "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
419 {
420   LY_ASSERT_TYPE (ly_is_symbol, name_sym, 1);
421
422   /*
423     TODO: should use strings instead?
424   */
425
426   const string in = ly_symbol2string (name_sym);
427   string result = camel_case_to_lisp_identifier (in);
428
429   return ly_symbol2scm (result.c_str ());
430 }
431
432 LY_DEFINE (ly_expand_environment, "ly:expand-environment",
433            1, 0, 0, (SCM str),
434            "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
435 {
436   LY_ASSERT_TYPE (scm_is_string, str, 1);
437
438   return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
439 }
440
441 LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
442            2, 0, 0, (SCM lst, SCM i),
443            "Take at most the first @var{i} of list @var{lst}.")
444 {
445   LY_ASSERT_TYPE (scm_is_integer, i, 1);
446
447   int k = scm_to_int (i);
448   if (k == 0)
449     lst = SCM_EOL;
450   else
451     {
452       SCM s = lst;
453       k--;
454       for (; scm_is_pair (s) && k--; s = scm_cdr (s))
455         ;
456
457       if (scm_is_pair (s))
458         scm_set_cdr_x (s, SCM_EOL);
459     }
460   return lst;
461 }
462
463 string
464 format_single_argument (SCM arg, int precision, bool escape = false)
465 {
466   if (scm_is_integer (arg) && scm_exact_p (arg) == SCM_BOOL_T)
467     return (String_convert::int_string (scm_to_int (arg)));
468   else if (scm_is_number (arg))
469     {
470       Real val = scm_to_double (arg);
471
472       if (isnan (val) || isinf (val))
473         {
474           warning (_ ("Found infinity or nan in output.  Substituting 0.0"));
475           return ("0.0");
476           if (strict_infinity_checking)
477             abort ();
478         }
479       else
480         return (String_convert::form_string ("%.*lf", precision, val));
481     }
482   else if (scm_is_string (arg))
483     {
484       string s = ly_scm2string (arg);
485       if (escape)
486         {
487           // Escape backslashes and double quotes, wrap it in double quotes
488           replace_all (&s, "\\", "\\\\");
489           replace_all (&s, "\"", "\\\"");
490           // don't replace percents, since the png backend uses %d as escape sequence
491           // replace_all (&s, "%", "\\%");
492           replace_all (&s, "$", "\\$");
493           s = "\"" + s + "\"";
494         }
495       return s;
496     }
497   else if (scm_is_symbol (arg))
498     return (ly_symbol2string (arg));
499   else
500     {
501       ly_progress (scm_from_locale_string ("\nUnsupported SCM value for format: ~a"),
502                    scm_list_1 (arg));
503     }
504
505   return "";
506 }
507
508 LY_DEFINE (ly_format, "ly:format",
509            1, 0, 1, (SCM str, SCM rest),
510            "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}."
511            "  Basic support for @code{~s} is also provided.")
512 {
513   LY_ASSERT_TYPE (scm_is_string, str, 1);
514
515   string format = ly_scm2string (str);
516   vector<string> results;
517
518   vsize i = 0;
519   while (i < format.size ())
520     {
521       vsize tilde = format.find ('~', i);
522
523       results.push_back (format.substr (i, (tilde - i)));
524
525       if (tilde == NPOS)
526         break;
527
528       tilde++;
529
530       char spec = format.at (tilde++);
531       if (spec == '~')
532         results.push_back ("~");
533       else
534         {
535           if (!scm_is_pair (rest))
536             {
537               programming_error (string (__FUNCTION__)
538                                  + ": not enough arguments for format.");
539               return ly_string2scm ("");
540             }
541
542           SCM arg = scm_car (rest);
543           rest = scm_cdr (rest);
544
545           int precision = 8;
546
547           if (spec == '$')
548             precision = 2;
549           else if (isdigit (spec))
550             {
551               precision = spec - '0';
552               spec = format.at (tilde++);
553             }
554
555           if (spec == 'a' || spec == 'A' || spec == 'f' || spec == '$')
556             results.push_back (format_single_argument (arg, precision));
557           else if (spec == 's' || spec == 'S')
558             results.push_back (format_single_argument (arg, precision, true));
559           else if (spec == 'l')
560             {
561               SCM s = arg;
562               for (; scm_is_pair (s); s = scm_cdr (s))
563                 {
564                   results.push_back (format_single_argument (scm_car (s), precision));
565                   if (scm_cdr (s) != SCM_EOL)
566                     results.push_back (" ");
567                 }
568
569               if (s != SCM_EOL)
570                 results.push_back (format_single_argument (s, precision));
571
572             }
573         }
574
575       i = tilde;
576     }
577
578   if (scm_is_pair (rest))
579     programming_error (string (__FUNCTION__)
580                        + ": too many arguments");
581
582   vsize len = 0;
583   for (vsize i = 0; i < results.size (); i++)
584     len += results[i].size ();
585
586   char *result = (char *) scm_malloc (len + 1);
587   char *ptr = result;
588   for (vsize i = 0; i < results.size (); i++)
589     {
590       strncpy (ptr, results[i].c_str (), results[i].size ());
591       ptr += results[i].size ();
592     }
593   *ptr = '\0';
594
595   return scm_take_locale_stringn (result, len);
596 }
597
598 int
599 ly_run_command (char *argv[], char **standard_output, char **standard_error)
600 {
601   GError *error = 0;
602   int exit_status = 0;
603   int flags = G_SPAWN_SEARCH_PATH;
604   if (!standard_output)
605     flags |= G_SPAWN_STDOUT_TO_DEV_NULL;
606   if (!standard_error)
607     flags |= G_SPAWN_STDERR_TO_DEV_NULL;
608   if (!g_spawn_sync (0, argv, 0, GSpawnFlags (flags),
609                      0, 0,
610                      standard_output, standard_error,
611                      &exit_status, &error))
612     {
613       fprintf (stderr, "failed (%d): %s: %s\n", exit_status, argv[0], error->message);
614       g_error_free (error);
615       if (!exit_status)
616         exit_status = -1;
617     }
618
619   return exit_status;
620 }
621
622 static char *
623 ly_scm2utf8 (SCM str)
624 {
625   char *p = ly_scm2str0 (str);
626   char *g = g_locale_to_utf8 (p, -1, 0, 0, 0);
627   free (p);
628   return g;
629 }
630
631 LY_DEFINE (ly_spawn, "ly:spawn",
632            1, 0, 1, (SCM command, SCM rest),
633            "Simple interface to g_spawn_sync"
634            " @var{str}."
635            "  The error is formatted with @code{format} and @var{rest}.")
636
637 {
638   LY_ASSERT_TYPE (scm_is_string, command, 1);
639
640   int argc = scm_is_pair (rest) ? scm_ilength (rest) : 0;
641   char **argv = new char*[argc + 2];
642
643   int n = 0;
644   argv[n++] = ly_scm2utf8 (command);
645   for (SCM s = rest; scm_is_pair (s); s = scm_cdr (s))
646     argv[n++] = ly_scm2utf8 (scm_car (s));
647   argv[n] = 0;
648
649   char *standard_output = 0;
650   char *standard_error = 0;
651   // Always get the pointer to the stdout/stderr messages
652   int exit_status = ly_run_command (argv, &standard_output, &standard_error);
653
654   // Print out stdout and stderr only in debug mode
655   debug_output (string ("\n") + standard_output + standard_error, true);
656
657   for (int i = 0; i < n; i++)
658     free (argv[i]);
659   delete[] argv;
660
661   return scm_from_int (exit_status);
662 }