2 This file is part of LilyPond, the GNU music typesetter.
4 Copyright (C) 1998--2010 Jan Nieuwenhuizen <janneke@gnu.org>
5 Han-Wen Nienhuys <hanwen@xs4all.nl>
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.
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.
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/>.
25 #include <cstring> /* memset */
28 #include "dimensions.hh"
29 #include "file-name.hh"
30 #include "file-path.hh"
31 #include "international.hh"
32 #include "libc-extension.hh"
33 #include "lily-guile.hh"
36 #include "program-option.hh"
37 #include "relocate.hh"
38 #include "string-convert.hh"
42 LY_DEFINE (ly_start_environment
, "ly:start-environment",
44 "Return the environment (a list of strings) that was in"
45 " effect at program start.")
50 for (vsize i
= 0; i
< start_environment_global
.size (); i
++)
52 *tail
= scm_cons (ly_string2scm (start_environment_global
[i
]),
54 tail
= SCM_CDRLOC(*tail
);
61 LY_DEFINE (ly_find_file
, "ly:find-file",
63 "Return the absolute file name of @var{name},"
64 " or @code{#f} if not found.")
66 LY_ASSERT_TYPE (scm_is_string
, name
, 1);
68 string nm
= ly_scm2string (name
);
69 string file_name
= global_path
.find (nm
);
70 if (file_name
.empty ())
73 return ly_string2scm (file_name
);
77 Ugh. Gulped file is copied twice. (maybe thrice if you count stdio
80 LY_DEFINE (ly_gulp_file
, "ly:gulp-file",
81 1, 1, 0, (SCM name
, SCM size
),
82 "Read the file @var{name}, and return its contents in a string."
83 " The file is looked up using the search path.")
85 LY_ASSERT_TYPE (scm_is_string
, name
, 1);
87 if (size
!= SCM_UNDEFINED
)
89 LY_ASSERT_TYPE (scm_is_number
, size
, 2);
90 sz
= scm_to_int (size
);
93 string contents
= gulp_file_to_string (ly_scm2string (name
), true, sz
);
94 return scm_from_locale_stringn (contents
.c_str (), contents
.length ());
97 LY_DEFINE (ly_error
, "ly:error",
98 1, 0, 1, (SCM str
, SCM rest
),
99 "A Scheme callable function to issue the error @var{str}."
100 " The error is formatted with @code{format} and @var{rest}.")
102 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
103 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
104 error (ly_scm2string (str
));
105 return SCM_UNSPECIFIED
;
108 LY_DEFINE (ly_message
, "ly:message",
109 1, 0, 1, (SCM str
, SCM rest
),
110 "A Scheme callable function to issue the message @var{str}."
111 " The message is formatted with @code{format} and @var{rest}.")
113 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
114 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
115 message (ly_scm2string (str
));
116 return SCM_UNSPECIFIED
;
119 LY_DEFINE (ly_progress
, "ly:progress",
120 1, 0, 1, (SCM str
, SCM rest
),
121 "A Scheme callable function to print progress @var{str}."
122 " The message is formatted with @code{format} and @var{rest}.")
124 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
125 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
126 progress_indication (ly_scm2string (str
));
127 return SCM_UNSPECIFIED
;
130 LY_DEFINE (ly_programming_error
, "ly:programming-error",
131 1, 0, 1, (SCM str
, SCM rest
),
132 "A Scheme callable function to issue the internal warning"
133 " @var{str}. The message is formatted with @code{format}"
136 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
137 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
139 if (get_program_option ("warning-as-error"))
140 error (ly_scm2string (str
));
142 programming_error (ly_scm2string (str
));
144 return SCM_UNSPECIFIED
;
147 LY_DEFINE (ly_success
, "ly:success",
148 1, 0, 1, (SCM str
, SCM rest
),
149 "A Scheme callable function to issue a success message @var{str}."
150 " The message is formatted with @code{format} and @var{rest}.")
152 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
153 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
154 successful (ly_scm2string (str
));
155 return SCM_UNSPECIFIED
;
158 LY_DEFINE (ly_warning
, "ly:warning",
159 1, 0, 1, (SCM str
, SCM rest
),
160 "A Scheme callable function to issue the warning @var{str}."
161 " The message is formatted with @code{format} and @var{rest}.")
163 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
164 str
= scm_simple_format (SCM_BOOL_F
, str
, rest
);
166 if (get_program_option ("warning-as-error"))
167 error (ly_scm2string (str
));
169 warning (ly_scm2string (str
));
171 return SCM_UNSPECIFIED
;
174 LY_DEFINE (ly_dir_p
, "ly:dir?",
176 "Is @var{s} a direction? Valid directions are @code{-1},"
177 " @code{0}, or@tie{}@code{1}, where @code{-1} represents"
178 " left or down, @code{1}@tie{}represents right or up, and @code{0}"
179 " represents a neutral direction.")
181 if (scm_is_number (s
))
183 int i
= scm_to_int (s
);
184 return (i
>= -1 && i
<= 1) ? SCM_BOOL_T
: SCM_BOOL_F
;
189 LY_DEFINE (ly_assoc_get
, "ly:assoc-get",
191 (SCM key
, SCM alist
, SCM default_value
, SCM strict_checking
),
192 "Return value if @var{key} in @var{alist}, else @var{default-value}"
193 " (or @code{#f} if not specified). If @var{strict-checking} is set"
194 " to @code{#t} and @var{key} is not in @var{alist}, a programming_error"
197 LY_ASSERT_TYPE(ly_cheap_is_list
, alist
, 2);
199 SCM handle
= scm_assoc (key
, alist
);
200 if (scm_is_pair (handle
))
201 return scm_cdr (handle
);
203 if (default_value
== SCM_UNDEFINED
)
204 default_value
= SCM_BOOL_F
;
206 if (strict_checking
== SCM_BOOL_T
)
208 string key_string
= ly_scm2string
209 (scm_object_to_string (key
, SCM_UNDEFINED
));
210 string default_value_string
= ly_scm2string
211 (scm_object_to_string (default_value
,
213 programming_error ("Cannot find key `" +
215 "' in alist, setting to `" +
216 default_value_string
+ "'.");
219 return default_value
;
222 LY_DEFINE (ly_string_substitute
, "ly:string-substitute",
223 3, 0, 0, (SCM a
, SCM b
, SCM s
),
224 "Replace string@tie{}@var{a} by string@tie{}@var{b} in"
225 " string@tie{}@var{s}.")
227 LY_ASSERT_TYPE (scm_is_string
, s
, 1);
228 LY_ASSERT_TYPE (scm_is_string
, b
, 2);
229 LY_ASSERT_TYPE (scm_is_string
, s
, 3);
231 string ss
= ly_scm2string (s
);
232 replace_all (&ss
, ly_scm2string (a
),
235 return ly_string2scm (ss
);
239 is_not_escape_character (Byte c
)
257 LY_DEFINE (ly_string_percent_encode
, "ly:string-percent-encode",
259 "Encode all characters in string @var{str} with hexadecimal"
260 " percent escape sequences, with the following exceptions:"
261 " characters @code{-}, @code{.}, @code{/}, and @code{_}; and"
262 " characters in ranges @code{0-9}, @code{A-Z}, and @code{a-z}.")
264 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
266 string orig_str
= ly_scm2string (str
);
270 vsize n
= orig_str
.size ();
274 Byte cur
= orig_str
[i
];
276 if (is_not_escape_character (cur
))
281 new_str
+= String_convert::bin2hex (cur
);
287 return ly_string2scm (new_str
);
290 LY_DEFINE (ly_number_2_string
, "ly:number->string",
292 "Convert @var{num} to a string without generating many decimals.")
294 LY_ASSERT_TYPE (scm_is_number
, s
, 1);
296 char str
[400]; // ugh.
298 if (scm_exact_p (s
) == SCM_BOOL_F
)
300 Real
r (scm_to_double (s
));
301 if (isinf (r
) || isnan (r
))
303 programming_error (_ ("infinity or NaN encountered while converting Real number"));
304 programming_error (_ ("setting to zero"));
309 snprintf (str
, sizeof (str
), "%.4f", r
);
312 snprintf (str
, sizeof (str
), "%d", int (scm_to_int (s
)));
314 return scm_from_locale_string (str
);
317 LY_DEFINE (ly_version
, "ly:version", 0, 0, 0, (),
318 "Return the current lilypond version as a list, e.g.,"
319 " @code{(1 3 127 uu1)}.")
321 char const *vs
= "\'(" MAJOR_VERSION
" " MINOR_VERSION
" " PATCH_LEVEL
" " MY_PATCH_LEVEL
")";
323 return scm_c_eval_string ((char *)vs
);
326 LY_DEFINE (ly_unit
, "ly:unit", 0, 0, 0, (),
327 "Return the unit used for lengths as a string.")
329 return scm_from_locale_string (INTERNAL_UNIT
);
332 LY_DEFINE (ly_dimension_p
, "ly:dimension?", 1, 0, 0, (SCM d
),
333 "Return @var{d} as a number. Used to distinguish length"
334 " variables from normal numbers.")
336 return scm_number_p (d
);
342 LY_DEFINE (ly_protects
, "ly:protects",
344 "Return hash of protected objects.")
349 LY_DEFINE (ly_gettext
, "ly:gettext",
350 1, 0, 0, (SCM original
),
351 "A Scheme wrapper function for @code{gettext}.")
353 LY_ASSERT_TYPE (scm_is_string
, original
, 1);
354 return ly_string2scm (_ (ly_scm2string (original
).c_str ()));
357 LY_DEFINE (ly_output_formats
, "ly:output-formats",
359 "Formats passed to @option{--format} as a list of strings,"
360 " used for the output.")
362 vector
<string
> output_formats
= string_split (output_format_global
, ',');
365 int output_formats_count
= output_formats
.size ();
366 for (int i
= 0; i
< output_formats_count
; i
++)
367 lst
= scm_cons (ly_string2scm (output_formats
[i
]), lst
);
372 LY_DEFINE (ly_wide_char_2_utf_8
, "ly:wide-char->utf-8",
374 "Encode the Unicode codepoint @var{wc}, an integer, as UTF-8.")
378 LY_ASSERT_TYPE (scm_is_integer
, wc
, 1);
379 unsigned wide_char
= (unsigned) scm_to_int (wc
);
382 if (wide_char
< 0x0080)
383 *p
++ = (char)wide_char
;
384 else if (wide_char
< 0x0800)
386 *p
++ = (char) (((wide_char
>> 6)) | 0xC0);
387 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
389 else if (wide_char
< 0x10000)
391 *p
++ = (char) (((wide_char
>> 12)) | 0xE0);
392 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
393 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
397 *p
++ = (char) (((wide_char
>> 18)) | 0xF0);
398 *p
++ = (char) (((wide_char
>> 12) & 0x3F) | 0x80);
399 *p
++ = (char) (((wide_char
>> 6) & 0x3F) | 0x80);
400 *p
++ = (char) (((wide_char
) & 0x3F) | 0x80);
404 return scm_from_locale_string (buf
);
407 LY_DEFINE (ly_effective_prefix
, "ly:effective-prefix",
409 "Return effective prefix.")
411 return ly_string2scm (lilypond_datadir
);
414 LY_DEFINE (ly_chain_assoc_get
, "ly:chain-assoc-get",
415 2, 2, 0, (SCM key
, SCM achain
, SCM default_value
, SCM strict_checking
),
416 "Return value for @var{key} from a list of alists @var{achain}."
417 " If no entry is found, return @var{default-value} or @code{#f} if"
418 " @var{default-value} is not specified. With @var{strict-checking}"
419 " set to @code{#t}, a programming_error is output in such cases.")
421 if (scm_is_pair (achain
))
423 SCM handle
= scm_assoc (key
, scm_car (achain
));
424 if (scm_is_pair (handle
))
425 return scm_cdr (handle
);
427 return ly_chain_assoc_get (key
, scm_cdr (achain
), default_value
);
430 if (strict_checking
== SCM_BOOL_T
)
432 string key_string
= ly_scm2string
433 (scm_object_to_string (key
, SCM_UNDEFINED
));
434 string default_value_string
= ly_scm2string
435 (scm_object_to_string (default_value
,
437 programming_error ("Cannot find key `" +
439 "' in achain, setting to `" +
440 default_value_string
+ "'.");
443 return default_value
== SCM_UNDEFINED
? SCM_BOOL_F
: default_value
;
447 LY_DEFINE (ly_stderr_redirect
, "ly:stderr-redirect",
448 1, 1, 0, (SCM file_name
, SCM mode
),
449 "Redirect stderr to @var{file-name}, opened with @var{mode}.")
451 LY_ASSERT_TYPE (scm_is_string
, file_name
, 1);
455 if (mode
!= SCM_UNDEFINED
&& scm_string_p (mode
))
456 m
= ly_scm2string (mode
);
457 /* dup2 and (fileno (current-error-port)) do not work with mingw'c
460 stderrfile
= freopen (ly_scm2string (file_name
).c_str (), m
.c_str (), stderr
);
461 return SCM_UNSPECIFIED
;
465 accumulate_symbol (void * /* closure */,
470 return scm_cons (key
, result
);
473 LY_DEFINE (ly_hash_table_keys
, "ly:hash-table-keys",
475 "Return a list of keys in @var{tab}.")
477 return scm_internal_hash_fold ((scm_t_hash_fold_fn
) &accumulate_symbol
,
481 LY_DEFINE (ly_camel_case_2_lisp_identifier
, "ly:camel-case->lisp-identifier",
482 1, 0, 0, (SCM name_sym
),
483 "Convert @code{FooBar_Bla} to @code{foo-bar-bla} style symbol.")
485 LY_ASSERT_TYPE (ly_is_symbol
, name_sym
, 1);
488 TODO: should use strings instead?
491 const string in
= ly_symbol2string (name_sym
);
492 string result
= camel_case_to_lisp_identifier (in
);
494 return ly_symbol2scm (result
.c_str ());
497 LY_DEFINE (ly_expand_environment
, "ly:expand-environment",
499 "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
501 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
503 return ly_string2scm (expand_environment_variables (ly_scm2string (str
)));
507 LY_DEFINE (ly_truncate_list_x
, "ly:truncate-list!",
508 2, 0, 0, (SCM lst
, SCM i
),
509 "Take at most the first @var{i} of list @var{lst}.")
511 LY_ASSERT_TYPE (scm_is_integer
, i
, 1);
513 int k
= scm_to_int (i
);
520 for (; scm_is_pair (s
) && k
--; s
= scm_cdr (s
))
524 scm_set_cdr_x (s
, SCM_EOL
);
530 format_single_argument (SCM arg
, int precision
, bool escape
= false)
532 if (scm_is_integer (arg
) && scm_exact_p (arg
) == SCM_BOOL_T
)
533 return (String_convert::int_string (scm_to_int (arg
)));
534 else if (scm_is_number (arg
))
536 Real val
= scm_to_double (arg
);
538 if (isnan (val
) || isinf (val
))
540 warning (_ ("Found infinity or nan in output. Substituting 0.0"));
542 if (strict_infinity_checking
)
546 return (String_convert::form_string ("%.*lf", precision
, val
));
548 else if (scm_is_string (arg
))
550 string s
= ly_scm2string (arg
);
553 // Escape backslashes and double quotes, wrap it in double quotes
554 replace_all (&s
, "\\", "\\\\");
555 replace_all (&s
, "\"", "\\\"");
556 // don't replace percents, since the png backend uses %d as escape sequence
557 // replace_all (&s, "%", "\\%");
558 replace_all (&s
, "$", "\\$");
563 else if (scm_is_symbol (arg
))
564 return (ly_symbol2string (arg
));
567 ly_progress (scm_from_locale_string ("Unsupported SCM value for format: ~a"),
575 LY_DEFINE (ly_format
, "ly:format",
576 1, 0, 1, (SCM str
, SCM rest
),
577 "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}."
578 " Basic support for @code{~s} is also provided.")
580 LY_ASSERT_TYPE (scm_is_string
, str
, 1);
582 string format
= ly_scm2string (str
);
583 vector
<string
> results
;
586 while (i
< format
.size ())
588 vsize tilde
= format
.find ('~', i
);
590 results
.push_back (format
.substr (i
, (tilde
-i
)));
597 char spec
= format
.at (tilde
++);
599 results
.push_back ("~");
602 if (!scm_is_pair (rest
))
604 programming_error (string (__FUNCTION__
)
605 + ": not enough arguments for format.");
606 return ly_string2scm ("");
609 SCM arg
= scm_car (rest
);
610 rest
= scm_cdr (rest
);
616 else if (isdigit (spec
))
618 precision
= spec
- '0';
619 spec
= format
.at (tilde
++);
622 if (spec
== 'a' || spec
== 'A' || spec
== 'f' || spec
== '$')
623 results
.push_back (format_single_argument (arg
, precision
));
624 else if (spec
== 's' || spec
== 'S')
625 results
.push_back (format_single_argument (arg
, precision
, true));
626 else if (spec
== 'l')
629 for (; scm_is_pair (s
); s
= scm_cdr (s
))
631 results
.push_back (format_single_argument (scm_car (s
), precision
));
632 if (scm_cdr (s
) != SCM_EOL
)
633 results
.push_back (" ");
637 results
.push_back (format_single_argument (s
, precision
));
645 if (scm_is_pair (rest
))
646 programming_error (string (__FUNCTION__
)
647 + ": too many arguments");
650 for (vsize i
= 0; i
< results
.size (); i
++)
651 len
+= results
[i
].size ();
653 char *result
= (char*) scm_malloc (len
+ 1);
655 for (vsize i
= 0; i
< results
.size (); i
++)
657 strncpy (ptr
, results
[i
].c_str (), results
[i
].size ());
658 ptr
+= results
[i
].size ();
662 return scm_take_locale_stringn (result
, len
);