+
+LY_DEFINE (ly_expand_environment, "ly:expand-environment",
+ 1, 0, 0, (SCM str),
+ "Expand @code{$VAR} and @code{$@{VAR@}} in @var{str}.")
+{
+ LY_ASSERT_TYPE (scm_is_string, str, 1);
+
+ return ly_string2scm (expand_environment_variables (ly_scm2string (str)));
+}
+
+
+LY_DEFINE (ly_truncate_list_x, "ly:truncate-list!",
+ 2, 0, 0, (SCM lst, SCM i),
+ "Take at most the first @var{i} of list @var{lst}.")
+{
+ LY_ASSERT_TYPE (scm_is_integer, i, 1);
+
+ int k = scm_to_int (i);
+ if (k == 0)
+ lst = SCM_EOL;
+ else
+ {
+ SCM s = lst;
+ k--;
+ for (; scm_is_pair (s) && k--; s = scm_cdr (s))
+ ;
+
+ if (scm_is_pair (s))
+ scm_set_cdr_x (s, SCM_EOL);
+ }
+ return lst;
+}
+
+string
+format_single_argument (SCM arg, int precision, bool escape = false)
+{
+ if (scm_is_integer (arg) && scm_exact_p (arg) == SCM_BOOL_T)
+ return (String_convert::int_string (scm_to_int (arg)));
+ else if (scm_is_number (arg))
+ {
+ Real val = scm_to_double (arg);
+
+ if (isnan (val) || isinf (val))
+ {
+ warning (_ ("Found infinity or nan in output. Substituting 0.0"));
+ return ("0.0");
+ if (strict_infinity_checking)
+ abort ();
+ }
+ else
+ return (String_convert::form_string ("%.*lf", precision, val));
+ }
+ else if (scm_is_string (arg))
+ {
+ string s = ly_scm2string (arg);
+ if (escape)
+ {
+ // Escape backslashes and double quotes, wrap it in double quotes
+ replace_all (&s, "\\", "\\\\");
+ replace_all (&s, "\"", "\\\"");
+ // don't replace percents, since the png backend uses %d as escape sequence
+ // replace_all (&s, "%", "\\%");
+ replace_all (&s, "$", "\\$");
+ s = "\"" + s + "\"";
+ }
+ return s;
+ }
+ else if (scm_is_symbol (arg))
+ return (ly_symbol2string (arg));
+ else
+ {
+ ly_progress (scm_from_locale_string ("\nUnsupported SCM value for format: ~a"),
+ scm_list_1 (arg));
+ }
+
+
+ return "";
+}
+
+LY_DEFINE (ly_format, "ly:format",
+ 1, 0, 1, (SCM str, SCM rest),
+ "LilyPond specific format, supporting @code{~a} and @code{~[0-9]f}."
+ " Basic support for @code{~s} is also provided.")
+{
+ LY_ASSERT_TYPE (scm_is_string, str, 1);
+
+ string format = ly_scm2string (str);
+ vector<string> results;
+
+ vsize i = 0;
+ while (i < format.size ())
+ {
+ vsize tilde = format.find ('~', i);
+
+ results.push_back (format.substr (i, (tilde-i)));
+
+ if (tilde == NPOS)
+ break ;
+
+ tilde ++;
+
+ char spec = format.at (tilde ++);
+ if (spec == '~')
+ results.push_back ("~");
+ else
+ {
+ if (!scm_is_pair (rest))
+ {
+ programming_error (string (__FUNCTION__)
+ + ": not enough arguments for format.");
+ return ly_string2scm ("");
+ }
+
+ SCM arg = scm_car (rest);
+ rest = scm_cdr (rest);
+
+ int precision = 8;
+
+ if (spec == '$')
+ precision = 2;
+ else if (isdigit (spec))
+ {
+ precision = spec - '0';
+ spec = format.at (tilde ++);
+ }
+
+ if (spec == 'a' || spec == 'A' || spec == 'f' || spec == '$')
+ results.push_back (format_single_argument (arg, precision));
+ else if (spec == 's' || spec == 'S')
+ results.push_back (format_single_argument (arg, precision, true));
+ else if (spec == 'l')
+ {
+ SCM s = arg;
+ for (; scm_is_pair (s); s = scm_cdr (s))
+ {
+ results.push_back (format_single_argument (scm_car (s), precision));
+ if (scm_cdr (s) != SCM_EOL)
+ results.push_back (" ");
+ }
+
+ if (s != SCM_EOL)
+ results.push_back (format_single_argument (s, precision));
+
+ }
+ }
+
+ i = tilde;
+ }
+
+ if (scm_is_pair (rest))
+ programming_error (string (__FUNCTION__)
+ + ": too many arguments");
+
+ vsize len = 0;
+ for (vsize i = 0; i < results.size (); i++)
+ len += results[i].size ();
+
+ char *result = (char*) scm_malloc (len + 1);
+ char *ptr = result;
+ for (vsize i = 0; i < results.size (); i++)
+ {
+ strncpy (ptr, results[i].c_str (), results[i].size ());
+ ptr += results[i].size ();
+ }
+ *ptr = '\0';
+
+ return scm_take_locale_stringn (result, len);
+}
+
+int
+ly_run_command (char *argv[], char **standard_output, char **standard_error)
+{
+ GError *error = 0;
+ int exit_status = 0;
+ int flags = G_SPAWN_SEARCH_PATH;
+ if (!standard_output)
+ flags |= G_SPAWN_STDOUT_TO_DEV_NULL;
+ if (!standard_error)
+ flags |= G_SPAWN_STDERR_TO_DEV_NULL;
+ if (!g_spawn_sync (0, argv, 0, GSpawnFlags (flags),
+ 0, 0,
+ standard_output, standard_error,
+ &exit_status, &error))
+ {
+ fprintf (stderr, "failed (%d): %s: %s\n", exit_status, argv[0], error->message);
+ g_error_free (error);
+ if (!exit_status)
+ exit_status = -1;
+ }
+
+ return exit_status;
+}
+
+static char *
+ly_scm2utf8 (SCM str)
+{
+ char *p = ly_scm2str0 (str);
+ char *g = g_locale_to_utf8 (p, -1, 0, 0, 0);
+ free (p);
+ return g;
+}
+
+LY_DEFINE (ly_spawn, "ly:spawn",
+ 1, 0, 1, (SCM command, SCM rest),
+ "Simple interface to g_spawn_sync"
+ " @var{str}."
+ " The error is formatted with @code{format} and @var{rest}.")
+
+{
+ LY_ASSERT_TYPE (scm_is_string, command, 1);
+
+ int argc = scm_is_pair (rest) ? scm_ilength (rest) : 0;
+ char **argv = new char*[argc + 2];
+
+ int n = 0;
+ argv[n++] = ly_scm2utf8 (command);
+ for (SCM s = rest; scm_is_pair (s); s = scm_cdr (s))
+ argv[n++] = ly_scm2utf8 (scm_car (s));
+ argv[n] = 0;
+
+ char *standard_output = 0;
+ char *standard_error = 0;
+ int exit_status = be_verbose_global
+ ? ly_run_command (argv, &standard_output, &standard_error)
+ : ly_run_command (argv, 0, 0);
+
+ if (be_verbose_global)
+ {
+ fprintf (stderr, "\n%s", standard_output);
+ fprintf (stderr, "%s", standard_error);
+ }
+
+ for (int i = 0; i < n; i++)
+ free (argv[i]);
+ delete[] argv;
+
+ return scm_from_int (exit_status);
+}