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   return scm_from_utf8_string (page->page_filename);
 137 }
 138
 139 /*! \brief Change the filename associated with a page.
 140  * \par Function Description
 141  * Sets the filename associated with the #PAGE smob \a page_s.
 142  *
 143  * \note Scheme API: Implements the %set-page-filename! procedure of
 144  * the (geda core page) module.
 145  *
 146  * \param page_s page to set filename for.
 147  * \param filename_s new filename for \a page.
 148  * \return \a page.
 149  */
 150 SCM_DEFINE (set_page_filename_x, "%set-page-filename!", 2, 0, 0,
 151             (SCM page_s, SCM filename_s), "Set a page's associated filename")
 152 {
 153   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 154               SCM_ARG1, s_set_page_filename_x);
 155   SCM_ASSERT (scm_is_string (filename_s), filename_s,
 156               SCM_ARG2, s_set_page_filename_x);
 157
 158   PAGE *page = edascm_to_page (page_s);
 159   char *new_fn = scm_to_utf8_string (filename_s);
 160   if (page->page_filename != NULL) {
 161     g_free (page->page_filename);
 162   }
 163   page->page_filename = g_strdup (new_fn);
 164   free (new_fn);
 165
 166   return page_s;
 167 }
 168
 169 /*! \brief Get a list of objects in a page.
 170  * \par Function Description
 171  * Retrieves the contents of a the #PAGE smob \a page_s as a Scheme
 172  * list of #OBJECT smobs.
 173  *
 174  * \note Scheme API: Implements the %page-contents procedure of the
 175  * (geda core page) module.
 176  *
 177  * \return a list of #OBJECT smobs.
 178  */
 179 SCM_DEFINE (page_contents, "%page-contents", 1, 0, 0,
 180             (SCM page_s), "Get a page's contents.")
 181 {
 182   PAGE *page;
 183
 184   /* Ensure that the argument is a page smob */
 185   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 186               SCM_ARG1, s_page_contents);
 187
 188   page = edascm_to_page (page_s);
 189
 190   return edascm_from_object_glist (s_page_objects (page));
 191 }
 192
 193 /*! \brief Get the page an object belongs to.
 194  * \par Function Description
 195  * Returns a smob for the #PAGE that \a obj_s belongs to.  If \a obj_s
 196  * does not belong to a #PAGE, returns SCM_BOOL_F.
 197  *
 198  * \note Scheme API: Implements the %object-page procedure in the
 199  * (geda core page) module.
 200  *
 201  * \param [in] obj_s an #OBJECT smob.
 202  * \return a #PAGE smob or SCM_BOOL_F.
 203  */
 204 SCM_DEFINE (object_page, "%object-page", 1, 0, 0,
 205             (SCM obj_s), "Get the page that an object smob belongs to")
 206 {
 207   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 208               SCM_ARG1, s_object_page);
 209
 210   PAGE *page = o_get_page (edascm_c_current_toplevel (),
 211                            edascm_to_object (obj_s));
 212
 213   if (page != NULL) {
 214     return edascm_from_page (page);
 215   } else {
 216     return SCM_BOOL_F;
 217   }
 218 }
 219
 220
 221 /*! \brief Add an object to a page.
 222  * \par Function Description
 223  * Adds \a obj_s to \a page_s.  If \a obj_s is already attached to a
 224  * #PAGE or to a complex #OBJECT, throws a Scheme error.
 225  *
 226  * \note Scheme API: Implements the %page-append! procedure of the
 227  * (geda core page) module.
 228  *
 229  * \return \a page_s.
 230  */
 231 SCM_DEFINE (page_append_x, "%page-append!", 2, 0, 0,
 232             (SCM page_s, SCM obj_s), "Add an object to a page.")
 233 {
 234   /* Ensure that the arguments have the correct types. */
 235   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 236               SCM_ARG1, s_page_append_x);
 237   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 238               SCM_ARG2, s_page_append_x);
 239
 240   PAGE *page = edascm_to_page (page_s);
 241   OBJECT *obj = edascm_to_object (obj_s);
 242   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 243
 244   /* Check that the object isn't already attached to something. */
 245   PAGE *curr_page = o_get_page (toplevel, obj);
 246   if (((curr_page != NULL) && (curr_page != page))
 247       || (obj->parent != NULL)) {
 248     scm_error (edascm_object_state_sym, s_page_append_x,
 249                _("Object ~A is already attached to something"),
 250                scm_list_1 (obj_s), SCM_EOL);
 251   }
 252
 253   if (curr_page == page) return obj_s;
 254
 255   /* Object cleanup now managed by C code. */
 256   edascm_c_set_gc (obj_s, 0);
 257   o_emit_pre_change_notify (toplevel, obj);
 258   s_page_append (edascm_c_current_toplevel (), page, obj);
 259   o_emit_change_notify (toplevel, obj);
 260   page->CHANGED = 1; /* Ugh. */
 261
 262   return page_s;
 263 }
 264
 265 /*! \brief Remove an object from a page.
 266  * \par Function Description
 267  * Removes \a obj_s from \a page_s.  If \a obj_s is attached to a
 268  * #PAGE other than \a page_s, or to a complex #OBJECT, throws a
 269  * Scheme error. If \a obj_s is not attached to a page, does nothing.
 270  *
 271  * \note Scheme API: Implements the %page-remove! procedure of the
 272  * (geda core page) module.
 273  *
 274  * \return \a page_s.
 275  */
 276 SCM_DEFINE (page_remove_x, "%page-remove!", 2, 0, 0,
 277             (SCM page_s, SCM obj_s), "Remove an object from a page.")
 278 {
 279   /* Ensure that the arguments have the correct types. */
 280   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 281               SCM_ARG1, s_page_remove_x);
 282   SCM_ASSERT (EDASCM_OBJECTP (obj_s), obj_s,
 283               SCM_ARG2, s_page_remove_x);
 284
 285   PAGE *page = edascm_to_page (page_s);
 286   OBJECT *obj = edascm_to_object (obj_s);
 287   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 288
 289   /* Check that the object is not attached to something else. */
 290   PAGE *curr_page = o_get_page (toplevel, obj);
 291   if ((curr_page != NULL && curr_page != page)
 292       || (obj->parent != NULL)) {
 293     scm_error (edascm_object_state_sym, s_page_remove_x,
 294                _("Object ~A is attached to a complex or different page"),
 295                scm_list_1 (obj_s), SCM_EOL);
 296   }
 297
 298   /* Check that object is not attached as an attribute. */
 299   if (obj->attached_to != NULL) {
 300     scm_error (edascm_object_state_sym, s_page_remove_x,
 301                _("Object ~A is attached as an attribute"),
 302                scm_list_1 (obj_s), SCM_EOL);
 303   }
 304
 305   /* Check that object doesn't have attributes. */
 306   if (obj->attribs != NULL) {
 307     scm_error (edascm_object_state_sym, s_page_remove_x,
 308                _("Object ~A has attributes"),
 309                scm_list_1 (obj_s), SCM_EOL);
 310   }
 311
 312   if (curr_page == NULL) return obj_s;
 313
 314   o_emit_pre_change_notify (toplevel, obj);
 315   s_page_remove (toplevel, page, obj);
 316   page->CHANGED = 1; /* Ugh. */
 317   /* If the object is currently selected, unselect it. */
 318   o_selection_remove (toplevel, page->selection_list, obj);
 319   o_emit_change_notify (toplevel, obj);
 320
 321   /* Object cleanup now managed by Guile. */
 322   edascm_c_set_gc (obj_s, 1);
 323   return page_s;
 324 }
 325
 326 /*! \brief Check whether a page has been flagged as changed.
 327  * \par Function Description
 328  * Returns SCM_BOOL_T if \a page_s has been flagged as having been
 329  * modified.
 330  *
 331  * \note Scheme API: Implements the %page-dirty? procedure of the
 332  * (geda core page) module.
 333  *
 334  * \param page_s page to inspect.
 335  * \return SCM_BOOL_T if page is dirtied, otherwise SCM_BOOL_F.
 336  */
 337 SCM_DEFINE (page_dirty, "%page-dirty?", 1, 0, 0,
 338             (SCM page_s), "Check whether a page has been flagged as changed.")
 339 {
 340   /* Ensure that the argument is a page smob */
 341   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 342               SCM_ARG1, s_page_dirty);
 343
 344   PAGE *page = edascm_to_page (page_s);
 345   return page->CHANGED ? SCM_BOOL_T : SCM_BOOL_F;
 346 }
 347
 348 /*! \brief Set a page's changed flag.
 349  * \par Function Description
 350  * If \a flag_s is true, flag \a page_s as having been modified.
 351  * Otherwise, clears the change flag.
 352  *
 353  * \note Scheme API: Implements the %set-page-dirty! procedure of the
 354  * (geda core page) module.
 355  *
 356  * \param page_s page to modify.
 357  * \param flag_s new flag setting.
 358  * \return \a page_s
 359  */
 360 SCM_DEFINE (set_page_dirty_x, "%set-page-dirty!", 2, 0, 0,
 361             (SCM page_s, SCM flag_s),
 362             "Set whether a page is flagged as changed.")
 363 {
 364   /* Ensure that the argument is a page smob */
 365   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 366               SCM_ARG1, s_set_page_dirty_x);
 367
 368   PAGE *page = edascm_to_page (page_s);
 369   page->CHANGED = scm_is_true (flag_s);
 370   return page_s;
 371 }
 372
 373 /*! \brief Create a string representation of a page.
 374  * \par Function Description
 375  * Returns a string representation of the contents of \a page_s.
 376  *
 377  * \note Scheme API: Implements the %page->string procedure of the
 378  * (geda core page) module.
 379  *
 380  * \param page_s page to convert to a string.
 381  * \return a string representation of \a page_s.
 382  */
 383 SCM_DEFINE (page_to_string, "%page->string", 1, 0, 0,
 384             (SCM page_s),
 385             "Create a string representation of a page.")
 386 {
 387   /* Ensure that the argument is a page smob */
 388   SCM_ASSERT (EDASCM_PAGEP (page_s), page_s,
 389               SCM_ARG1, s_page_to_string);
 390
 391   PAGE *page = edascm_to_page (page_s);
 392   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 393
 394   gchar *buf = o_save_buffer (toplevel, s_page_objects (page));
 395   scm_dynwind_begin (0);
 396   scm_dynwind_unwind_handler (g_free, buf, SCM_F_WIND_EXPLICITLY);
 397   SCM result = scm_from_utf8_string (buf);
 398   scm_dynwind_end ();
 399   return result;
 400 }
 401
 402 /*! \brief Create a page from a string representation.
 403  * \par Function Description
 404  * Returns a page with filename \a filename_s created by parsing \a
 405  * str_s. Throws an error if \a str_s contains invalid gEDA file
 406  * format syntax.
 407  *
 408  * \note Scheme API: Implements the %string->page procedure of the
 409  * (geda core page) module.
 410  *
 411  * \param filename_s Filename for new page.
 412  * \param str_s      String to parse to create page.
 413  * \return a new page created by parsing \a str_s.
 414  */
 415 SCM_DEFINE (string_to_page, "%string->page", 2, 0, 0,
 416             (SCM filename_s, SCM str_s),
 417             "Create a new page from a string.")
 418 {
 419   /* Ensure that the arguments are strings */
 420   SCM_ASSERT (scm_is_string (filename_s), filename_s,
 421               SCM_ARG1, s_string_to_page);
 422   SCM_ASSERT (scm_is_string (str_s), str_s,
 423               SCM_ARG2, s_string_to_page);
 424
 425   TOPLEVEL *toplevel = edascm_c_current_toplevel ();
 426   char *filename = scm_to_utf8_string (filename_s);
 427   PAGE *page = s_page_new (toplevel, filename);
 428   free (filename);
 429
 430   size_t len;
 431   GError * err = NULL;
 432   char *str = scm_to_utf8_stringn (str_s, &len);
 433   GList *objects = o_read_buffer (toplevel, NULL, str, len,
 434                                   page->page_filename, &err);
 435   free (str);
 436
 437   if (err) {
 438       SCM error_message = scm_from_utf8_string (err->message);
 439
 440       g_error_free(err);
 441       scm_error (edascm_string_format_sym, s_string_to_page,
 442                  _("Parse error: ~s"), scm_list_1 (error_message), SCM_EOL);
 443   }
 444
 445   s_page_append_list (toplevel, page, objects);
 446
 447   return edascm_from_page (page);
 448 }
 449
 450 /*!
 451  * \brief Create the (geda core page) Scheme module.
 452  * \par Function Description
 453  * Defines procedures in the (geda core page) module. The module can
 454  * be accessed using (use-modules (geda core page)).
 455  */
 456 static void
 457 init_module_geda_core_page ()
 458 {
 459   /* Register the functions */
 460   #include "scheme_page.x"
 461
 462   /* Add them to the module's public definitions. */
 463
 464   scm_c_export (s_active_pages, s_new_page, s_close_page_x,
 465                 s_page_filename, s_set_page_filename_x, s_page_contents,
 466                 s_object_page, s_page_append_x, s_page_remove_x, s_page_dirty,
 467                 s_set_page_dirty_x, s_page_to_string, s_string_to_page, NULL);
 468 }
 469
 470 /*!
 471  * \brief Initialise the basic gEDA page manipulation procedures.
 472  * \par Function Description
 473  * Registers some Scheme procedures for working with #PAGE
 474  * smobs. Should only be called by edascm_init().
 475  */
 476 void
 477 edascm_init_page ()
 478 {
 479   /* Define the (geda core page) module */
 480   scm_c_define_module ("geda core page",
 481                        init_module_geda_core_page,
 482                        NULL);
 483 }