libgeda/src/scheme_page.c

   1 /* gEDA - GPL Electronic Design Automation
   2  * libgeda - gEDA's library - Scheme API
   3  * Copyright (C) 2010 Peter Brett <peter@peter-b.co.uk>
   4  *
   5  * This program is free software; you can redistribute it and/or modify
   6  * it under the terms of the GNU General Public License as published by
   7  * the Free Software Foundation; either version 2 of the License, or
   8  * (at your option) any later version.
   9  *
  10  * This program is distributed in the hope that it will be useful,
  11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13  * GNU General Public License for more details.
  14  *
  15  * You should have received a copy of the GNU General Public License
  16  * along with this program; if not, write to the Free Software
  17  * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111 USA
  18  */
  19
  20 /*!
  21  * \file scheme_page.c
  22  * \brief Scheme API page manipulation procedures.
  23  */
  24
  25 #include <config.h>
  26
  27 #include "libgeda_priv.h"
  28 #include "libgedaguile_priv.h"
  29
  30 SCM_SYMBOL (edascm_string_format_sym , "string-format");
  31
  32 /*! \brief Get a of open pages.
  33  * \par Function Description
  34  * Retrieves a Scheme list of currently-opened pages.
  35  *
  36  * \note Scheme API: Implements the %active-pages procedure of the
  37  * (geda core page) module.
  38  *
  39  * \return a Scheme list of #PAGE smobs.
  40  */
  41 SCM_DEFINE (active_pages, "%active-pages", 0, 0, 0,
  42             (), "Retrieve a list of currently-opened pages")
  43 {
  44   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  45   SCM lst = SCM_EOL;
  46   SCM rlst;
  47   GList *page_list = geda_list_get_glist (toplevel->pages);
  48
  49   while (page_list != NULL) {
  50     lst = scm_cons (edascm_from_page (page_list->data), lst);
  51     page_list = g_list_next (page_list);
  52   }
  53
  54   rlst = scm_reverse (lst);
  55   scm_remember_upto_here_1 (lst);
  56   return rlst;
  57 }
  58
  59 /*! \brief Create a new page.
  60  * \par Function Description
  61  * Creates and initialises a new #PAGE structure associated with the
  62  * filename \a filename_s. Note that this does not check that a file
  63  * exists with that name, or attempt to load any data from it.
  64  *
  65  * \note Scheme API: Implements the %new-page procedure of the (geda
  66  * core page) module.
  67  *
  68  * \return a newly-created #PAGE smob.
  69  */
  70 SCM_DEFINE (new_page, "%new-page", 1, 0, 0,
  71             (SCM filename_s), "Create a new page")
  72 {
  73   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
  74   char *filename;
  75   PAGE *page;
  76
  77   /* Ensure that the argument is a string */
  78   SCM_ASSERT (scm_is_string (filename_s), filename_s,
  79               SCM_ARG1, s_new_page);
  80
  81   filename = scm_to_utf8_string (filename_s);
  82   page = s_page_new (toplevel, filename);
  83   g_free (filename);
  84
  85   return edascm_from_page (page);
  86 }
  87
  88 /*! \brief Close a page
  89  * \par Function Description
  90
  91  * Destroys the #PAGE structure \a page_s, freeing all of its
  92  * resources.  Attempting to use \a page_s after calling this function
  93  * will cause an error.
  94  *
  95  * \note Scheme API: Implements the %close-page procedure of the (geda
  96  * core page) module.
  97  *
  98  * \param page_s The page to close.
  99  * \return SCM_UNDEFINED.
 100  */
 101 SCM_DEFINE (close_page_x, "%close-page!", 1, 0, 0,
 102             (SCM page_s), "Close a page.")
 103 {
 104   /* Ensure that the argument is a page smob */
 105   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 106               SCM_ARG1, s_close_page_x);
 107
 108   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 109   PAGE *page = edascm_to_page (page_s);
 110
 111   s_page_delete (toplevel, page);
 112
 113   return SCM_UNDEFINED;
 114 }
 115
 116 /*! \brief Get the filename associated with a page.
 117  * \par Function Description
 118  * Retrieves the filename associated with the #PAGE smob \a page_s.
 119  *
 120  * \note Scheme API: Implements the %page-filename procedure of the
 121  * (geda core page) module.
 122  *
 123  * \return a Scheme string containing the page filename.
 124  */
 125 SCM_DEFINE (page_filename, "%page-filename", 1, 0, 0,
 126             (SCM page_s), "Get a page's associated filename")
 127 {
 128   PAGE *page;
 129
 130   /* Ensure that the argument is a page smob */
 131   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 132               SCM_ARG1, s_page_filename);
 133
 134
 135   page = edascm_to_page (page_s);
 136   if (page->is_untitled)
 137     return SCM_BOOL_F;
 138   return scm_from_utf8_string (page->page_filename);
 139 }
 140
 141 /*! \brief Change the filename associated with a page.
 142  * \par Function Description
 143  * Sets the filename associated with the #PAGE smob \a page_s.
 144  *
 145  * \note Scheme API: Implements the %set-page-filename! procedure of
 146  * the (geda core page) module.
 147  *
 148  * \param page_s page to set filename for.
 149  * \param filename_s new filename for \a page.
 150  * \return \a page.
 151  */
 152 SCM_DEFINE (set_page_filename_x, "%set-page-filename!", 2, 0, 0,
 153             (SCM page_s, SCM filename_s), "Set a page's associated filename")
 154 {
 155   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 156               SCM_ARG1, s_set_page_filename_x);
 157   SCM_ASSERT (scm_is_string (filename_s), filename_s,
 158               SCM_ARG2, s_set_page_filename_x);
 159
 160   PAGE *page = edascm_to_page (page_s);
 161   char *new_fn = scm_to_utf8_string (filename_s);
 162   if (page->page_filename != NULL) {
 163     g_free (page->page_filename);
 164   }
 165   page->page_filename = g_strdup (new_fn);
 166   page->is_untitled = FALSE;
 167   free (new_fn);
 168
 169   return page_s;
 170 }
 171
 172 /*! \brief Get a list of objects in a page.
 173  * \par Function Description
 174  * Retrieves the contents of a the #PAGE smob \a page_s as a Scheme
 175  * list of #OBJECT smobs.
 176  *
 177  * \note Scheme API: Implements the %page-contents procedure of the
 178  * (geda core page) module.
 179  *
 180  * \return a list of #OBJECT smobs.
 181  */
 182 SCM_DEFINE (page_contents, "%page-contents", 1, 0, 0,
 183             (SCM page_s), "Get a page's contents.")
 184 {
 185   PAGE *page;
 186
 187   /* Ensure that the argument is a page smob */
 188   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 189               SCM_ARG1, s_page_contents);
 190
 191   page = edascm_to_page (page_s);
 192
 193   return edascm_from_object_glist (s_page_objects (page));
 194 }
 195
 196 /*! \brief Get the page an object belongs to.
 197  * \par Function Description
 198  * Returns a smob for the #PAGE that \a obj_s belongs to.  If \a obj_s
 199  * does not belong to a #PAGE, returns SCM_BOOL_F.
 200  *
 201  * \note Scheme API: Implements the %object-page procedure in the
 202  * (geda core page) module.
 203  *
 204  * \param [in] obj_s an #OBJECT smob.
 205  * \return a #PAGE smob or SCM_BOOL_F.
 206  */
 207 SCM_DEFINE (object_page, "%object-page", 1, 0, 0,
 208             (SCM obj_s), "Get the page that an object smob belongs to")
 209 {
 210   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 211               SCM_ARG1, s_object_page);
 212
 213   PAGE *page = o_get_page (edascm_c_current_toplevel (),
 214                            edascm_to_object (obj_s));
 215
 216   if (page != NULL) {
 217     return edascm_from_page (page);
 218   } else {
 219     return SCM_BOOL_F;
 220   }
 221 }
 222
 223
 224 /*! \brief Add an object to a page.
 225  * \par Function Description
 226  * Adds \a obj_s to \a page_s.  If \a obj_s is already attached to a
 227  * #PAGE or to a complex #OBJECT, throws a Scheme error.
 228  *
 229  * \note Scheme API: Implements the %page-append! procedure of the
 230  * (geda core page) module.
 231  *
 232  * \return \a page_s.
 233  */
 234 SCM_DEFINE (page_append_x, "%page-append!", 2, 0, 0,
 235             (SCM page_s, SCM obj_s), "Add an object to a page.")
 236 {
 237   /* Ensure that the arguments have the correct types. */
 238   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 239               SCM_ARG1, s_page_append_x);
 240   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 241               SCM_ARG2, s_page_append_x);
 242
 243   PAGE *page = edascm_to_page (page_s);
 244   OBJECT *obj = edascm_to_object (obj_s);
 245   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 246
 247   /* Check that the object isn't already attached to something. */
 248   PAGE *curr_page = o_get_page (toplevel, obj);
 249   if (((curr_page != NULL) && (curr_page != page))
 250       || (obj->parent != NULL)) {
 251     scm_error (edascm_object_state_sym, s_page_append_x,
 252                _("Object ~A is already attached to something"),
 253                scm_list_1 (obj_s), SCM_EOL);
 254   }
 255
 256   if (curr_page == page) return obj_s;
 257
 258   /* Object cleanup now managed by C code. */
 259   edascm_c_set_gc (obj_s, 0);
 260   o_emit_pre_change_notify (toplevel, obj);
 261   s_page_append (edascm_c_current_toplevel (), page, obj);
 262   o_emit_change_notify (toplevel, obj);
 263   page->CHANGED = 1; /* Ugh. */
 264
 265   return page_s;
 266 }
 267
 268 /*! \brief Remove an object from a page.
 269  * \par Function Description
 270  * Removes \a obj_s from \a page_s.  If \a obj_s is attached to a
 271  * #PAGE other than \a page_s, or to a complex #OBJECT, throws a
 272  * Scheme error. If \a obj_s is not attached to a page, does nothing.
 273  *
 274  * \note Scheme API: Implements the %page-remove! procedure of the
 275  * (geda core page) module.
 276  *
 277  * \return \a page_s.
 278  */
 279 SCM_DEFINE (page_remove_x, "%page-remove!", 2, 0, 0,
 280             (SCM page_s, SCM obj_s), "Remove an object from a page.")
 281 {
 282   /* Ensure that the arguments have the correct types. */
 283   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 284               SCM_ARG1, s_page_remove_x);
 285   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 286               SCM_ARG2, s_page_remove_x);
 287
 288   PAGE *page = edascm_to_page (page_s);
 289   OBJECT *obj = edascm_to_object (obj_s);
 290   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 291
 292   /* Check that the object is not attached to something else. */
 293   PAGE *curr_page = o_get_page (toplevel, obj);
 294   if ((curr_page != NULL && curr_page != page)
 295       || (obj->parent != NULL)) {
 296     scm_error (edascm_object_state_sym, s_page_remove_x,
 297                _("Object ~A is attached to a complex or different page"),
 298                scm_list_1 (obj_s), SCM_EOL);
 299   }
 300
 301   /* Check that object is not attached as an attribute. */
 302   if (obj->attached_to != NULL) {
 303     scm_error (edascm_object_state_sym, s_page_remove_x,
 304                _("Object ~A is attached as an attribute"),
 305                scm_list_1 (obj_s), SCM_EOL);
 306   }
 307
 308   /* Check that object doesn't have attributes. */
 309   if (obj->attribs != NULL) {
 310     scm_error (edascm_object_state_sym, s_page_remove_x,
 311                _("Object ~A has attributes"),
 312                scm_list_1 (obj_s), SCM_EOL);
 313   }
 314
 315   if (curr_page == NULL) return obj_s;
 316
 317   o_emit_pre_change_notify (toplevel, obj);
 318   s_page_remove (toplevel, page, obj);
 319   page->CHANGED = 1; /* Ugh. */
 320   /* If the object is currently selected, unselect it. */
 321   o_selection_remove (toplevel, page->selection_list, obj);
 322   o_emit_change_notify (toplevel, obj);
 323
 324   /* Object cleanup now managed by Guile. */
 325   edascm_c_set_gc (obj_s, 1);
 326   return page_s;
 327 }
 328
 329 /*! \brief Check whether a page has been flagged as changed.
 330  * \par Function Description
 331  * Returns SCM_BOOL_T if \a page_s has been flagged as having been
 332  * modified.
 333  *
 334  * \note Scheme API: Implements the %page-dirty? procedure of the
 335  * (geda core page) module.
 336  *
 337  * \param page_s page to inspect.
 338  * \return SCM_BOOL_T if page is dirtied, otherwise SCM_BOOL_F.
 339  */
 340 SCM_DEFINE (page_dirty, "%page-dirty?", 1, 0, 0,
 341             (SCM page_s), "Check whether a page has been flagged as changed.")
 342 {
 343   /* Ensure that the argument is a page smob */
 344   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 345               SCM_ARG1, s_page_dirty);
 346
 347   PAGE *page = edascm_to_page (page_s);
 348   return page->CHANGED ? SCM_BOOL_T : SCM_BOOL_F;
 349 }
 350
 351 /*! \brief Set a page's changed flag.
 352  * \par Function Description
 353  * If \a flag_s is true, flag \a page_s as having been modified.
 354  * Otherwise, clears the change flag.
 355  *
 356  * \note Scheme API: Implements the %set-page-dirty! procedure of the
 357  * (geda core page) module.
 358  *
 359  * \param page_s page to modify.
 360  * \param flag_s new flag setting.
 361  * \return \a page_s
 362  */
 363 SCM_DEFINE (set_page_dirty_x, "%set-page-dirty!", 2, 0, 0,
 364             (SCM page_s, SCM flag_s),
 365             "Set whether a page is flagged as changed.")
 366 {
 367   /* Ensure that the argument is a page smob */
 368   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 369               SCM_ARG1, s_set_page_dirty_x);
 370
 371   PAGE *page = edascm_to_page (page_s);
 372   page->CHANGED = scm_is_true (flag_s);
 373   return page_s;
 374 }
 375
 376 /*! \brief Create a string representation of a page.
 377  * \par Function Description
 378  * Returns a string representation of the contents of \a page_s.
 379  *
 380  * \note Scheme API: Implements the %page->string procedure of the
 381  * (geda core page) module.
 382  *
 383  * \param page_s page to convert to a string.
 384  * \return a string representation of \a page_s.
 385  */
 386 SCM_DEFINE (page_to_string, "%page->string", 1, 0, 0,
 387             (SCM page_s),
 388             "Create a string representation of a page.")
 389 {
 390   /* Ensure that the argument is a page smob */
 391   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 392               SCM_ARG1, s_page_to_string);
 393
 394   PAGE *page = edascm_to_page (page_s);
 395
 396   gchar *buf = o_save_buffer (s_page_objects (page));
 397   scm_dynwind_begin (0);
 398   scm_dynwind_unwind_handler (g_free, buf, SCM_F_WIND_EXPLICITLY);
 399   SCM result = scm_from_utf8_string (buf);
 400   scm_dynwind_end ();
 401   return result;
 402 }
 403
 404 /*! \brief Create a page from a string representation.
 405  * \par Function Description
 406  * Returns a page with filename \a filename_s created by parsing \a
 407  * str_s. Throws an error if \a str_s contains invalid gEDA file
 408  * format syntax.
 409  *
 410  * \note Scheme API: Implements the %string->page procedure of the
 411  * (geda core page) module.
 412  *
 413  * \param filename_s Filename for new page.
 414  * \param str_s      String to parse to create page.
 415  * \return a new page created by parsing \a str_s.
 416  */
 417 SCM_DEFINE (string_to_page, "%string->page", 2, 0, 0,
 418             (SCM filename_s, SCM str_s),
 419             "Create a new page from a string.")
 420 {
 421   /* Ensure that the arguments are strings */
 422   SCM_ASSERT (scm_is_string (filename_s), filename_s,
 423               SCM_ARG1, s_string_to_page);
 424   SCM_ASSERT (scm_is_string (str_s), str_s,
 425               SCM_ARG2, s_string_to_page);
 426
 427   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 428   char *filename = scm_to_utf8_string (filename_s);
 429   PAGE *page = s_page_new (toplevel, filename);
 430   free (filename);
 431
 432   size_t len;
 433   GError * err = NULL;
 434   char *str = scm_to_utf8_stringn (str_s, &len);
 435   GList *objects = o_read_buffer (toplevel, NULL, str, len,
 436                                   page->page_filename, &err);
 437   free (str);
 438
 439   if (err) {
 440       SCM error_message = scm_from_utf8_string (err->message);
 441
 442       g_error_free(err);
 443       scm_error (edascm_string_format_sym, s_string_to_page,
 444                  _("Parse error: ~s"), scm_list_1 (error_message), SCM_EOL);
 445   }
 446
 447   s_page_append_list (toplevel, page, objects);
 448
 449   return edascm_from_page (page);
 450 }
 451
 452 /*!
 453  * \brief Create the (geda core page) Scheme module.
 454  * \par Function Description
 455  * Defines procedures in the (geda core page) module. The module can
 456  * be accessed using (use-modules (geda core page)).
 457  */
 458 static void
 459 init_module_geda_core_page ()
 460 {
 461   /* Register the functions */
 462   #include "scheme_page.x"
 463
 464   /* Add them to the module's public definitions. */
 465
 466   scm_c_export (s_active_pages, s_new_page, s_close_page_x,
 467                 s_page_filename, s_set_page_filename_x, s_page_contents,
 468                 s_object_page, s_page_append_x, s_page_remove_x, s_page_dirty,
 469                 s_set_page_dirty_x, s_page_to_string, s_string_to_page, NULL);
 470 }
 471
 472 /*!
 473  * \brief Initialise the basic gEDA page manipulation procedures.
 474  * \par Function Description
 475  * Registers some Scheme procedures for working with #PAGE
 476  * smobs. Should only be called by edascm_init().
 477  */
 478 void
 479 edascm_init_page ()
 480 {
 481   /* Define the (geda core page) module */
 482   scm_c_define_module ("geda core page",
 483                        init_module_geda_core_page,
 484                        NULL);
 485 }