Goo-Canvas-0.06/0000755000175000017500000000000011200440442011547 5ustar ywbywbGoo-Canvas-0.06/Changes0000644000175000017500000000104611200440417013045 0ustar ywbywbRevision history for Perl extension Goo::Canvas. 0.01 Wed Sep 26 16:24:09 2007 - original version; created by h2xs 1.23 with options -A -n Goo::Canvas 0.03 Sun Oct 7 22:35:33 2007 - Fix for demo/demo.pl create_stipples 0.04 Sun Oct 7 22:36:28 2007 - Bindings for goocanvas-0.9 0.05 Sun Nov 4 14:25:34 2007 - Fix get_bounds error - Add bin/perltetris.pl - Add bin/perlmine.pl 0.06 Wed, 06 May 2009 22:00:39 -0400 - Add Goo:Canvas::get_items_at and Goo::Canvas::get_items_in_area. Thanks to Jeffrey Ratcliffe! Goo-Canvas-0.06/META.yml0000644000175000017500000000106511200440442013022 0ustar ywbywb--- #YAML:1.0 name: Goo-Canvas version: 0.06 abstract: Perl interface to the GooCanvas license: ~ author: ~ generated_by: ExtUtils::MakeMaker version 6.42 distribution_type: module requires: Cairo: 1.00 ExtUtils::Depends: 0.2 ExtUtils::PkgConfig: 1.0 Glib: 1.103 Gtk2: 1.100 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 Goo-Canvas-0.06/maps0000644000175000017500000000507510676513710012460 0ustar ywbywbGOO_TYPE_CANVAS GooCanvas GtkObject Goo::Canvas GOO_TYPE_CANVAS_ELLIPSE GooCanvasEllipse GObject Goo::Canvas::Ellipse GOO_TYPE_CANVAS_ELLIPSE_MODEL GooCanvasEllipseModel GObject Goo::Canvas::EllipseModel GOO_TYPE_CANVAS_ANIMATE_TYPE GooCanvasAnimateType GEnum Goo::Canvas::AnimateType GOO_TYPE_CANVAS_POINTER_EVENTS GooCanvasPointerEvents GFlags Goo::Canvas::PointerEvents GOO_TYPE_CANVAS_ITEM_VISIBILITY GooCanvasItemVisibility GEnum Goo::Canvas::ItemVisibility GOO_TYPE_CANVAS_PATH_COMMAND_TYPE GooCanvasPathCommandType GEnum Goo::Canvas::PathCommandType GOO_TYPE_CANVAS_GROUP GooCanvasGroup GObject Goo::Canvas::Group GOO_TYPE_CANVAS_GROUP_MODEL GooCanvasGroupModel GObject Goo::Canvas::GroupModel GOO_TYPE_CANVAS_IMAGE GooCanvasImage GObject Goo::Canvas::Image GOO_TYPE_CANVAS_IMAGE_MODEL GooCanvasImageModel GObject Goo::Canvas::ImageModel GOO_TYPE_CANVAS_ITEM GooCanvasItem GObject Goo::Canvas::Item GOO_TYPE_CANVAS_ITEM_MODEL GooCanvasItemModel GObject Goo::Canvas::ItemModel GOO_TYPE_CANVAS_ITEM_SIMPLE GooCanvasItemSimple GObject Goo::Canvas::ItemSimple GOO_TYPE_CANVAS_ITEM_MODEL_SIMPLE GooCanvasItemModelSimple GObject Goo::Canvas::ItemModelSimple GOO_TYPE_CANVAS_PATH GooCanvasPath GObject Goo::Canvas::Path GOO_TYPE_CANVAS_PATH_MODEL GooCanvasPathModel GObject Goo::Canvas::PathModel GOO_TYPE_CANVAS_POINTS GooCanvasPoints GBoxed Goo::Canvas::Points GOO_TYPE_CANVAS_POLYLINE GooCanvasPolyline GObject Goo::Canvas::Polyline GOO_TYPE_CANVAS_POLYLINE_MODEL GooCanvasPolylineModel GObject Goo::Canvas::PolylineModel GOO_TYPE_CANVAS_RECT GooCanvasRect GObject Goo::Canvas::Rect GOO_TYPE_CANVAS_RECT_MODEL GooCanvasRectModel GObject Goo::Canvas::RectModel GOO_TYPE_CANVAS_STYLE GooCanvasStyle GObject Goo::Canvas::Style GOO_TYPE_CANVAS_TABLE GooCanvasTable GObject Goo::Canvas::Table GOO_TYPE_CANVAS_TABLE_MODEL GooCanvasTableModel GObject Goo::Canvas::TableModel GOO_TYPE_CANVAS_TEXT GooCanvasText GObject Goo::Canvas::Text GOO_TYPE_CANVAS_TEXT_MODEL GooCanvasTextModel GObject Goo::Canvas::TextModel GOO_TYPE_CANVAS_LINE_DASH GooCanvasLineDash GBoxed Goo::Canvas::LineDash GOO_TYPE_CAIRO_MATRIX GooCairoMatrix GBoxed Goo::Cairo::Matrix GOO_TYPE_CAIRO_PATTERN GooCairoPattern GBoxed Goo::Cairo::Pattern GOO_TYPE_CAIRO_FILL_RULE GooCairoFillRule GEnum Goo::Cairo::FillRule GOO_TYPE_CAIRO_OPERATOR GooCairoOperator GEnum Goo::Cairo::Operator GOO_TYPE_CAIRO_ANTIALIAS GooCairoAntialias GEnum Goo::Cairo::Antialias GOO_TYPE_CAIRO_LINE_CAP GooCairoLineCap GEnum Goo::Cairo::LineCap GOO_TYPE_CAIRO_LINE_JOIN GooCairoLineJoin GEnum Goo::Cairo::LineJoin GOO_TYPE_CANVAS_WIDGET GooCanvasWidget GObject Goo::Canvas::Widget Goo-Canvas-0.06/MANIFEST0000644000175000017500000000135610772721474012731 0ustar ywbywbbin/perlmine.pl bin/perltetris.pl Changes demo/demo.pl demo/flower.png demo/mv-demo.pl demo/mv-simple.pl demo/scalablity.pl demo/simple.pl demo/table.pl demo/toroid.png demo/unit-demo.pl goocanvas-perl.h goocanvas.typemap lib/Goo/Canvas.pm Makefile.PL MANIFEST This list of files maps ppport.h README t/Goo-Canvas.t tools/genmaps.pl tools/init.pl xs/goocanvas.xs xs/goocanvasbounds.xs xs/goocanvasellipse.xs xs/goocanvasgroup.xs xs/goocanvasimage.xs xs/goocanvasitem.xs xs/goocanvasitemmodel.xs xs/goocanvasitemsimple.xs xs/goocanvaspath.xs xs/goocanvaspolyline.xs xs/goocanvasrect.xs xs/goocanvasstyle.xs xs/goocanvastable.xs xs/goocanvastext.xs xs/goocanvaswidget.xs META.yml Module meta-data (added by MakeMaker) Goo-Canvas-0.06/xs/0000755000175000017500000000000011200440442012201 5ustar ywbywbGoo-Canvas-0.06/xs/goocanvaspath.xs0000644000175000017500000000132510716177722015436 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Path PACKAGE = Goo::Canvas::Path PREFIX = goo_canvas_path_ GooCanvasItem* goo_canvas_path_new(class, parent, path_data, ...) GooCanvasItem *parent const gchar *path_data CODE: RETVAL = goo_canvas_path_new(parent, path_data, NULL); GOOCANVAS_PERL_ADD_PROPETIES(3); OUTPUT: RETVAL MODULE = Goo::Canvas::Path PACKAGE = Goo::Canvas::PathModel PREFIX = goo_canvas_path_model_ GooCanvasItemModel* goo_canvas_path_model_new(class, parent, path_data, ...) GooCanvasItemModel *parent const gchar *path_data CODE: RETVAL = goo_canvas_path_model_new(parent, path_data, NULL); GOOCANVAS_PERL_ADD_PROPETIES(3); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvaswidget.xs0000644000175000017500000000072210716177722015765 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Widget PACKAGE = Goo::Canvas::Widget PREFIX = goo_canvas_widget_ GooCanvasItem* goo_canvas_widget_new(class, parent, widget, x, y, width, height, ...) GooCanvasItem *parent GtkWidget *widget gdouble x gdouble y gdouble width gdouble height CODE: RETVAL = goo_canvas_widget_new(parent, widget, x, y, width, height, NULL); GOOCANVAS_PERL_ADD_PROPETIES(7); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvastable.xs0000644000175000017500000000117510716177722015574 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Table PACKAGE = Goo::Canvas::Table PREFIX = goo_canvas_table_ GooCanvasItem* goo_canvas_table_new(class, parent, ...) GooCanvasItem *parent CODE: RETVAL = goo_canvas_table_new(parent, NULL); GOOCANVAS_PERL_ADD_PROPETIES(2); OUTPUT: RETVAL MODULE = Goo::Canvas::Table PACKAGE = Goo::Canvas::TableModel PREFIX = goo_canvas_table_model_ GooCanvasItemModel* goo_canvas_table_model_new(class, parent, ...) GooCanvasItemModel *parent CODE: RETVAL = goo_canvas_table_model_new(parent, NULL); GOOCANVAS_PERL_ADD_PROPETIES(2); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvasellipse.xs0000644000175000017500000000173210716177722016141 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Ellipse PACKAGE = Goo::Canvas::Ellipse PREFIX = goo_canvas_ellipse_ GooCanvasItem* goo_canvas_ellipse_new(class, parent, center_x, center_y, radius_x, radius_y, ...) GooCanvasItem *parent gdouble center_x gdouble center_y gdouble radius_x gdouble radius_y CODE: RETVAL = goo_canvas_ellipse_new(parent, center_x, center_y, radius_x, radius_y, NULL); GOOCANVAS_PERL_ADD_PROPETIES(6); OUTPUT: RETVAL MODULE = Goo::Canvas::Ellipse PACKAGE = Goo::Canvas::EllipseModel PREFIX = goo_canvas_ellipse_model_ GooCanvasItemModel* goo_canvas_ellipse_model_new(class, parent, center_x, center_y, radius_x, radius_y, ...) GooCanvasItemModel *parent gdouble center_x gdouble center_y gdouble radius_x gdouble radius_y CODE: RETVAL = goo_canvas_ellipse_model_new(parent, center_x, center_y, radius_x, radius_y, NULL); GOOCANVAS_PERL_ADD_PROPETIES(6); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvasrect.xs0000644000175000017500000000152210716177722015436 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Rect PACKAGE = Goo::Canvas::Rect PREFIX = goo_canvas_rect_ GooCanvasItem* goo_canvas_rect_new(class, parent, x, y, width, height, ...) GooCanvasItem *parent gdouble x gdouble y gdouble width gdouble height CODE: RETVAL = goo_canvas_rect_new(parent, x, y, width, height, NULL); GOOCANVAS_PERL_ADD_PROPETIES(6); OUTPUT: RETVAL MODULE = Goo::Canvas::Rect PACKAGE = Goo::Canvas::RectModel PREFIX = goo_canvas_rect_model_ GooCanvasItemModel* goo_canvas_rect_model_new(class, parent, x, y, width, height, ...) GooCanvasItemModel *parent gdouble x gdouble y gdouble width gdouble height CODE: RETVAL = goo_canvas_rect_model_new(parent, x, y, width, height, NULL); GOOCANVAS_PERL_ADD_PROPETIES(6); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvasimage.xs0000644000175000017500000000174010716177722015565 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Image PACKAGE = Goo::Canvas::Image PREFIX = goo_canvas_image_ GooCanvasItem* goo_canvas_image_new(class, parent, pixbuf, x, y, ...) GooCanvasItem *parent gdouble x gdouble y CODE: if ( SvTRUE( ST(2) ) ) RETVAL = goo_canvas_image_new(parent, SvGdkPixbuf (ST(2)), x, y, NULL); else RETVAL = goo_canvas_image_new(parent, NULL, x, y, NULL); GOOCANVAS_PERL_ADD_PROPETIES(5); OUTPUT: RETVAL MODULE = Goo::Canvas::Image PACKAGE = Goo::Canvas::ImageModel PREFIX = goo_canvas_image_model_ GooCanvasItemModel* goo_canvas_image_model_new(class, parent, pixbuf, x, y, ...) GooCanvasItemModel *parent gdouble x gdouble y CODE: if ( SvTRUE( ST(2) ) ) RETVAL = goo_canvas_image_model_new(parent, SvGdkPixbuf (ST(2)), x, y, NULL); else RETVAL = goo_canvas_image_model_new(parent, NULL, x, y, NULL); GOOCANVAS_PERL_ADD_PROPETIES(5); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvastext.xs0000644000175000017500000000164310716177722015471 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Text PACKAGE = Goo::Canvas::Text PREFIX = goo_canvas_text_ GooCanvasItem* goo_canvas_text_new(class, parent, string, x, y, width, anchor, ...) GooCanvasItem *parent const char *string gdouble x gdouble y gdouble width GtkAnchorType anchor CODE: RETVAL = goo_canvas_text_new(parent, string, x, y, width, anchor, NULL); GOOCANVAS_PERL_ADD_PROPETIES(7); OUTPUT: RETVAL MODULE = Goo::Canvas::Text PACKAGE = Goo::Canvas::TextModel PREFIX = goo_canvas_text_model_ GooCanvasItemModel* goo_canvas_text_model_new(class, parent, string, x, y, width, anchor, ...) GooCanvasItemModel *parent const char *string gdouble x gdouble y gdouble width GtkAnchorType anchor CODE: RETVAL = goo_canvas_text_model_new(parent, string, x, y, width, anchor, NULL); GOOCANVAS_PERL_ADD_PROPETIES(7); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvasstyle.xs0000644000175000017500000000601210716177722015640 0ustar ywbywb#include "goocanvas-perl.h" typedef SV* SVREF; static GQuark get_property_id(char* property) { GQuark property_id; if ( gperl_str_eq(property, "stroke_pattern") ) { property_id = goo_canvas_style_stroke_pattern_id; } else if ( gperl_str_eq(property, "fill-pattern") ) { property_id = goo_canvas_style_fill_pattern_id; } else if ( gperl_str_eq(property, "fill-rule") ) { property_id = goo_canvas_style_fill_rule_id; } else if ( gperl_str_eq(property, "operator") ) { property_id = goo_canvas_style_operator_id; } else if ( gperl_str_eq(property, "antialias") ) { property_id = goo_canvas_style_antialias_id; } else if ( gperl_str_eq(property, "line-width") ) { property_id = goo_canvas_style_line_width_id; } else if ( gperl_str_eq(property, "line-cap") ) { property_id = goo_canvas_style_line_cap_id; } else if ( gperl_str_eq(property, "line-join") ) { property_id = goo_canvas_style_line_join_id; } else if ( gperl_str_eq(property, "line-join-miter-limit") ) { property_id = goo_canvas_style_line_join_miter_limit_id; } else if ( gperl_str_eq(property, "line-dash") ) { property_id = goo_canvas_style_line_dash_id; } else if ( gperl_str_eq(property, "font-desc") ) { property_id = goo_canvas_style_font_desc_id; } else { croak ("Unknown style: %s, should be one of stroke_pattern/fill_pattern/fill_rule/operator/antialias/line_width/line_cap/line_join/line_join_miter_limit/line_dash/font_desc", property); } return property_id; } MODULE = Goo::Canvas::Style PACKAGE = Goo::Canvas::Style PREFIX = goo_canvas_style_ GooCanvasStyle* goo_canvas_style_new(class) C_ARGS: /* void */ GooCanvasStyle* goo_canvas_style_copy(style) GooCanvasStyle *style GooCanvasStyle* goo_canvas_style_get_parent(style) GooCanvasStyle *style void goo_canvas_style_set_parent(style, parent) GooCanvasStyle *style GooCanvasStyle *parent void goo_canvas_style_set_property(style, property, val) GooCanvasStyle *style char* property SV* val PREINIT: GQuark property_id; GType type; GValue value; CODE: property_id = get_property_id(property); type = gperl_type_from_package(sv_reftype(SvRV(val), TRUE)); if ( !type ) croak ("set_property: Unknown type of the value!"); g_value_init(&value, type); gperl_value_from_sv (&value, val); goo_canvas_style_set_property(style, property_id, &value); g_value_unset(&value); SV* goo_canvas_style_get_property(style, property) GooCanvasStyle *style char* property PREINIT: GQuark property_id; GValue* value; CODE: property_id = get_property_id(property); value = goo_canvas_style_get_property(style, property_id); RETVAL = gperl_sv_from_value(value); OUTPUT: RETVAL gboolean goo_canvas_style_set_fill_options(style, cr) GooCanvasStyle *style cairo_t *cr gboolean goo_canvas_style_set_stroke_options(style, cr) GooCanvasStyle *style cairo_t *cr Goo-Canvas-0.06/xs/goocanvasitem.xs0000644000175000017500000003623710716177722015452 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Item PACKAGE = Goo::Canvas::Item PREFIX = goo_canvas_item_ GooCanvas* goo_canvas_item_get_canvas(item) GooCanvasItem *item void goo_canvas_item_set_canvas(item, canvas) GooCanvasItem *item GooCanvas *canvas GooCanvasItem* goo_canvas_item_get_parent(item) GooCanvasItem *item void goo_canvas_item_set_parent(item, parent) GooCanvasItem *item GooCanvasItem *parent GooCanvasItemModel* goo_canvas_item_get_model(item) GooCanvasItem *item void goo_canvas_item_set_model(item, model) GooCanvasItem *item GooCanvasItemModel *model gboolean goo_canvas_item_is_container(item) GooCanvasItem *item gint goo_canvas_item_get_n_children(item) GooCanvasItem *item GooCanvasItem* goo_canvas_item_get_child(item, child_num) GooCanvasItem *item gint child_num gint goo_canvas_item_find_child(item, child) GooCanvasItem *item GooCanvasItem *child void goo_canvas_item_add_child(item, child, position) GooCanvasItem *item GooCanvasItem *child gint position void goo_canvas_item_move_child(item, old_position, new_position) GooCanvasItem *item gint old_position gint new_position void goo_canvas_item_remove_child(item, child_num) GooCanvasItem *item gint child_num gboolean goo_canvas_item_get_transform_for_child(item, child, transform) GooCanvasItem *item GooCanvasItem *child cairo_matrix_t *transform void goo_canvas_item_raise(item, ...) GooCanvasItem *item CODE: if ( items == 1 ) goo_canvas_item_raise(item, NULL); else goo_canvas_item_raise(item, SvGooCanvasItem (ST(1))); void goo_canvas_item_lower(item, ...) GooCanvasItem *item CODE: if ( items == 1 ) goo_canvas_item_lower(item, NULL); else goo_canvas_item_lower(item, SvGooCanvasItem (ST(1))); void goo_canvas_item_get_transform(item) GooCanvasItem *item PREINIT: gboolean ret; cairo_matrix_t *transform; PPCODE: ret = goo_canvas_item_get_transform(item, transform); if ( ret ) { ST(0) = newSVCairoMatrix (transform); sv_2mortal(ST(0)); } else { XSRETURN_UNDEF; } void goo_canvas_item_set_transform(item, matrix) GooCanvasItem *item cairo_matrix_t *matrix void goo_canvas_item_set_simple_transform(item, x, y, scale, rotation) GooCanvasItem *item gdouble x gdouble y gdouble scale gdouble rotation void goo_canvas_item_translate(item, tx, ty) GooCanvasItem *item gdouble tx gdouble ty void goo_canvas_item_scale(item, sx, sy) GooCanvasItem *item gdouble sx gdouble sy void goo_canvas_item_rotate(item, degrees, cx, cy) GooCanvasItem *item gdouble degrees gdouble cx gdouble cy void goo_canvas_item_skew_x(item, degrees, cx, cy) GooCanvasItem *item gdouble degrees gdouble cx gdouble cy void goo_canvas_item_skew_y(item, degrees, cx, cy) GooCanvasItem *item gdouble degrees gdouble cx gdouble cy GooCanvasStyle* goo_canvas_item_get_style(item) GooCanvasItem *item void goo_canvas_item_set_style(item, style) GooCanvasItem *item GooCanvasStyle *style void goo_canvas_item_animate(item, x, y, scale, degrees, absolute, duration, step_time, type) GooCanvasItem *item gdouble x gdouble y gdouble scale gdouble degrees gboolean absolute gint duration gint step_time GooCanvasAnimateType type void goo_canvas_item_stop_animation(item) GooCanvasItem *item void goo_canvas_item_request_update(item) GooCanvasItem *item void goo_canvas_item_ensure_updated(item) GooCanvasItem *item GooCanvasBounds * goo_canvas_item_update(item, entire_tree, cr) GooCanvasItem *item gboolean entire_tree cairo_t *cr CODE: Newx(RETVAL, 1, GooCanvasBounds); goo_canvas_item_update(item, entire_tree, cr, RETVAL); OUTPUT: RETVAL GooCanvasBounds * goo_canvas_item_get_requested_area(item, cr) GooCanvasItem *item cairo_t *cr PREINIT: gboolean ret; CODE: Newx(RETVAL, 1, GooCanvasBounds); ret = goo_canvas_item_get_requested_area(item, cr, RETVAL); if ( !ret ) { Safefree(RETVAL); RETVAL = NULL; } OUTPUT: RETVAL void goo_canvas_item_allocate_area(item, cr, requested_area, allocated_area, x_offset, y_offset) GooCanvasItem *item cairo_t *cr GooCanvasBounds *requested_area GooCanvasBounds *allocated_area gdouble x_offset gdouble y_offset GooCanvasBounds* goo_canvas_item_get_bounds(item) GooCanvasItem *item CODE: Newx(RETVAL, 1, GooCanvasBounds); goo_canvas_item_get_bounds(item, RETVAL); OUTPUT: RETVAL AV* goo_canvas_item_get_items_at(item, x, y, cr, is_pointer_event, parent_is_visible) GooCanvasItem *item gdouble x gdouble y cairo_t *cr gboolean is_pointer_event gboolean parent_is_visible PREINIT: GList *list, *i; CODE: list = goo_canvas_item_get_items_at(item, x, y, cr, is_pointer_event, parent_is_visible, NULL); RETVAL = newAV(); for ( i = list; i != NULL; i = i->next ) { av_push(RETVAL, newSVGooCanvasItem((GooCanvasItem*)i->data)); } sv_2mortal((SV*)RETVAL); OUTPUT: RETVAL CLEANUP: g_list_free (list); gboolean goo_canvas_item_is_visible(item) GooCanvasItem *item void goo_canvas_item_paint(item, cr, bounds, scale) GooCanvasItem *item cairo_t *cr GooCanvasBounds *bounds gdouble scale void goo_canvas_item_set_child_properties(item, child, ...) GooCanvasItem *item GooCanvasItem *child PREINIT: GParamSpec *pspec; GValue value = {0,}; int i; CODE: if ( 0 != items % 2 ) croak ("set_child_properties: expects name => value pairs" "(odd number of arguments detected)"); for ( i = 2; i < items; i+= 2 ) { char* name = SvPV_nolen(ST(i)); SV *newval = ST(i+1); pspec = goo_canvas_item_class_find_child_property( (GObjectClass*)g_type_class_peek(G_OBJECT_TYPE (G_OBJECT(item))), name); if ( !pspec ) { const char* classname = gperl_object_package_from_type(G_OBJECT_TYPE (G_OBJECT(item))); if ( !classname ) classname = G_OBJECT_TYPE_NAME(G_OBJECT(item)); croak("type %s does not support property '%s'", classname, name); } g_value_init (&value, G_PARAM_SPEC_VALUE_TYPE (pspec)); gperl_value_from_sv (&value, newval); if ( G_IS_PARAM_SPEC_BOOLEAN(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_boolean(&value), NULL); } else if ( G_IS_PARAM_SPEC_CHAR(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_char(&value), NULL); } else if ( G_IS_PARAM_SPEC_UCHAR(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_uchar(&value), NULL); } else if ( G_IS_PARAM_SPEC_INT(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_int(&value), NULL); } else if ( G_IS_PARAM_SPEC_UINT(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_uint(&value), NULL); } else if ( G_IS_PARAM_SPEC_LONG(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_long(&value), NULL); } else if ( G_IS_PARAM_SPEC_ULONG(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_ulong(&value), NULL); } else if ( G_IS_PARAM_SPEC_INT64(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_int64(&value), NULL); } else if ( G_IS_PARAM_SPEC_UINT64(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_uint64(&value), NULL); } else if ( G_IS_PARAM_SPEC_FLOAT(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_float(&value), NULL); } else if ( G_IS_PARAM_SPEC_DOUBLE(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_double(&value), NULL); } else if ( G_IS_PARAM_SPEC_ENUM(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_enum(&value), NULL); } else if ( G_IS_PARAM_SPEC_FLAGS(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_flags(&value), NULL); } else if ( G_IS_PARAM_SPEC_STRING(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_string(&value), NULL); } else if ( G_IS_PARAM_SPEC_PARAM(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_param(&value), NULL); } else if ( G_IS_PARAM_SPEC_BOXED(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_boxed(&value), NULL); } else if ( G_IS_PARAM_SPEC_POINTER(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_pointer(&value), NULL); } else if ( G_IS_PARAM_SPEC_OBJECT(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_object(&value), NULL); } else if ( G_IS_PARAM_SPEC_UNICHAR(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_uint(&value), NULL); } else if ( G_IS_PARAM_SPEC_VALUE_ARRAY(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_boxed(&value), NULL); } else if ( G_IS_PARAM_SPEC_GTYPE(pspec) ) { goo_canvas_item_set_child_properties(item, child, name, g_value_get_gtype(&value), NULL); } g_value_unset (&value); } =for apidoc Not like the original C function, which call as goo_canvas_item_get_child_properties(item, child, key1, &val1, key2, &val2, ..., NULL). This function call as $item->get_child_properties($child, $key1, $key2, ...) and return a list ($key1, $val1, $key2, $val2, ...) instead. So you can call like %pair = $item->get_child_properties($child, $key1, $key2) and use $pair{$key1} and $pair{$key2} to access the value for the property. =cut void goo_canvas_item_get_child_properties(item, child, ...) GooCanvasItem *item GooCanvasItem *child PREINIT: GParamSpec *pspec; GValue value = {0,}; int i; PPCODE: for ( i = 2; i < items; i++ ) { char* name = SvPV_nolen(ST(i)); SV* pval; pspec = goo_canvas_item_class_find_child_property( (GObjectClass*)g_type_class_peek(G_OBJECT_TYPE (G_OBJECT(item))), name); if ( !pspec ) { const char* classname = gperl_object_package_from_type(G_OBJECT_TYPE (G_OBJECT(item))); if ( !classname ) classname = G_OBJECT_TYPE_NAME(G_OBJECT(item)); croak("type %s does not support property '%s'", classname, name); } g_value_init (&value, G_PARAM_SPEC_VALUE_TYPE (pspec)); if ( G_IS_PARAM_SPEC_BOOLEAN(pspec) ) { gboolean val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_boolean(&value, val); } else if ( G_IS_PARAM_SPEC_CHAR(pspec) ) { gchar val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_char(&value, val); } else if ( G_IS_PARAM_SPEC_UCHAR(pspec) ) { guchar val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_uchar(&value, val); } else if ( G_IS_PARAM_SPEC_INT(pspec) ) { gint val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_int(&value, val); } else if ( G_IS_PARAM_SPEC_UINT(pspec) ) { guint val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_uint(&value, val); } else if ( G_IS_PARAM_SPEC_LONG(pspec) ) { glong val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_long(&value, val); } else if ( G_IS_PARAM_SPEC_ULONG(pspec) ) { gulong val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_ulong(&value, val); } else if ( G_IS_PARAM_SPEC_INT64(pspec) ) { gint64 val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_int64(&value, val); } else if ( G_IS_PARAM_SPEC_UINT64(pspec) ) { guint64 val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_uint64(&value, val); } else if ( G_IS_PARAM_SPEC_FLOAT(pspec) ) { gfloat val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_float(&value, val); } else if ( G_IS_PARAM_SPEC_DOUBLE(pspec) ) { gdouble val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_double(&value, val); } else if ( G_IS_PARAM_SPEC_ENUM(pspec) ) { gint val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_enum(&value, val); } else if ( G_IS_PARAM_SPEC_FLAGS(pspec) ) { guint val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_flags(&value, val); } else if ( G_IS_PARAM_SPEC_STRING(pspec) ) { gchar* val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_string(&value, val); } else if ( G_IS_PARAM_SPEC_PARAM(pspec) ) { GParamSpec* val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_param(&value, val); } else if ( G_IS_PARAM_SPEC_BOXED(pspec) ) { gpointer val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_boxed(&value, val); } else if ( G_IS_PARAM_SPEC_POINTER(pspec) ) { gpointer val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_pointer(&value, val); } else if ( G_IS_PARAM_SPEC_OBJECT(pspec) ) { gpointer val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_object(&value, val); } else if ( G_IS_PARAM_SPEC_UNICHAR(pspec) ) { guint val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_uint(&value, val); } else if ( G_IS_PARAM_SPEC_VALUE_ARRAY(pspec) ) { gpointer val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_boxed(&value, val); } else if ( G_IS_PARAM_SPEC_GTYPE(pspec) ) { GType val; goo_canvas_item_get_child_properties(item, child, name, &val, NULL); g_value_set_gtype(&value, val); } pval = gperl_sv_from_value(&value); g_value_unset (&value); mXPUSHp(name, strlen(name)); XPUSHs(pval); } Goo-Canvas-0.06/xs/goocanvasitemmodel.xs0000644000175000017500000003273210716177722016467 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::ItemModel PACKAGE = Goo::Canvas::ItemModel PREFIX = goo_canvas_item_model_ GooCanvasItemModel* goo_canvas_item_model_get_parent(model) GooCanvasItemModel *model void goo_canvas_item_model_set_parent(model, parent) GooCanvasItemModel *model GooCanvasItemModel *parent gboolean goo_canvas_item_model_is_container(model) GooCanvasItemModel *model gint goo_canvas_item_model_get_n_children(model) GooCanvasItemModel *model GooCanvasItemModel* goo_canvas_item_model_get_child(model, child_num) GooCanvasItemModel *model gint child_num void goo_canvas_item_model_add_child(model, child, position) GooCanvasItemModel *model GooCanvasItemModel *child gint position void goo_canvas_item_model_move_child(model, old_position, new_position) GooCanvasItemModel *model gint old_position gint new_position void goo_canvas_item_model_remove_child(model, child_num) GooCanvasItemModel *model gint child_num gint goo_canvas_item_model_find_child(model, child) GooCanvasItemModel *model GooCanvasItemModel *child void goo_canvas_item_model_raise(item, ...) GooCanvasItemModel *item CODE: if ( items == 1 ) goo_canvas_item_model_raise(item, NULL); else goo_canvas_item_model_raise(item, SvGooCanvasItemModel (ST(1))); void goo_canvas_item_model_lower(item, ...) GooCanvasItemModel *item CODE: if ( items == 1 ) goo_canvas_item_model_lower(item, NULL); else goo_canvas_item_model_lower(item, SvGooCanvasItemModel (ST(1))); void goo_canvas_item_model_get_transform(item) GooCanvasItemModel *item PREINIT: gboolean ret; cairo_matrix_t *transform; PPCODE: ret = goo_canvas_item_model_get_transform(item, transform); if ( ret ) { ST(0) = newSVCairoMatrix (transform); sv_2mortal(ST(0)); } else { XSRETURN_UNDEF; } void goo_canvas_item_model_set_transform(model, matrix) GooCanvasItemModel *model cairo_matrix_t *matrix void goo_canvas_item_model_set_simple_transform(model, x, y, scale, rotation) GooCanvasItemModel *model gdouble x gdouble y gdouble scale gdouble rotation void goo_canvas_item_model_translate(model, tx, ty) GooCanvasItemModel *model gdouble tx gdouble ty void goo_canvas_item_model_scale(model, sx, sy) GooCanvasItemModel *model gdouble sx gdouble sy void goo_canvas_item_model_rotate(model, degrees, cx, cy) GooCanvasItemModel *model gdouble degrees gdouble cx gdouble cy void goo_canvas_item_model_skew_x(model, degrees, cx, cy) GooCanvasItemModel *model gdouble degrees gdouble cx gdouble cy void goo_canvas_item_model_skew_y(model, degrees, cx, cy) GooCanvasItemModel *model gdouble degrees gdouble cx gdouble cy GooCanvasStyle* goo_canvas_item_model_get_style(model) GooCanvasItemModel *model void goo_canvas_item_model_set_style(model, style) GooCanvasItemModel *model GooCanvasStyle *style void goo_canvas_item_model_animate(model, x, y, scale, degrees, absolute, duration, step_time, type) GooCanvasItemModel *model gdouble x gdouble y gdouble scale gdouble degrees gboolean absolute gint duration gint step_time GooCanvasAnimateType type void goo_canvas_item_model_stop_animation(model) GooCanvasItemModel *model void goo_canvas_item_model_set_child_properties(model, child, ...) GooCanvasItemModel *model GooCanvasItemModel *child PREINIT: GParamSpec *pspec; GValue value = {0,}; int i; CODE: if ( 0 != items % 2 ) croak ("set_child_properties: expects name => value pairs" "(odd number of arguments detected)"); for ( i = 2; i < items; i+= 2 ) { char* name = SvPV_nolen(ST(i)); SV *newval = ST(i+1); pspec = goo_canvas_item_model_class_find_child_property( (GObjectClass*)g_type_class_peek(G_OBJECT_TYPE (G_OBJECT(model))), name); if ( !pspec ) { const char* classname = gperl_object_package_from_type(G_OBJECT_TYPE (G_OBJECT(model))); if ( !classname ) classname = G_OBJECT_TYPE_NAME(G_OBJECT(model)); croak("type %s does not support property '%s'", classname, name); } g_value_init (&value, G_PARAM_SPEC_VALUE_TYPE (pspec)); gperl_value_from_sv (&value, newval); if ( G_IS_PARAM_SPEC_BOOLEAN(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_boolean(&value), NULL); } else if ( G_IS_PARAM_SPEC_CHAR(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_char(&value), NULL); } else if ( G_IS_PARAM_SPEC_UCHAR(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_uchar(&value), NULL); } else if ( G_IS_PARAM_SPEC_INT(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_int(&value), NULL); } else if ( G_IS_PARAM_SPEC_UINT(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_uint(&value), NULL); } else if ( G_IS_PARAM_SPEC_LONG(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_long(&value), NULL); } else if ( G_IS_PARAM_SPEC_ULONG(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_ulong(&value), NULL); } else if ( G_IS_PARAM_SPEC_INT64(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_int64(&value), NULL); } else if ( G_IS_PARAM_SPEC_UINT64(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_uint64(&value), NULL); } else if ( G_IS_PARAM_SPEC_FLOAT(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_float(&value), NULL); } else if ( G_IS_PARAM_SPEC_DOUBLE(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_double(&value), NULL); } else if ( G_IS_PARAM_SPEC_ENUM(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_enum(&value), NULL); } else if ( G_IS_PARAM_SPEC_FLAGS(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_flags(&value), NULL); } else if ( G_IS_PARAM_SPEC_STRING(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_string(&value), NULL); } else if ( G_IS_PARAM_SPEC_PARAM(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_param(&value), NULL); } else if ( G_IS_PARAM_SPEC_BOXED(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_boxed(&value), NULL); } else if ( G_IS_PARAM_SPEC_POINTER(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_pointer(&value), NULL); } else if ( G_IS_PARAM_SPEC_OBJECT(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_object(&value), NULL); } else if ( G_IS_PARAM_SPEC_UNICHAR(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_uint(&value), NULL); } else if ( G_IS_PARAM_SPEC_VALUE_ARRAY(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_boxed(&value), NULL); } else if ( G_IS_PARAM_SPEC_GTYPE(pspec) ) { goo_canvas_item_model_set_child_properties(model, child, name, g_value_get_gtype(&value), NULL); } g_value_unset (&value); } =for apidoc Not like the original C function, which call as goo_canvas_item_model_get_child_properties(model, child, key1, &val1, key2, &val2, ..., NULL). This function call as $model->get_child_properties($child, $key1, $key2, ...) and return a list ($key1, $val1, $key2, $val2, ...) instead. So you can call like %pair = $model->get_child_properties($child, $key1, $key2) and use $pair{$key1} and $pair{$key2} to access the value for the property. =cut void goo_canvas_item_model_get_child_properties(model, child, ...) GooCanvasItemModel *model GooCanvasItemModel *child PREINIT: GParamSpec *pspec; GValue value = {0,}; int i; PPCODE: for ( i = 2; i < items; i++ ) { char* name = SvPV_nolen(ST(i)); SV* pval; pspec = goo_canvas_item_model_class_find_child_property( (GObjectClass*)g_type_class_peek(G_OBJECT_TYPE (G_OBJECT(model))), name); if ( !pspec ) { const char* classname = gperl_object_package_from_type(G_OBJECT_TYPE (G_OBJECT(model))); if ( !classname ) classname = G_OBJECT_TYPE_NAME(G_OBJECT(model)); croak("type %s does not support property '%s'", classname, name); } g_value_init (&value, G_PARAM_SPEC_VALUE_TYPE (pspec)); if ( G_IS_PARAM_SPEC_BOOLEAN(pspec) ) { gboolean val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_boolean(&value, val); } else if ( G_IS_PARAM_SPEC_CHAR(pspec) ) { gchar val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_char(&value, val); } else if ( G_IS_PARAM_SPEC_UCHAR(pspec) ) { guchar val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_uchar(&value, val); } else if ( G_IS_PARAM_SPEC_INT(pspec) ) { gint val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_int(&value, val); } else if ( G_IS_PARAM_SPEC_UINT(pspec) ) { guint val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_uint(&value, val); } else if ( G_IS_PARAM_SPEC_LONG(pspec) ) { glong val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_long(&value, val); } else if ( G_IS_PARAM_SPEC_ULONG(pspec) ) { gulong val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_ulong(&value, val); } else if ( G_IS_PARAM_SPEC_INT64(pspec) ) { gint64 val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_int64(&value, val); } else if ( G_IS_PARAM_SPEC_UINT64(pspec) ) { guint64 val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_uint64(&value, val); } else if ( G_IS_PARAM_SPEC_FLOAT(pspec) ) { gfloat val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_float(&value, val); } else if ( G_IS_PARAM_SPEC_DOUBLE(pspec) ) { gdouble val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_double(&value, val); } else if ( G_IS_PARAM_SPEC_ENUM(pspec) ) { gint val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_enum(&value, val); } else if ( G_IS_PARAM_SPEC_FLAGS(pspec) ) { guint val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_flags(&value, val); } else if ( G_IS_PARAM_SPEC_STRING(pspec) ) { gchar* val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_string(&value, val); } else if ( G_IS_PARAM_SPEC_PARAM(pspec) ) { GParamSpec* val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_param(&value, val); } else if ( G_IS_PARAM_SPEC_BOXED(pspec) ) { gpointer val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_boxed(&value, val); } else if ( G_IS_PARAM_SPEC_POINTER(pspec) ) { gpointer val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_pointer(&value, val); } else if ( G_IS_PARAM_SPEC_OBJECT(pspec) ) { gpointer val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_object(&value, val); } else if ( G_IS_PARAM_SPEC_UNICHAR(pspec) ) { guint val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_uint(&value, val); } else if ( G_IS_PARAM_SPEC_VALUE_ARRAY(pspec) ) { gpointer val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_boxed(&value, val); } else if ( G_IS_PARAM_SPEC_GTYPE(pspec) ) { GType val; goo_canvas_item_model_get_child_properties(model, child, name, &val, NULL); g_value_set_gtype(&value, val); } pval = gperl_sv_from_value(&value); g_value_unset (&value); mXPUSHp(name, strlen(name)); XPUSHs(pval); } Goo-Canvas-0.06/xs/goocanvasitemsimple.xs0000644000175000017500000000272110716177722016653 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::ItemSimple PACKAGE = Goo::Canvas::ItemSimple PREFIX = goo_canvas_itemsimple_ void goo_canvas_item_simple_check_style(item) GooCanvasItemSimple *item GooCanvasBounds* goo_canvas_item_simple_get_path_bounds(item, cr) GooCanvasItemSimple *item cairo_t *cr CODE: Newx(RETVAL, 1, GooCanvasBounds); goo_canvas_item_simple_get_path_bounds(item, cr, RETVAL); OUTPUT: RETVAL GooCanvasBounds* goo_canvas_item_simple_user_bounds_to_device(item, cr) GooCanvasItemSimple *item cairo_t *cr CODE: Newx(RETVAL, 1, GooCanvasBounds); goo_canvas_item_simple_user_bounds_to_device(item, cr, RETVAL); OUTPUT: RETVAL GooCanvasBounds* goo_canvas_item_simple_user_bounds_to_parent(item, cr) GooCanvasItemSimple *item cairo_t *cr CODE: Newx(RETVAL, 1, GooCanvasBounds); goo_canvas_item_simple_user_bounds_to_parent(item, cr, RETVAL); OUTPUT: RETVAL gboolean goo_canvas_item_simple_check_in_path (item, x, y, cr, pointer_events) GooCanvasItemSimple *item gdouble x gdouble y cairo_t *cr GooCanvasPointerEvents pointer_events void goo_canvas_item_simple_paint_path(item, cr) GooCanvasItemSimple *item cairo_t *cr void goo_canvas_item_simple_changed(item, recompute_bounds) GooCanvasItemSimple *item gboolean recompute_bounds void goo_canvas_item_simple_set_model(item, model) GooCanvasItemSimple *item GooCanvasItemModel *model Goo-Canvas-0.06/xs/goocanvasbounds.xs0000644000175000017500000000211010716177722015765 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Bounds PACKAGE = Goo::Canvas::Bounds PREFIX = goo_canvas_bounds_ GooCanvasBounds* new(class, x1, y1, x2, y2) double x1 double y1 double x2 double y2 CODE: Newx(RETVAL, 1, GooCanvasBounds); RETVAL->x1 = x1; RETVAL->x2 = x2; RETVAL->y1 = y1; RETVAL->y2 = y2; OUTPUT: RETVAL double x1 (self, ...) GooCanvasBounds* self CODE: RETVAL = self->x1; if (items ==2) self->x1 = SvNV(ST(1)); OUTPUT: RETVAL double x2 (self, ...) GooCanvasBounds* self CODE: RETVAL = self->x2; if (items ==2) self->x2 = SvNV(ST(1)); OUTPUT: RETVAL double y1 (self, ...) GooCanvasBounds* self CODE: RETVAL = self->y1; if (items ==2) self->y1 = SvNV(ST(1)); OUTPUT: RETVAL double y2 (self, ...) GooCanvasBounds* self CODE: RETVAL = self->y2; if (items ==2) self->y2 = SvNV(ST(1)); OUTPUT: RETVAL void DESTROY(self) GooCanvasBounds* self CODE: Safefree(self); Goo-Canvas-0.06/xs/goocanvas.xs0000644000175000017500000002065611200436555014560 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas PACKAGE = Goo::Canvas PREFIX = goo_canvas_ =head1 SYNOPSIS use Goo::Canvas; use Gtk2 '-init'; use Glib qw(TRUE FALSE); my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); my $swin = Gtk2::ScrolledWindow->new; $swin->set_shadow_type('in'); $window->add($swin); my $canvas = Goo::Canvas->new(); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $swin->add($canvas); my $root = $canvas->get_root_item(); my $rect = Goo::Canvas::Rect->new( $root, 100, 100, 400, 400, 'line-width' => 10, 'radius-x' => 20, 'radius-y' => 10, 'stroke-color' => 'yellow', 'fill-color' => 'red' ); $rect->signal_connect('button-press-event', \&on_rect_button_press); my $text = Goo::Canvas::Text->new( $root, "Hello World", 300, 300, -1, 'center', 'font' => 'Sans 24', ); $text->rotate(45, 300, 300); $window->show_all(); Gtk2->main; sub on_rect_button_press { print "Rect item pressed!\n"; return TRUE; } =head1 DESCRIPTION GTK+ doesn't has an built-in canvas widget. GooCanvas is wonderful. It is easy to use and has powerful and extensible methods to create items in canvas. Just try it. For more documents, please read GooCanvas Manual and the demo programs provided in the source distribution in both perl-Goo::Canvas and GooCanvas. =cut GtkWidget* goo_canvas_new(class) C_ARGS: /* void */ GooCanvasItem* goo_canvas_get_root_item(canvas) GooCanvas *canvas void goo_canvas_set_root_item(canvas, item) GooCanvas *canvas GooCanvasItem *item GooCanvasItemModel* goo_canvas_get_root_item_model(canvas) GooCanvas *canvas void goo_canvas_set_root_item_model(canvas, model) GooCanvas *canvas GooCanvasItemModel *model void goo_canvas_get_bounds(canvas) GooCanvas *canvas PREINIT: gdouble left; gdouble top; gdouble right; gdouble bottom; PPCODE: goo_canvas_get_bounds(canvas, &left, &top, &right, &bottom); mXPUSHn(left); mXPUSHn(top); mXPUSHn(right); mXPUSHn(bottom); void goo_canvas_set_bounds(canvas, left, top, right, bottom) GooCanvas *canvas gdouble left gdouble top gdouble right gdouble bottom gdouble goo_canvas_get_scale(canvas) GooCanvas *canvas void goo_canvas_set_scale(canvas, scale) GooCanvas *canvas gdouble scale GooCanvasItem* goo_canvas_get_item(canvas, model) GooCanvas *canvas GooCanvasItemModel *model GooCanvasItem* goo_canvas_get_item_at(canvas, x, y, is_pointer_event) GooCanvas *canvas gdouble x gdouble y gboolean is_pointer_event AV* goo_canvas_get_items_at(canvas, x, y, is_pointer_event) GooCanvas *canvas gdouble x gdouble y gboolean is_pointer_event PREINIT: GList *list, *i; CODE: list = goo_canvas_get_items_at(canvas, x, y, is_pointer_event); RETVAL = newAV(); for ( i = list; i != NULL; i = i->next ) { av_push(RETVAL, newSVGooCanvasItem((GooCanvasItem*)i->data)); } sv_2mortal((SV*)RETVAL); OUTPUT: RETVAL CLEANUP: g_list_free (list); AV* goo_canvas_get_items_in_area(canvas, area, inside_area, allow_overlaps, include_containers) GooCanvas *canvas GooCanvasBounds *area gboolean inside_area gboolean allow_overlaps gboolean include_containers PREINIT: GList *list, *i; CODE: list = goo_canvas_get_items_in_area(canvas, area, inside_area, allow_overlaps, include_containers); RETVAL = newAV(); for ( i = list; i != NULL; i = i->next ) { av_push(RETVAL, newSVGooCanvasItem((GooCanvasItem*)i->data)); } sv_2mortal((SV*)RETVAL); OUTPUT: RETVAL CLEANUP: g_list_free (list); void goo_canvas_scroll_to(canvas, left, top) GooCanvas *canvas gdouble left gdouble top void goo_canvas_render(canvas, cr, bounds, scale) GooCanvas *canvas cairo_t *cr GooCanvasBounds *bounds gdouble scale void goo_canvas_convert_to_pixels(canvas, x, y) GooCanvas *canvas gdouble x gdouble y C_ARGS: canvas, &x, &y OUTPUT: x y void goo_canvas_convert_from_pixels(canvas, x, y) GooCanvas *canvas gdouble x gdouble y C_ARGS: canvas, &x, &y OUTPUT: x y void goo_canvas_convert_to_item_space(canvas, item, x, y) GooCanvas *canvas GooCanvasItem *item gdouble x gdouble y C_ARGS: canvas, item, &x, &y OUTPUT: x y void goo_canvas_convert_from_item_space(canvas, item, x, y) GooCanvas *canvas GooCanvasItem *item gdouble x gdouble y C_ARGS: canvas, item, &x, &y OUTPUT: x y =for apidoc =for arg cursor (GdkCursor) the cursor to display during the grab, or undef means no change =cut GdkGrabStatus goo_canvas_pointer_grab(canvas, item, event_mask, cursor, time) GooCanvas *canvas GooCanvasItem *item GdkEventMask event_mask guint32 time CODE: if ( SvTRUE(ST(3)) ) RETVAL = goo_canvas_pointer_grab(canvas, item, event_mask, SvGdkCursor (ST(3)), time); else RETVAL = goo_canvas_pointer_grab(canvas, item, event_mask, NULL, time); OUTPUT: RETVAL void goo_canvas_pointer_ungrab(canvas, item, time) GooCanvas *canvas GooCanvasItem *item guint32 time void goo_canvas_grab_focus(canvas, item) GooCanvas *canvas GooCanvasItem *item GdkGrabStatus goo_canvas_keyboard_grab(canvas, item, owner_events, time) GooCanvas *canvas GooCanvasItem *item gboolean owner_events guint32 time void goo_canvas_keyboard_ungrab(canvas, item, time) GooCanvas *canvas GooCanvasItem *item guint32 time GooCanvasItem* goo_canvas_create_item(canvas, model) GooCanvas *canvas GooCanvasItemModel *model void goo_canvas_unregister_item(canvas, model) GooCanvas *canvas GooCanvasItemModel *model void goo_canvas_register_widget_item(canvas, witem) GooCanvas *canvas GooCanvasWidget *witem void goo_canvas_unregister_widget_item(canvas, witem) GooCanvas *canvas GooCanvasWidget *witem void goo_canvas_update(canvas) GooCanvas *canvas void goo_canvas_request_update(canvas) GooCanvas *canvas void goo_canvas_request_redraw(canvas, bounds) GooCanvas *canvas GooCanvasBounds *bounds gdouble goo_canvas_get_default_line_width(canvas) GooCanvas *canvas GArray* goo_canvas_parse_path_data(path_data) const gchar *path_data void goo_canvas_create_path(commands, cr) GArray *commands cairo_t *cr cairo_surface_t* goo_canvas_cairo_surface_from_pixbuf(pixbuf) GdkPixbuf* pixbuf BOOT: #include "register.xsh" #include "boot.xsh" MODULE = Goo::Canvas PACKAGE = Goo::Canvas::Points PREFIX = goo_canvas_points_ =for apidoc Create GooCanvasPoints from a Perl array. The points is an array reference that contain data like [x1, y1, x2, y2, ...] =cut GooCanvasPoints* goo_canvas_points_new(class, points) AV* points PREINIT: int len; int i; CODE: len = av_len(points) + 1; if ( 0 != len % 2 ) croak ("points new: expects point pairs" "(odd number of point coordinates detected)"); RETVAL = goo_canvas_points_new(len/2); for ( i = 0; i < len; i++ ) RETVAL->coords[i] = SvNV(*av_fetch(points, i, FALSE)); OUTPUT: RETVAL MODULE = Goo::Canvas PACKAGE = Goo::Canvas::LineDash PREFIX = goo_canvas_line_dash_ =for apidoc Create GooCanvasLineDash from a perl array. The dashes is an array reference contains numbers. =cut GooCanvasLineDash* goo_canvas_line_dash_new(class, dashes) AV *dashes PREINIT: int len; gdouble *dashes_ary; int i; CODE: len = av_len(dashes) + 1; Newx(dashes_ary, len, gdouble); for ( i = 0; i < len; i++ ) dashes_ary[i] = SvNV(*(av_fetch(dashes, i, FALSE))); RETVAL = goo_canvas_line_dash_newv(len, dashes_ary); OUTPUT: RETVAL MODULE = Goo::Canvas PACKAGE = Goo::Cairo::Pattern GooCairoPattern_copy* new(class, pattern) cairo_pattern_t* pattern CODE: RETVAL = pattern; OUTPUT: RETVAL GooCairoPattern_copy* new_from_pixbuf(class, pixbuf) GdkPixbuf *pixbuf CODE: RETVAL = goo_canvas_cairo_pattern_from_pixbuf(pixbuf); OUTPUT: RETVAL MODULE = Goo::Canvas PACKAGE = Goo::Cairo::Matrix GooCairoMatrix_copy* new(class, mat) cairo_matrix_t* mat CODE: RETVAL = (GooCairoMatrix*)mat; OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvaspolyline.xs0000644000175000017500000000640410716177722016340 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Polyline PACKAGE = Goo::Canvas::Polyline PREFIX = goo_canvas_polyline_ =for apidoc =for arg points (AV) The points is an array reference that contains a flat points coordinates. If you want create a polyline without points, pass an empty array refer or undef. =cut GooCanvasItem* goo_canvas_polyline_new(class, parent, close_path, points, ...) GooCanvasItem *parent gboolean close_path PREINIT: GooCanvasPolylineData *polyline_data; int i, len; AV* points; CODE: RETVAL = goo_canvas_polyline_new(parent, close_path, 0, NULL); if ( SvTRUE(ST(3)) ) { points = (AV*)SvRV(ST(3)); len = av_len(points) + 1; if ( len > 0) { if ( 0 != len % 2 ) croak ("polyline new: expects point pairs" "(odd number of point coordinates detected)"); polyline_data = ((GooCanvasPolyline*)RETVAL)->polyline_data; polyline_data->num_points = len/2; polyline_data->coords = g_slice_alloc( len * sizeof (gdouble)); for (i = 0; i < len; i++) { /* printf("point %e\n", SvNV(*av_fetch(points, i, FALSE))); */ polyline_data->coords[i] = SvNV(*av_fetch(points, i, FALSE)); } } } GOOCANVAS_PERL_ADD_PROPETIES(4); OUTPUT: RETVAL GooCanvasItem* goo_canvas_polyline_new_line(class, parent, x1, y1, x2, y2, ...) GooCanvasItem *parent gdouble x1 gdouble y1 gdouble x2 gdouble y2 CODE: RETVAL = goo_canvas_polyline_new_line(parent, x1, y1, x2, y2, NULL); GOOCANVAS_PERL_ADD_PROPETIES(6); OUTPUT: RETVAL MODULE = Goo::Canvas::Polyline PACKAGE = Goo::Canvas::PolylineModel PREFIX = goo_canvas_polyline_model_ =for apidoc =for arg points (AV) The points is an array reference that contains a flat points coordinates. If you want create a polyline without points, pass an empty array refer or undef. =cut GooCanvasItemModel* goo_canvas_polyline_model_new(class, parent, close_path, points, ...) GooCanvasItemModel *parent gboolean close_path PREINIT: GooCanvasPolylineData *polyline_data; int i, len; AV* points; CODE: RETVAL = goo_canvas_polyline_model_new(parent, close_path, 0, NULL); if ( SvTRUE(ST(3)) ) { points = (AV*)SvRV(ST(3)); len = av_len(points)+1; if ( len > 0 ) { if ( 0 != len % 2 ) croak ("polyline new: expects point pairs" "(odd number of point coordinates detected)"); polyline_data = &((GooCanvasPolylineModel*)RETVAL)->polyline_data; polyline_data->num_points = len/2; polyline_data->coords = g_slice_alloc( len * sizeof (gdouble)); for (i = 0; i < len; i++) polyline_data->coords[i] = SvNV(*av_fetch(points, i, FALSE)); } } GOOCANVAS_PERL_ADD_PROPETIES(4); OUTPUT: RETVAL GooCanvasItemModel* goo_canvas_polyline_model_new_line(class, parent, x1, y1, x2, y2, ...) GooCanvasItemModel *parent gdouble x1 gdouble y1 gdouble x2 gdouble y2 CODE: RETVAL = goo_canvas_polyline_model_new_line(parent, x1, y1, x2, y2, NULL); GOOCANVAS_PERL_ADD_PROPETIES(6); OUTPUT: RETVAL Goo-Canvas-0.06/xs/goocanvasgroup.xs0000644000175000017500000000172110716177722015636 0ustar ywbywb#include "goocanvas-perl.h" MODULE = Goo::Canvas::Group PACKAGE = Goo::Canvas::Group PREFIX = goo_canvas_group_ GooCanvasItem* goo_canvas_group_new(class, ...) PREINIT: GooCanvasItem *parent; CODE: if ( items == 1 || !sv_true(ST(1)) ) RETVAL = goo_canvas_group_new(NULL, NULL); else { parent = SvGooCanvasItem (ST(1)); RETVAL = goo_canvas_group_new(parent, NULL); GOOCANVAS_PERL_ADD_PROPETIES(2); } OUTPUT: RETVAL MODULE = Goo::Canvas::Group PACKAGE = Goo::Canvas::GroupModel PREFIX = goo_canvas_group_model_ GooCanvasItemModel* goo_canvas_group_model_new(class, ...) PREINIT: GooCanvasItemModel *parent; CODE: if ( items == 1 || !sv_true(ST(1)) ) RETVAL = goo_canvas_group_model_new(NULL, NULL); else { parent = SvGooCanvasItemModel (ST(1)); RETVAL = goo_canvas_group_model_new(parent, NULL); GOOCANVAS_PERL_ADD_PROPETIES(2); } OUTPUT: RETVAL Goo-Canvas-0.06/goocanvas-perl.h0000644000175000017500000000441010677321572014662 0ustar ywbywb/* @(#)goocanvas-perl.h */ #ifndef _GOOCANVAS_PERL_H #define _GOOCANVAS_PERL_H 1 #include "gperl.h" #include "gtk2perl.h" #include "cairo-perl.h" #include "goocanvas.h" /* FIXME: How to avoid compile error in autogen.h */ #define GooCairoPattern cairo_pattern_t #define GooCairoMatrix cairo_matrix_t #include "goocanvas-perl-version.h" #include "goocanvas-perl-autogen.h" #define GOOCANVAS_PERL_VALUE_GET(pspec, value) #define GOOCANVAS_PERL_ADD_PROPETIES(narg) \ { \ GValue value = {0, }; \ int i; \ if ( 0 != (items-(narg)) % 2 ) \ croak ("set method expects name => value pairs " \ "(odd number of arguments detected)"); \ for (i = (narg); i < items; i += 2) { \ char *name = SvPV_nolen (ST (i)); \ SV *newval = ST (i + 1); \ GParamSpec *pspec; \ pspec = g_object_class_find_property(G_OBJECT_GET_CLASS(G_OBJECT(RETVAL)), name); \ if ( !pspec ) { \ const char * classname = \ gperl_object_package_from_type(G_OBJECT_TYPE (G_OBJECT(RETVAL))); \ if (!classname) \ classname = G_OBJECT_TYPE_NAME(G_OBJECT(RETVAL)); \ croak ("type %s does not support property '%s'", \ classname, name); \ } \ g_value_init (&value, G_PARAM_SPEC_VALUE_TYPE (pspec)); \ gperl_value_from_sv (&value, newval); \ g_object_set_property (G_OBJECT(RETVAL), name, &value); \ g_value_unset (&value); \ } \ } #endif /* _GOOCANVAS_PERL_H */ Goo-Canvas-0.06/goocanvas.typemap0000644000175000017500000000111410676674137015157 0ustar ywbywbGooCanvasBounds* T_PTROBJ_GENRIC GArray* T_PTRREF INPUT T_PTROBJ_GENRIC if (sv_isa($arg, \"${\(join('::', split(/(?=[A-Z])/, do{ (my $t = ${type}) =~ s/\s*[*]+$//; $t })))}\")) { IV tmp = SvIV((SV*)SvRV($arg)); $var = INT2PTR($type,tmp); } else if ( !SvTRUE($arg) ) $var = NULL; else Perl_croak(aTHX_ \"$var is not of type ${\(join('::', split(/(?=[A-Z])/, do{ (my $t = ${type}) =~ s/\s*[*]+$//; $t })))}\"); OUTPUT T_PTROBJ_GENRIC sv_setref_pv($arg, \"${\(join('::', split(/(?=[A-Z])/, do{ (my $t = ${type}) =~ s/\s*[*]+$//; $t })))}\", (void*)$var); Goo-Canvas-0.06/ppport.h0000644000175000017500000034666010676413451013303 0ustar ywbywb#if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.06_01 Automatically created by Devel::PPPort running under perl 5.008008 on Wed Sep 26 16:24:09 2007. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.06_01 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.9.3. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only up to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions, you want either C or global variants. For a C function, use: #define NEED_function For a global function, use: #define NEED_function_GLOBAL Note that you mustn't have more than one global request for one function in your project. Function Static Request Global Request ----------------------------------------------------------------------------------------- eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report using the CPAN Request Tracker at L. Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } usage() if $opt{help}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } # Never use C comments in this file!!!!! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( AvFILLp|5.004050||p AvFILL||| CLASS|||n CX_CURPAD_SAVE||| CX_CURPAD_SV||| CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002||p Copy||| CvPADLIST||| CvSTASH||| CvWEAKOUTSIDE||| DEFSV|5.004050||p END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvSV||| Gv_AMupdate||| HEf_SVKEY||5.004000| HeHASH||5.004000| HeKEY||5.004000| HeKLEN||5.004000| HePV||5.004000| HeSVKEY_force||5.004000| HeSVKEY_set||5.004000| HeSVKEY||5.004000| HeVAL||5.004000| HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LVRET||| MARK||| MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002||p Move||| NEWSV||| NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newc||| Newz||| New||| Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| ORIGMARK||| PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERL_BCDVERSION|5.009003||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_INT_MAX|5.004000||p PERL_INT_MIN|5.004000||p PERL_LONG_MAX|5.004000||p PERL_LONG_MIN|5.004000||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.007002||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.007002||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.007002||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.007002||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_QUAD_MAX|5.004000||p PERL_QUAD_MIN|5.004000||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.004000||p PERL_SHORT_MIN|5.004000||p PERL_SUBVERSION|5.006000||p PERL_UCHAR_MAX|5.004000||p PERL_UCHAR_MIN|5.004000||p PERL_UINT_MAX|5.004000||p PERL_UINT_MIN|5.004000||p PERL_ULONG_MAX|5.004000||p PERL_ULONG_MIN|5.004000||p PERL_UNUSED_DECL|5.007002||p PERL_UQUAD_MAX|5.004000||p PERL_UQUAD_MIN|5.004000||p PERL_USHORT_MAX|5.004000||p PERL_USHORT_MIN|5.004000||p PERL_VERSION|5.006000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||n PL_Sv|5.005000||p PL_compiling|5.004050||p PL_copline|5.005000||p PL_curcop|5.004050||p PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_last_in_gv|||n PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofs_sv|||n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rsfp_filters|5.004050||p PL_rsfp|5.004050||p PL_rs|||n PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Poison|5.008000||p RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p ST||| SVt_IV||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVHV||| SVt_PVMG||| SVt_PV||| Safefree||| Slab_Alloc||| Slab_Free||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set||5.009003| SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX||| SvPV_force_nomg|5.007002||p SvPV_force||| SvPV_nolen|5.006000||p SvPV_nomg|5.007002||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec||| SvREFCNT_inc||| SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set||5.009003| SvRV||| SvSETMAGIC||| SvSHARE||5.007003| SvSTASH_set||5.009003| SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK||5.007001| SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set||5.009003| SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| THIS|||n UNDERBAR|5.009002||p UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN||| XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_VERSION_BOOTCHECK||| XS_VERSION||| XS||| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _pMY_CXT|5.007003||p aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHX_|5.006000||p aTHX|5.006000||p add_data||| allocmy||| amagic_call||| any_dup||| ao||| append_elem||| append_list||| apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| asIV||| asUV||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_delete||5.006000| av_exists||5.006000| av_extend||| av_fake||| av_fetch||| av_fill||| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_undef||| av_unshift||| ax|||n bad_type||| bind_match||| block_end||| block_gimme||5.004000| block_start||| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_xsutils||| bytes_from_utf8||5.007001| bytes_to_utf8||5.006001| cache_re||| call_argv|5.006000||p call_atexit||5.006000| call_body||| call_list_body||| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p calloc||5.007002|n cando||| cast_i32||5.006000| cast_iv||5.006000| cast_ulong||5.006000| cast_uv||5.006000| check_uni||| checkcomma||| checkposixcc||| ck_anoncode||| ck_bitop||| ck_concat||| ck_defined||| ck_delete||| ck_die||| ck_eof||| ck_eval||| ck_exec||| ck_exists||| ck_exit||| ck_ftst||| ck_fun||| ck_glob||| ck_grep||| ck_index||| ck_join||| ck_lengthconst||| ck_lfun||| ck_listiob||| ck_match||| ck_method||| ck_null||| ck_open||| ck_repeat||| ck_require||| ck_retarget||| ck_return||| ck_rfun||| ck_rvconst||| ck_sassign||| ck_select||| ck_shift||| ck_sort||| ck_spair||| ck_split||| ck_subr||| ck_substr||| ck_svconst||| ck_trunc||| ck_unpack||| cl_and||| cl_anything||| cl_init_zero||| cl_init||| cl_is_anything||| cl_or||| closest_cop||| convert||| cop_free||| cr_textfilter||| croak_nocontext|||vn croak|||v csighandler||5.007001|n custom_op_desc||5.007003| custom_op_name||5.007003| cv_ckproto||| cv_clone||| cv_const_sv||5.004000| cv_dump||| cv_undef||| cx_dump||5.005000| cx_dup||| cxinc||| dAXMARK||5.009003| dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| deb||5.007003|v del_he||| del_sv||| delimcpy||5.004000| depcom||| deprecate_old||| deprecate||| despatch_signals||5.007001| die_nocontext|||vn die_where||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_chop||| do_close||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_kv||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_oddball||| do_op_dump||5.006000| do_open9||5.006000| do_openn||5.007001| do_open||5.004000| do_pipe||| do_pmop_dump||5.006000| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch_body||| docatch||| doeval||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptosub||| dounwind||| dowantarray||| dump_all||5.006000| dump_eval||5.006000| dump_fds||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs||5.006000| dump_sub||5.006000| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| emulate_eaccess||| eval_pv|5.006000||p eval_sv|5.006000||p expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| fd_on_nosuid_fs||| filter_add||| filter_del||| filter_gets||| filter_read||| find_beginning||| find_byclass||| find_in_my_stash||| find_runcv||| find_rundefsvoffset||5.009002| find_script||| find_uninit_var||| fold_constants||| forbid_setid||| force_ident||| force_list||| force_next||| force_version||| force_word||| form_nocontext|||vn form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_av|5.006000||p get_context||5.006000|n get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| gp_dup||| gp_free||| gp_ref||| grok_bin|5.007003||p grok_hex|5.007003||p grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_autoload4||5.004000| gv_check||| gv_dump||5.006000| gv_efullname3||5.004000| gv_efullname4||5.006001| gv_efullname||| gv_ename||| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmethod_autoload||5.004000| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags||5.009002| gv_fetchpv||| gv_fetchsv||5.009002| gv_fullname3||5.004000| gv_fullname4||5.006001| gv_fullname||| gv_handler||5.007001| gv_init_sv||| gv_init||| gv_share||| gv_stashpvn|5.006000||p gv_stashpv||| gv_stashsv||| he_dup||| hek_dup||| hfreeentries||| hsplit||| hv_assert||5.009001| hv_auxinit||| hv_clear_placeholders||5.009001| hv_clear||| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.004000| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_exists_ent||5.004000| hv_exists||| hv_fetch_common||| hv_fetch_ent||5.004000| hv_fetch||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.004000| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_ksplit||5.004000| hv_magic_check||| hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||5.009003| hv_placeholders_set||5.009003| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.004000| hv_store_flags||5.008000| hv_store||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incl_perldb||| incline||| incpush||| ingroup||| init_argv_symbols||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_lexer||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| instr||| intro_my||| intuit_method||| intuit_more||| invert||| io_close||| isALNUM||| isALPHA||| isDIGIT||| isLOWER||| isSPACE||| isUPPER||| is_an_int||| is_gv_magical_sv||| is_gv_magical||| is_handle_constructor||| is_list_assignment||| is_lvalue_sub||5.007001| is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.006000| is_uni_alnumc||5.006000| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.006000| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_char_slow||| is_utf8_char||5.006000| is_utf8_cntrl||5.006000| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003| is_utf8_string_loc||5.008001| is_utf8_string||5.006001| is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| isa_lookup||| items|||n ix|||n jmaybe||| keyword||| leave_scope||| lex_end||| lex_start||| linklist||| listkids||| list||| load_module_nocontext|||vn load_module||5.006000|v localize||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHu|5.009002||p magic_clear_all_env||| magic_clearenv||| magic_clearpack||| magic_clearsig||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_freeregexp||| magic_getarylen||| magic_getdefelem||| magic_getglob||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_len||| magic_methcall||| magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setamagic||| magic_setarylen||| magic_setbm||| magic_setcollxfrm||| magic_setdbline||| magic_setdefelem||| magic_setenv||| magic_setfm||| magic_setglob||| magic_setisa||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| magicname||| make_trie||| malloced_size|||n malloc||5.007002|n markstack_grow||| measure_struct||| memEQ|5.004000||p memNE|5.004000||p mem_collxfrm||| mess_alloc||| mess_nocontext|||vn mess||5.006000|v method_common||| mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find||| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical||| mg_set||| mg_size||5.005000| mini_mktime||5.007002| missingterm||| mode_from_discipline||| modkids||| mod||| moreswitches||| mul128||| mulexp10|||n my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy|||n my_betoh16|||n my_betoh32|||n my_betoh64|||n my_betohi|||n my_betohl|||n my_betohs|||n my_bzero|||n my_chsize||| my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_htobe16|||n my_htobe32|||n my_htobe64|||n my_htobei|||n my_htobel|||n my_htobes|||n my_htole16|||n my_htole32|||n my_htole64|||n my_htolei|||n my_htolel|||n my_htoles|||n my_htonl||| my_kid||| my_letoh16|||n my_letoh32|||n my_letoh64|||n my_letohi|||n my_letohl|||n my_letohs|||n my_lstat||| my_memcmp||5.004000|n my_memset|||n my_ntohl||| my_pclose||5.004000| my_popen_list||5.007001| my_popen||5.004000| my_setenv||| my_socketpair||5.007003|n my_stat||| my_strftime||5.007002| my_swabn|||n my_swap||| my_unexec||| my||| newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB|5.006000||p newCVREF||| newDEFSVOP||| newFORM||| newFOROP||| newGVOP||| newGVREF||| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMYSUB||5.006000| newNULLLIST||| newOP||| newPADOP||5.006000| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.006000||p newRV||| newSLICEOP||| newSTATEOP||| newSUB||| newSVOP||| newSVREF||| newSVhek||5.009003| newSViv||| newSVnv||| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_share||5.007001| newSVpvn|5.006000||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newUNOP||| newWHILEOP||5.009003| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| next_symbol||| nextargv||| nextchar||| ninstr||| no_bareword_allowed||| no_fh_allowed||| no_op||| not_a_number||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n oopsAV||| oopsCV||| oopsHV||| op_clear||| op_const_sv||| op_dump||5.006000| op_free||| op_null||5.007002| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| open_script||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p pack_cat||5.007003| pack_rec||| package||| packlist||5.008001| pad_add_anon||| pad_add_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||| pad_findlex||| pad_findmy||| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||| pad_push||| pad_reset||| pad_setsv||| pad_sv||| pad_swipe||| pad_tidy||| pad_undef||| parse_body||| parse_unicode_opts||| path_is_absolute||| peep||| pending_ident||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pmflag||| pmop_dump||5.006000| pmruntime||| pmtrans||| pop_scope||| pregcomp||| pregexec||| pregfree||| prepend_elem||| printf_nocontext|||vn ptr_table_clear||| ptr_table_fetch||| ptr_table_free||| ptr_table_new||| ptr_table_split||| ptr_table_store||| push_scope||| put_byte||| pv_display||5.006000| pv_uni_display||5.007003| qerror||| re_croak2||| re_dup||| re_intuit_start||5.006000| re_intuit_string||5.006000| realloc||5.007002|n reentrant_free||| reentrant_init||| reentrant_retry|||vn reentrant_size||| refkids||| refto||| ref||| reg_node||| reganode||| regatom||| regbranch||| regclass_swash||5.007003| regclass||| regcp_set_to||| regcppop||| regcppush||| regcurly||| regdump||5.005000| regexec_flags||5.005000| reghop3||| reghopmaybe3||| reghopmaybe||| reghop||| reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regoptail||| regpiece||| regpposixcc||| regprop||| regrepeat_hard||| regrepeat||| regtail||| regtry||| reguni||| regwhite||| reg||| repeatcpy||| report_evil_fh||| report_uninit||| require_errno||| require_pv||5.006000| rninstr||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| runops_debug||5.005000| runops_standard||5.005000| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hek_flags||| save_helem||5.004050| save_hints||5.005000| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic||| save_mortalizesv||5.007001| save_nogv||| save_op||| save_padsv||5.007001| save_pptr||| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_svref||| save_threadsv||5.005000| save_vptr||5.006000| savepvn||| savepv||| savesharedpv||5.007003| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| sawparens||| scalar_mod_type||| scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.008001| scan_word||| scope||| screaminstr||5.005000| seed||| set_context||5.006000|n set_csh||| set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| setdefout||| setenv_getix||| share_hek_flags||| share_hek||| si_dup||| sighandler|||n simplify_sort||| skipspace||| sortsv||5.007003| ss_dup||| stack_grow||| start_glob||| start_subparse||5.004000| stashpv_hvname_match||5.009003| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2nv||| sv_2pv_flags||5.007002| sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen||| sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff||| sv_bless||| sv_cat_decode||5.008001| sv_catpv_mg|5.006000||p sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.006000||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.006000||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm||| sv_compile_2op||5.008001| sv_copypv||5.007003| sv_dec||| sv_del_backref||| sv_derived_from||5.004000| sv_dump||| sv_dup||| sv_eq||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_gets||5.004000| sv_grow||| sv_inc||| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_len_utf8||5.006000| sv_len||| sv_magicext||5.007003| sv_magic||| sv_mortalcopy||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||5.007003| sv_nv||5.005000| sv_peek||5.005000| sv_pos_b2u||5.006000| sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags||5.007002| sv_pvn_force|||p sv_pvn_nomg|5.007003||p sv_pvn|5.006000||p sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_release_COW||| sv_release_IVX||| sv_replace||| sv_report_used||| sv_reset||| sv_rvweaken||5.006000| sv_setiv_mg|5.006000||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.006000||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.006000||p sv_setpvn||| sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.006000||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.006000||p sv_setuv|5.006000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_mg|5.006000||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.006000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p svtype||| swallow_bom||| swash_fetch||5.007002| swash_init||5.006000| sys_intern_clear||| sys_intern_dup||| sys_intern_init||| taint_env||| taint_proper||| tmps_grow||5.006000| toLOWER||| toUPPER||| to_byte_substr||| to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.007003| to_utf8_lower||5.007003| to_utf8_substr||| to_utf8_title||5.007003| to_utf8_upper||5.007003| tokeq||| tokereport||| too_few_arguments||| too_many_arguments||| unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.004000| upg_version||5.009000| usage||| utf16_textfilter||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf16rev_textfilter||| utf8_distance||5.006000| utf8_hop||5.006000| utf8_length||5.007001| utf8_mg_pos_init||| utf8_mg_pos||| utf8_to_bytes||5.006001| utf8_to_uvchr||5.007001| utf8_to_uvuni||5.007001| utf8n_to_uvchr||5.007001| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||5.007001| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vdie||| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module||5.006000| vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warner_nocontext|||vn warner||5.006000|v warn|||v watch||| whichsig||| write_to_stderr||| yyerror||| yylex||| yyparse||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %depends); my $replace = 0; my $hint = ''; while () { if ($hint) { if (m{^\s*\*\s(.*?)\s*$}) { $hints{$hint} ||= ''; # suppress warning with older perls $hints{$hint} .= "$1\n"; } else { $hint = ''; } } $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2; } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "$hints{$f}" if exists $hints{$f}; $info++; } unless ($info) { print "No portability information available.\n"; } $count++; } if ($count > 0) { print "\n"; } else { print "Found no API matching '$opt{'api-info'}'.\n"; } exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( xs c h cc cpp ); my $srcext = join '|', @srcext; if (@ARGV) { my %seen; @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV; } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /\.($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*.$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } unless (@files) { die "No input files given!\n"; } my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # temporarily remove C comments from the code my @ccom; $c =~ s{ ( [^"'/]+ | (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+ | (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+ ) | (/ (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* )) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce"; }egsx; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/); my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { if (exists $need{$_}) { $file{needs}{$_} = 'static'; } } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename"); } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses}}) { next unless $file{uses}{$func}; # if it's only a dependency if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } elsif (exists $replace{$func}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } else { diag("Uses $func"); } hint($func); } for $func (sort keys %{$file{uses_todo}}) { warning("Uses $func, which may not be portable below perl ", format_version($API{$func}{todo})); } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and can_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub can_use { eval "use @_;"; return $@ eq ''; } sub rec_depend { my $func = shift; my %seen; return () unless exists $depends{$func}; grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; sub hint { $opt{quiet} and return; $opt{hints} or return; my $func = shift; exists $hints{$func} or return; $given_hints{$func}++ and return; my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)) /* Replace: 1 */ # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_Sv Sv # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_hexdigit hexdigit # define PL_hints hints # define PL_na na # define PL_no_modify no_modify # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_ppaddr ppaddr # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting /* Replace: 0 */ #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef NOOP # define NOOP (void)0 #endif #ifndef dNOOP # define dNOOP extern int Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif # define NUM2PTR(any,d) (any)(PTRV)(d) # define PTR2IV(p) INT2PTR(IV,p) # define PTR2UV(p) INT2PTR(UV,p) # define PTR2NV(p) NUM2PTR(NV,p) # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif /* !INT2PTR */ #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC) # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #undef STMT_START #undef STMT_END #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d) #endif #endif #ifndef Poison # define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t)) #endif #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ /* Replace perl_eval_pv with eval_pv */ /* eval_pv depends on eval_sv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5)) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))) start_subparse(), #elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22)) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv(name,0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 )) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # else # if IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # endif # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvPV_nolen #if defined(NEED_sv_2pv_nolen) static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); static #else extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv); #endif #ifdef sv_2pv_nolen # undef sv_2pv_nolen #endif #define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a) #define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen) #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL) char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv) { STRLEN n_a; return sv_2pv(sv, &n_a); } #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() macro instead of sv_2pv_nolen(). */ /* SvPV_nolen depends on sv_2pv_nolen */ #define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_nolen(sv)) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0))) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte /* SvPVbyte depends on sv_2pvbyte */ #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif /* sv_2pvbyte_nolen depends on sv_2pv_nolen */ #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen sv_2pv_nolen #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ #ifndef sv_pvn # define sv_pvn(sv, len) SvPV(sv, len) #endif /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ #ifndef sv_pvn_force # define sv_pvn_force(sv, len) SvPV_force(sv, len) #endif #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif /* sv_vcatpvf depends on sv_vcatpvfn */ #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif /* sv_vsetpvf depends on sv_vsetpvfn */ #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif /* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */ #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif /* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */ #ifdef PERL_IMPLICIT_CONTEXT #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif /* sv_vcatpvf_mg depends on sv_vcatpvfn */ #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif /* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */ #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif /* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */ #ifdef PERL_IMPLICIT_CONTEXT #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif /* sv_vsetpvf_mg depends on sv_vsetpvfn */ #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef SvPV_force_nomg # define SvPV_force_nomg SvPV_force #endif #ifndef SvPV_nomg # define SvPV_nomg SvPV #endif #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */ #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif /* PERL_VERSION */ #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif /* grok_number depends on grok_numeric_radix */ #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Goo-Canvas-0.06/tools/0000755000175000017500000000000011200440442012707 5ustar ywbywbGoo-Canvas-0.06/tools/genmaps.pl0000755000175000017500000000560710676416653014740 0ustar ywbywb#! /usr/bin/perl -w #read !grep _TYPE_ /usr/include/gtk-2.0/gtk/*.h | grep get_type #% s/^.*[ \t]\([_A-Z0-9]*_TYPE_[_A-Z0-9]*\)[ \t].*$/\1/ # # Copyright (C) 2003 by the gtk2-perl team (see the file AUTHORS for the full # list) # # This library is free software; you can redistribute it and/or modify it under # the terms of the GNU Library General Public License as published by the Free # Software Foundation; either version 2.1 of the License, or (at your option) # any later version. # # This library is distributed in the hope that it will be useful, but WITHOUT # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for # more details. # # You should have received a copy of the GNU Library General Public License # along with this library; if not, write to the Free Software Foundation, Inc., # 59 Temple Place - Suite 330, Boston, MA 02111-1307 USA. # # $Header: /cvsroot/gtk2-perl/gtk2-perl-xs/Gtk2/tools/genmaps.pl,v 1.1 2003/12/05 19:33:17 muppetman Exp $ # my $del_foo = shift; my $gc = "goocanvas"; my ($dir) = grep {/$gc/} split /\s*-I\s*/, `pkg-config $gc --cflags`; my @types; my @lines = `grep _TYPE_ $dir/*.h | grep get_type`; foreach (@lines) { chomp; s/^.*\s([A-Z][A-Z0-9_]*_TYPE_[A-Z0-9_]*)\s.*$/$1/; # print "$1\n"; push @types, $_; } if ( $del_foo || !-e 'foo.c' ) { create_foo_c(); } if ( !-e 'foo' || (stat('foo'))[9]<(stat('foo.c'))[9] ) { create_foo(); } foreach (`./foo`) { chomp; my @p = split; my @n = split /(?=[A-Z])/, $p[1]; my $fullname = join('::', @n[0,1], join('', @n[2..$#n])); $fullname =~ s/::$//; print join("\t", @p, $fullname), "\n"; } sub create_foo { system "gcc -DGTK_DISABLE_DEPRECATED -Wall -o foo foo.c `pkg-config $gc --cflags --libs`" and die "couldn't compile helper program"; } sub create_foo_c { open FOO, "> foo.c"; select FOO; print '#include #include #include const char * find_base (GType gtype) { if (g_type_is_a (gtype, GTK_TYPE_OBJECT)) return "GtkObject"; if (g_type_is_a (gtype, G_TYPE_OBJECT)) return "GObject"; if (g_type_is_a (gtype, G_TYPE_BOXED)) return "GBoxed"; if (g_type_is_a (gtype, G_TYPE_FLAGS)) return "GFlags"; if (g_type_is_a (gtype, G_TYPE_ENUM)) return "GEnum"; if (g_type_is_a (gtype, G_TYPE_INTERFACE)) return "GInterface"; if (g_type_is_a (gtype, G_TYPE_STRING)) return "GString"; { GType parent = gtype; while (parent != 0) { gtype = parent; parent = g_type_parent (gtype); } return g_type_name (gtype); } return "-"; } int main (int argc, char * argv []) { g_type_init (); '; foreach (@types) { print '#ifdef '.$_.' { GType gtype = '.$_.'; printf ("%s\t%s\t%s\n", "'.$_.'", g_type_name (gtype), find_base (gtype)); } #endif /* '.$_.' */ '; } print ' return 0; } '; close FOO; select STDOUT; } Goo-Canvas-0.06/tools/init.pl0000755000175000017500000000214210676417627014242 0ustar ywbywb#!/usr/bin/perl -w # init.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/22 05:30:05 # Author: Ye Wenbin use strict; use warnings; my $gc = "goocanvas"; my ($dir) = grep {/$gc/} split /\s*-I\s*/, `pkg-config $gc --cflags`; opendir(DIR, $dir) or die "Can't open directory $dir: $!"; foreach ( readdir(DIR) ) { next unless $_ =~ s/\.h$//; if ( /png/ ) { s/png/PNG/; } my $out = "../xs/$_.xs"; (my $mod = $_) =~ s/goocanvas(.*)/'Goo::Canvas::'.ucfirst($1)/e; $mod =~ s/::$//; (my $pre = $_) =~ s/goocanvas(.*)/goo_canvas_${1}_/; $pre =~ s/__$/_/; next if -e $out; open(FH, ">$out") or die "Can't create file $out: $!"; print FH <$cc") or die "Can't create file $cc: $!"; print FH < [ qw( ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( ); our $VERSION = '0.06'; require XSLoader; XSLoader::load('Goo::Canvas', $VERSION); # FIXME: Why ancestor not added? push @ISA, 'Gtk2::Container'; # Preloaded methods go here. 1; __END__ # documents. =head1 NAME Goo::Canvas - Perl interface to the GooCanvas =head1 SYNOPSIS use Goo::Canvas; use Gtk2 '-init'; use Glib qw(TRUE FALSE); my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); my $swin = Gtk2::ScrolledWindow->new; $swin->set_shadow_type('in'); $window->add($swin); my $canvas = Goo::Canvas->new(); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $swin->add($canvas); my $root = $canvas->get_root_item(); my $rect = Goo::Canvas::Rect->new( $root, 100, 100, 400, 400, 'line-width' => 10, 'radius-x' => 20, 'radius-y' => 10, 'stroke-color' => 'yellow', 'fill-color' => 'red' ); $rect->signal_connect('button-press-event', \&on_rect_button_press); my $text = Goo::Canvas::Text->new( $root, "Hello World", 300, 300, -1, 'center', 'font' => 'Sans 24', ); $text->rotate(45, 300, 300); $window->show_all(); Gtk2->main; sub on_rect_button_press { print "Rect item pressed!\n"; return TRUE; } =head1 DESCRIPTION GTK+ does't has an buildin canvas widget. GooCanvas is wonderful. It is easy to use and has powerful and extensible way to create items in canvas. Just try it. For more documents, please read GooCanvas Manual and the demo programs provided in the source distribution in both perl-Goo::Canvas and GooCanvas. =head1 SEE ALSO L(3pm) =head1 AUTHOR Ye Wenbin Ewenbinye@gmail.comE =head1 COPYRIGHT AND LICENSE Copyright (C) 2007 by ywb This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut Goo-Canvas-0.06/bin/0000755000175000017500000000000011200440442012317 5ustar ywbywbGoo-Canvas-0.06/bin/perlmine.pl0000755000175000017500000006144610721147511014515 0ustar ywbywb#!/usr/bin/perl -w # mine --- # Last modify Time-stamp: # Version: v 0.0 2007/11/04 12:35:20 # Author: Ye Wenbin use strict; use warnings; #{{{ Localization package Mine::L18N; use base qw(Locale::Maketext); package Mine::L18N::zh_cn; use base qw(Mine::L18N); our %Lexicon = ( 'Rows' => '行数', 'Columns' => '列数', 'Mines' => '地雷数', '_Junior' => '初级(J)', '_Senior' => '中级(S)', '_Advance' => '高级(A)', '_Rank' => '积分板(_R)', '_File' => '文件(_F)', '_Setting' => '设置(_S)', '_Help' => '帮助(_H)', 'Ye Wenbin' => '叶文彬', '_AUTO' => 1, ); package Mine::L18N::en; use base qw(Mine::L18N); our %Lexicon = ( '_Junior' => '_Junior', '_Senior' => '_Senior', '_Advance' =>'_Advance', '_Rank' => '_Rank', '_File' => '_File', '_Setting' => '_Setting', '_Help' => '_Help', '_AUTO' => 1, ); #}}} #{{{ package Cell # 一个 mine 有这种状态: # - 按钮盖住 cover # - 盖住有旗标 flag # - 盖住有问号 question # - 打开爆炸 boom # - 打开错误 wrong # - 打开炸弹 mine # - 打开数字 number # 游戏的状态如下: # waiting: # - 计时停止 # - 点击进入 start 状态 # start: # - 计时开始 # - 当打开炸弹时进入 stop 状态 # - 当未打开的格子数等于炸弹数时胜利,进入 stop 状态 # stop: # - 计时停止 # - 点击无效 # - 单击开始按钮进入 waiting 状态 package Mine::Cell; use Data::Dumper qw(Dumper); use Glib qw(TRUE FALSE); our @ISA = qw(Goo::Canvas::Group); our %pixbuf; our @color =( undef, 'blue', 'green', ('red') x 5, ); sub pixbuf { my ($name, $size) = @_; return $pixbuf{$name}{$size} if exists $pixbuf{$name}{$size}; $pixbuf{$name}{$size} = Gtk2::Gdk::Pixbuf->new_from_file_at_scale( $main::image{$name}, $size, $size, 1 ); } sub new { my $_class = shift; my $class = ref $_class || $_class; my ($root, $color, $x, $y, %options) = @_; my %def_opts = ( '-size' => 16, '-bgcolor' => 'grey90', ); foreach ( keys %def_opts ) { if ( exists $options{$_} ) { $def_opts{$_} = $options{$_}; delete $options{$_}; } } my $size = $def_opts{-size}; my $self = Goo::Canvas::Group->new($root); Goo::Canvas::Rect->new( $self, 0, 0, $size-1, $size-1, 'line-width' => 0, 'fill-color' => $def_opts{-bgcolor}, ); my $pixbuf; unless ( ref $color ) { if ( $color =~ /^#/ ) { $color = hex2rgb($color); } else { $color = Gtk2::Gdk::Color->parse($color); $color = [ map {$_/257} $color->red, $color->green, $color->blue]; } } $pixbuf = Gtk2::Gdk::Pixbuf->new_from_xpm_data( @{xpm_data( rgb2hex(map {0.6*$_} @$color), rgb2hex(map {0.8*$_} @$color), rgb2hex(@$color), )} ); $self->{background} = Goo::Canvas::Image->new( $self, $pixbuf, 0, 0, %options ); $self->translate($x, $y); $self->{size} = $def_opts{-size}; $self->{status} = 'cover'; bless $self, $class; } sub coords { my $self = shift; if ( @_ ) { $self->{coords} = [@_]; } return @{$self->{coords}}; } sub get_status { return shift->{status}; } sub remove { my $self = shift; my @item; if ( @_ ) { @item = @_; } else { @item = ( 'boom', 'flag', 'question', 'mine', 'wrong', 'number' ); } foreach (@item) { if ( exists $self->{$_} && $self->{$_} ) { $self->remove_child( $self->find_child($self->{$_}) ); delete $self->{$_}; } } } sub set_status { my $self = shift; my $status = shift; my $size = $self->{size}; if ( $status eq 'cover' ) { $self->remove(); $self->{background}->set('visibility'=>'visible'); } elsif ( $status eq 'flag' ) { return FALSE if $self->{status} ne 'cover'; $self->{flag} = Goo::Canvas::Image->new( $self, pixbuf('flag', $size), 0, 0, ); } elsif ( $status eq 'question' ) { return FALSE if ($self->{status} ne 'flag'); $self->remove('flag'); $self->{question} = Goo::Canvas::Text->new( $self, "?", $self->{size}/2, $self->{size}/2, -1, 'center' ); } elsif ( $status eq 'mine' ) { $self->remove(); $self->{background}->set('visibility'=>'hidden'); $self->{mine} = Goo::Canvas::Image->new( $self, pixbuf('mine', $size), 0, 0 ); } elsif ( $status eq 'boom' ) { return FALSE if $self->{status} ne 'mine'; $self->{boom} = Goo::Canvas::Ellipse->new( $self, $size/2, $size/2, $size/4, $size/4, 'line-width' => 0, 'fill-color' => 'red', ); } elsif ( $status eq 'wrong' ) { return FALSE if $self->{status} ne 'mine'; my $item = Goo::Canvas::Group->new($self); Goo::Canvas::Polyline->new_line( $item, 0, 0, $size, $size, 'stroke-color' => 'red', ); Goo::Canvas::Polyline->new_line( $item, 0, $size, $size, 0, 'stroke-color' => 'red', ); $self->{wrong} = $item; } elsif ( $status eq 'number' ) { return FALSE unless ($self->{status} eq 'cover' || $self->{status} eq 'question'); my $num = shift(@_); $self->remove(); $self->{background}->set('visibility'=>'hidden'); $self->{number} = Goo::Canvas::Text->new( $self, $num, $self->{size}/2, $self->{size}/2, -1, 'center', 'fill-color' => $color[$num], ); } elsif ( $status eq 'open' ) { $self->remove(); $self->{background}->set('visibility'=>'hidden'); } else { print "Unknown status!\n"; return FALSE; } $self->{status} = $status; return 1; } sub rgb2hex { my ($r, $g, $b) = @_; return sprintf("#%02x%02x%02x", $r, $g, $b); } sub hex2rgb { my $hex = shift; map { hex } substr($hex, 1) =~ /(..)/g; } sub xpm_data { my ($col1, $col2, $col3) = @_; return [split /\n/, < 16; sub new { my $_class = shift; my $class = ref $_class || $_class; my ($root, $x, $y, %options) = @_; my $self = Goo::Canvas::Group->new($root); bless $self, $class; for ( qw/columns rows/ ) { $self->{$_} = $options{'-'.$_}; } $self->{table} = []; $self->{bgcolor} = $options{-bgcolor} || 'grey90'; $self->{gridcolor} = $options{-gridcolor} || 'grey60'; $self->{color} = $options{-color} || 'white'; $self->{mines} = $options{-mines} || int(0.1*$self->{rows}*$self->{columns}); $self->{question} = ( exists $options{-question} ? $options{-question} : 1 ); $self->{flag_count} = $self->{mines}; $self->{unopen_count} = $self->{rows}*$self->{columns}; $self->draw_table(); $self->translate($x, $y); return $self; } sub flag_count { return shift->{flag_count}; } sub unopen_count { return shift->{unopen_count}; } sub mines { return shift->{mines}; } sub draw_table { my $self = shift; my ($sx, $sy) = $self->offset; my ($rows, $cols) = ($self->{rows}, $self->{columns}); my $color = $self->{color}; Goo::Canvas::Rect->new( $self, $sx, $sy, $sx+SIZE*$cols, $sy+SIZE*$rows, 'line-width' => 0, 'fill-color' => $self->{gridcolor} ); my @table; foreach my $c ( 1..$cols ) { foreach my $r ( 1..$rows ) { $table[$r-1][$c-1] = Mine::Cell->new( $self, $color, $sx+($c-1)*SIZE, $sy+($r-1)*SIZE, -size => SIZE, ); $table[$r-1][$c-1]->coords($r, $c); } } $self->{table} = \@table; } sub set_visible { my $self = shift; my ($row, $col, $visible) = @_; $self->{table}[$row-1][$col-1]->set_visible($visible); } sub offset { my $self = shift; if ( exists $self->{offset} ) { return @{$self->{offset}}; } else { return (1, 1); } } sub reset { my $self = shift; my $table = $self->{table}; my ($rows, $cols) = ($self->{rows}, $self->{columns}); my @mines = shuffle((1)x$self->{mines}, (0)x($rows*$cols-$self->{mines})); foreach my $i( 1..$rows ) { foreach my $j( 1..$cols ) { my $cell = $table->[$i-1][$j-1]; $cell->{has_mine} = $mines[($i-1)*$cols+$j-1]; $cell->set_status('cover'); } } $self->{flag_count} = $self->{mines}; $self->{unopen_count} = $rows*$cols; } sub open { my $self = shift; my ($row, $col) = @_; my $table = $self->{table}; my @open; push @open,$self->cell($row, $col); while ( @open ) { my $cell = pop @open; unless ( $cell->get_status =~ /^(cover|question)$/ ) { next; } if ( $cell->{has_mine} ) { $cell->set_status('mine'); $cell->set_status('boom'); foreach ( @{$table} ) { foreach ( @{$_} ) { next if $_->{status} eq 'boom'; if ( $_->{has_mine} ) { if ($_->{status} ne 'flag') { $_->set_status('mine'); } } elsif ( $_->{status} eq 'flag' ) { $_->set_status('mine'); $_->set_status('wrong'); } } } return TRUE; } else { my $adj = $self->neighbor($cell->coords); my $n = grep { $_->{has_mine} } @$adj; if ( $n ) { if ( $cell->set_status('number', $n) ) { $self->{unopen_count}--; } } else { if ($cell->set_status('open') ) { $self->{unopen_count}--; } push @open, grep {$_->{status} =~/^(cover|question)$/ } @$adj; } } } return FALSE; } sub set_flag { my $self = shift; my ($row, $col) = @_; my $cell = $self->cell($row, $col); my $s = $cell->get_status; return if $s =~ /open|number/; my @status = qw/flag cover/; if ( $self->{question} ) { unshift @status, 'question'; } my $i = 0; while ( $i <= $#status ) { last if $s eq $status[$i]; $i++; } return if $i > 2; $cell->set_status($status[$i-1]); if ( $status[$i-1] eq 'flag' ) { $self->{flag_count}--; } elsif ( $s eq 'flag' ) { $self->{flag_count}++; } } sub neighbor { my $self = shift; my ($row, $col) = @_; my ($rows, $cols) = ($self->{rows}, $self->{columns}); my @r = max(1, $row-1) .. min($row+1, $rows); my @c = max(1, $col-1) .. min($col+1, $cols); my @ne; for my $r ( @r ) { for my $c ( @c ) { next if ($r==$row && $c == $col); push @ne, $self->cell($r, $c); } } return \@ne; } sub open_others { my $self = shift; my ($row, $col) = @_; my $cell = $self->cell($row, $col); return unless $cell->get_status eq 'number'; my $ne = $self->neighbor($row, $col); my $n = grep { $_->get_status eq 'flag' } @$ne; my $b = grep { $_->{has_mine} } @$ne; return if $n != $b; my $boom; foreach ( @$ne ) { next if $_->get_status eq 'flag'; $boom = $self->open($_->coords); last if $boom; } return $boom; } sub cell { my $self = shift; my ($row, $col) = @_; my ($rows, $cols) = ($self->{rows}, $self->{columns}); if ( $row > $rows || $row < 1 || $col > $cols || $col < 1 ) { die "row or col out of range ($row, $col) in ($rows, $cols)\n"; } return $self->{table}[$row-1][$col-1]; } #}}} #{{{ package main package main; use Goo::Canvas; use constant { START => 0, WAITING => 1, STOP => 2, MAXROWS => 40, MAXCOLS => 40, MAXMINES => 400, }; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use FindBin qw($Bin); use Data::Dumper qw(Dumper); use Encode qw(encode decode); use File::Spec::Functions; our $lh = Mine::L18N->get_handle() || Tetris::L18N->get_handle('en'); sub gettext { return decode('utf8', $lh->maketext(@_)) } our %Config = ( rows => 10, cols => 10, mines => 10, image_directory => '.', level => { 'junior' => [10, 10, 10], 'senior' => [15, 20, 45], 'advance'=> [20, 30, 100], }, 'use_question_flag' => 0, ); our $history; our $DEBUG = 0; my $config_file; my $home; my $default_conf_file = ".perlmine"; eval { require File::HomeDir }; if ( $@ ) { $home = $ENV{HOME} || $Bin; } else { $home = File::HomeDir->my_home; } if ( -e "$home/$default_conf_file" ) { $config_file = "$home/$default_conf_file"; eval { require $config_file }; if ( $@ ) { print STDERR "Error when load config file: $@!\n"; } } else { eval { require Mine::Config; }; $config_file = $INC{'Mine/Config.pm'}; } if ( !$config_file ) { $config_file = "$home/$default_conf_file"; } our $game_status; our $elapse_time = 0; our $timer; $Data::Dumper::Indent = 1; $| = 1; our %image = ( 'smile' => catfile($Config{image_directory}, 'face-smile.png'), 'win' => catfile($Config{image_directory}, 'face-win.png'), 'sad' => catfile($Config{image_directory}, 'face-sad.png'), 'mine' => catfile($Config{image_directory}, 'mine.svg'), 'flag' => catfile($Config{image_directory}, 'flag.svg'), ); my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); my $vbox = Gtk2::VBox->new(); my $menu = create_menu(); # box for buttons and labels my $btab = Gtk2::Table->new(1, 3, FALSE); my $timer_label = Gtk2::Label->new(); $btab->attach_defaults($timer_label, 0, 1, 0, 1); my $image_but = Gtk2::Button->new; $image_but->signal_connect( 'clicked' => \&start_game ); $image_but->set('relief' => 'none'); $btab->attach_defaults($image_but, 1, 2, 0, 1); my $count_label = Gtk2::Label->new(); $btab->attach_defaults($count_label, 2, 3, 0, 1); my $canvas = Goo::Canvas->new; setup_canvas(); for ( $menu, $btab, $canvas ) { $vbox->pack_start($_, FALSE, FALSE, 0); } $window->add($vbox); $window->show_all; start_game(); Gtk2->main; sub END { write_history(); } #}}} #{{{ create menu and canvas sub create_menu { my $menu_bar = Gtk2::MenuBar->new; # File my $file_menu = Gtk2::Menu->new; # |- junior my $junior_menuitem = Gtk2::MenuItem->new_with_label( gettext('_Junior') ); $junior_menuitem->signal_connect('activate' => \&set_level, $Config{level}{junior} ); $file_menu->append($junior_menuitem); # |- senior my $senior_menuitem = Gtk2::MenuItem->new_with_label( gettext('_Senior') ); $senior_menuitem->signal_connect('activate' => \&set_level, $Config{level}{senior} ); $file_menu->append($senior_menuitem); # |- advance my $advance_menuitem = Gtk2::MenuItem->new_with_label( gettext('_Advance') ); $advance_menuitem->signal_connect('activate' => \&set_level, $Config{level}{advance} ); $file_menu->append($advance_menuitem); # |- Exit my $exit_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-quit', undef); $exit_menuitem->signal_connect('activate' => sub { Gtk2->main_quit }); $file_menu->append($exit_menuitem); # Setting my $setting_menu = Gtk2::Menu->new; # |- Settings my $setting_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-preferences', undef); $setting_menuitem->signal_connect('activate' => \&setting); $setting_menu->append($setting_menuitem); # Help my $help_menu = Gtk2::Menu->new; # |- About my $about_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-about', undef); $about_menuitem->signal_connect('activate' => \&about); $help_menu->append($about_menuitem); my $file_menuitem = Gtk2::MenuItem->new(gettext("_File")); $file_menuitem->set_submenu($file_menu); $menu_bar->append( $file_menuitem ); my $setting_menuitem2 = Gtk2::MenuItem->new(gettext("_Setting")); $setting_menuitem2->set_submenu($setting_menu); $menu_bar->append($setting_menuitem2); my $help_menuitem = Gtk2::MenuItem->new(gettext("_Help")); $help_menuitem->set_submenu($help_menu); $menu_bar->append($help_menuitem); return $menu_bar; } sub about { my $dia = Gtk2::AboutDialog->new(); $dia->set_authors(gettext('Ye Wenbin')); $dia->run; $dia->destroy; } sub setup_canvas { my $root = Goo::Canvas::Group->new; my ($rows, $cols) = ($Config{rows}, $Config{cols}); my ($xpad, $ypad) = ( 10, 10 ); my $border = 1; $canvas->{table} = Mine::Table->new( $root, $xpad, $ypad, -columns => $cols, -rows => $rows, -border => $border, -mines => $Config{mines}, -question => $Config{use_question_flag}, ); foreach ( @{$canvas->{table}{table}} ) { foreach ( @{$_} ) { $_->signal_connect( 'button-press-event' => \&open_cell ); } } $canvas->set_root_item($root); $canvas->set_size_request( $xpad * 2 + Mine::Table::SIZE * $cols, $ypad * 2 + Mine::Table::SIZE * $rows); } sub setting { my $dia = Gtk2::Dialog->new( gettext('Setting'), $window, 'modal', 'gtk-ok' => 'ok', 'gtk-cancel' => 'cancel', ); my $vbox = $dia->vbox; my $table = Gtk2::Table->new(2, 2); my ($label, $row_but, $col_but, $mines_but); $label = Gtk2::Label->new(gettext("Rows")); $row_but = Gtk2::SpinButton->new_with_range(1, MAXROWS, 1); $row_but->set_value($Config{rows}); $table->attach_defaults($label, 0, 1, 0, 1); $table->attach_defaults($row_but, 1, 2, 0, 1); $label = Gtk2::Label->new(gettext("Columns")); $col_but = Gtk2::SpinButton->new_with_range(1, MAXROWS, 1); $col_but->set_value($Config{cols}); $table->attach_defaults($label, 0, 1, 1, 2); $table->attach_defaults($col_but, 1, 2, 1, 2); $label = Gtk2::Label->new(gettext("Mines")); $mines_but = Gtk2::SpinButton->new_with_range(1, MAXMINES, 1); $mines_but->set_value($Config{mines}); $table->attach_defaults($label, 0, 1, 2, 3); $table->attach_defaults($mines_but, 1, 2, 2, 3); $vbox->add($table); $vbox->show_all(); my $response = $dia->run; if ( $response eq 'ok' ) { set_level(undef, [$row_but->get_value, $col_but->get_value, $mines_but->get_value]); } $dia->destroy; } #}}} sub start_game { $game_status = WAITING; if ( $timer ) { Glib::Source->remove($timer); $elapse_time = 0; } setup_canvas(); my $table = $canvas->{table}; $table->reset; set_count_label( $table->flag_count ); set_timer_label(); $image_but->set_image(Gtk2::Image->new_from_file($image{'smile'})); return FALSE; } sub update_label { $elapse_time++; set_timer_label(); return TRUE; } sub open_cell { return FALSE if $game_status == STOP; if ( $game_status == WAITING ) { $game_status = START; $elapse_time = 0; $timer = Glib::Timeout->add(1000, \&update_label); } my ($cell, $target, $ev ) = @_; if ( $DEBUG ) { # print "x, y: (", join(', ', $ev->x, $ev->y), ")\n"; print "row, col: (", join(", ", $cell->coords), ")\n"; } my $boom; my $table = $canvas->{table}; if ( $ev->button == 1 ) { # left button $boom = $table->open($cell->coords); } elsif ( $ev->button == 2) { # middle button $boom = $table->open_others($cell->coords); } elsif ( $ev->button == 3 ) { # right button $table->set_flag($cell->coords); set_count_label($table->flag_count); } if ( $boom ) { stop_game(); } if ( $table->unopen_count == $table->mines ) { win(); } return FALSE; } sub set_count_label { my ($cnt) = @_; $count_label->set_markup(sprintf("%3d/%d", $cnt, $Config{mines})); } sub set_timer_label { $timer_label->set_markup(sprintf("%3d", $elapse_time)); } sub set_level { my ($wid, $data) = @_; $Config{rows} = $data->[0]; $Config{cols} = $data->[1]; $Config{mines} = $data->[2]; if ( $Config{mines} > $Config{rows} * $Config{cols} ) { warn "Mines more than cells of the table!\n"; $Config{mines} = 0.1 * $Config{rows} * $Config{cols}; } setup_canvas(); start_game(); return FALSE; } sub stop_game { $game_status = STOP; Glib::Source->remove($timer); $image_but->set_image(Gtk2::Image->new_from_file($image{'sad'})); } sub win { if ( $DEBUG ) { print "You win!\n"; } $game_status = STOP; Glib::Source->remove($timer); $image_but->set_image(Gtk2::Image->new_from_file($image{'win'})); return; my $new_entry = [$Config{name} || getlogin || getpwuid($<) || 'Nobody', $elapse_time]; my ($idx, $new_iter); if ( $#$history > 8 ) { $#$history = 8; } push @$history, $new_entry; $idx = $#$history; my $dia = Gtk2::Dialog->new( 'Rank', undef, # $window, ['modal', 'destroy-with-parent'], 'gtk-ok' => 'ok', ); my $vbox = $dia->vbox; my $store = Gtk2::ListStore->new( qw/Glib::String Glib::Int/ ); foreach ( 0..$#$history ) { my $iter = $store->append(); $store->set($iter, 0, $history->[$_][0], 1, $history->[$_][1], ); if ( $idx == $_ ) { $new_iter = $iter; } } my $treeview = Gtk2::TreeView->new($store); my $col = Gtk2::TreeViewColumn->new(); $col->set_title('name'); my $ren = Gtk2::CellRendererText->new; $ren->set_property('editable' => TRUE); $ren->{'renderer_number'} = 0; $ren->signal_connect( edited => sub { my ($cell, $path_string, $new_text) = @_; $new_entry->[0] = $new_text; $store->set($new_iter, 0, $new_text); $cell->set_property('editable' => FALSE); return FALSE; } ); $col->pack_start($ren, FALSE); $col->add_attribute($ren, text=>0); $treeview->append_column($col); my $col2 = Gtk2::TreeViewColumn->new(); $col2->set_title('score'); my $ren2 = Gtk2::CellRendererText->new; $col2->pack_start($ren2, FALSE); $col2->add_attribute($ren2, text=>1); $treeview->append_column($col2); $vbox->pack_start($treeview, FALSE, FALSE, 0); $dia->show_all; $treeview->set_cursor($store->get_path($new_iter), $col, TRUE); $dia->signal_connect( response => sub { $dia->destroy; return FALSE; } ); } sub write_history { my $str; my $found_mark; open(my $out, ">", \$str) or die "Can't write to string: $!\n"; my $start_mark = "# HISTORY: Don't edit from this line to the line marked with END HISTORY."; my $end_mark = "# END HISTORY"; my $conf = $start_mark . "\n" . Data::Dumper->Dump([$history], ['history']) . $end_mark . "\n"; if ( -e $config_file ) { open(my $fh, $config_file) or die "Can't open file $config_file: $!"; while ( <$fh> ) { if ( /\Q$start_mark/ ) { $found_mark = 1; while ( <$fh>) { last if /\Q$end_mark/; } print $out $conf; } else { print $out $_; } } close($fh); } if ( !$found_mark ) { print $out $conf; print $out "1;\n"; } close($out); open(my $fh, ">$config_file") or die "Can't create file $config_file: $!"; print $fh $str; close($fh); } __END__ =head1 NAME perlmine - A game to clear hidden mines from a minefield =head1 SYNOPSIS perl perlmine.pl =head1 DESCRIPTION An example of config file: # -*- perl -*- # ~/.perlmine use utf8; %Config = ( %Config, rows => 10, cols => 10, mines => 10, image_directory => '/usr/share/pixmaps/gnomine', name => '叶文彬', ); =cut Goo-Canvas-0.06/bin/perltetris.pl0000755000175000017500000007774310715353555015120 0ustar ywbywb#!/usr/bin/perl -w # Last modify Time-stamp: # Version: v 0.0 2007/11/02 08:25:10 # Author: Ye Wenbin use strict; use warnings; package Tetris::L18N; use base qw(Locale::Maketext); package Tetris::L18N::zh_cn; use base qw(Tetris::L18N); our %Lexicon = ( 'Scores' => '得分', 'Lines' => '行数', 'Level' => '级别', '_Rank' => '积分板(_R)', '_File' => '文件(_F)', '_Setting' => '设置(_S)', '_Help' => '帮助(_H)', "Cancel current game?" => '关闭当前运行的游戏吗?', 'Start level' => '初始等级', 'Ye Wenbin' => '叶文彬', '_AUTO' => 1, ); package Tetris::L18N::en; use base qw(Tetris::L18N); our %Lexicon = ( '_File' => '_File', '_Rank' => '_Rank', '_Setting' => '_Setting', '_Help' => '_Help', '_AUTO' => 1, ); #{{{ package Cell package Tetris::Cell; use Gtk2; use Goo::Canvas; use constant SIZE => 16; our @ISA = qw(Goo::Canvas::Image); sub new { my $_class = shift; my $class = ref $_class || $_class; my ($root, $color, $x, $y, %options) = @_; my $pixbuf; unless ( ref $color ) { if ( $color =~ /^#/ ) { $color = hex2rgb($color); } else { $color = Gtk2::Gdk::Color->parse($color); $color = [ map {$_/257} $color->red, $color->green, $color->blue]; } } if ( $options{-plan} ) { $pixbuf = xpm_data((rgb2hex(@$color)) x 3); delete $options{-plan}; } else { $pixbuf = xpm_data( rgb2hex(map {0.6*$_} @$color), rgb2hex(map {0.8*$_} @$color), rgb2hex(@$color), ); } $pixbuf = Gtk2::Gdk::Pixbuf->new_from_xpm_data(@$pixbuf); my $self = Goo::Canvas::Image->new($root, $pixbuf, $x, $y, %options); bless $self, $class; } sub rgb2hex { my ($r, $g, $b) = @_; return sprintf("#%02x%02x%02x", $r, $g, $b); } sub hex2rgb { my $hex = shift; map { hex } substr($hex, 1) =~ /(..)/g; } sub xpm_data { my ($col1, $col2, $col3) = @_; return [split /\n/, <new($root); bless $self, $class; for ( qw/columns rows/ ) { $self->{$_} = $options{'-'.$_}; } $self->{table} = []; $self->{bgcolor} = $options{-bgcolor} || 'black'; if ( $options{-border} ) { $self->{border_color} = $options{-border_color} || 'grey50'; $self->{offset} = [(Tetris::Cell::SIZE) x 2]; $self->draw_border(); } $self->draw_table(); $self->translate($x, $y); return $self; } sub draw_border { my $self = shift; my ($rows, $cols) = ($self->{rows}, $self->{columns}); my $color = $self->{border_color}; foreach ( 1..($cols+2) ) { Tetris::Cell->new($self, $color, ($_-1)*Tetris::Cell::SIZE, 0); Tetris::Cell->new($self, $color, ($_-1)*Tetris::Cell::SIZE, ($rows+1)*Tetris::Cell::SIZE); } foreach ( 1..$rows ) { Tetris::Cell->new($self, $color, 0, $_*Tetris::Cell::SIZE); Tetris::Cell->new($self, $color, ($cols+1)*Tetris::Cell::SIZE, $_*Tetris::Cell::SIZE); } } sub draw_table { my $self = shift; my ($sx, $sy) = $self->offset; my ($rows, $cols) = ($self->{rows}, $self->{columns}); my $color = $self->{bgcolor}; my @table; foreach my $i ( 1..$cols ) { foreach my $j ( 1..$rows ) { $table[$i-1][$j-1] = Tetris::Cell->new( $self, $color, $sx+($i-1)*Tetris::Cell::SIZE, $sy+($j-1)*Tetris::Cell::SIZE, ); } } $self->{bgtable} = \@table; } sub check_pos { my $self = shift; my ($rows, $cols) = ($self->{rows}, $self->{columns}); my ($row, $col) = @_; if ( $row < 1 || $row > $rows ) { return; } if ( $col < 1 || $col > $cols ) { return; } return 1; } sub put_cell { my $self = shift; my ($row, $col, %options) = @_; unless ( $self->check_pos($row, $col) ) { return; } for ( $row, $col ) { $_--; } my $table = $self->{table}; my ($sx, $sy) = $self->offset(); if ( $table->[$row][$col] ) { $self->remove_cell($row, $col); } my $color = $options{-color}; delete $options{-color}; return $table->[$row][$col] = Tetris::Cell->new( $self, $color, $sx+$col*Tetris::Cell::SIZE, $sy+$row*Tetris::Cell::SIZE, %options ); } sub offset { my $self = shift; if ( exists $self->{offset} ) { return @{$self->{offset}}; } else { return (0, 0); } } sub remove_cell { my $self = shift; my ($row, $col) = @_; unless ( $self->check_pos($row, $col) ) { return; } for ( $row, $col ) { $_--; } my $table = $self->{table}; my $item = $table->[$row][$col]; if ( $item ) { $self->remove_child($self->find_child($item)); $table->[$row][$col] = undef; return 1; } } sub move_cell { my $self = shift; my ($row, $col, $newrow, $newcol) = @_; unless ( $self->check_pos($row, $col) && $self->check_pos($newrow, $newcol) ) { return; } for ( $row, $col, $newrow, $newcol ) { $_--; } my ($rows, $cols) = ($self->{rows}, $self->{columns}); my $table = $self->{table}; my $item = $table->[$row][$col]; if ( $item ) { if ( $self->{table}[$newrow][$newcol] ) { $self->remove_cell($newrow+1, $newcol+1); } # print "Move $item from $row $col to $newrow $newcol\n"; $item->translate( ($newcol-$col)*Tetris::Cell::SIZE, ($newrow-$row)*Tetris::Cell::SIZE, ); $table->[$newrow][$newcol] = $item; $table->[$row][$col] = undef; } } sub table { return shift->{table}; } sub cell { my $self = shift; my ($row, $col) = @_; unless ( $self->check_pos($row, $col) ) { return; } return $self->{table}[$row-1][$col-1]; } sub rows { return shift->{rows}; } sub columns { return shift->{columns}; } sub eliminate_line { my $self = shift; my %lines = map { $_=>1 } @_; return unless %lines; # print "eliminate_line @_\n"; my $line = max(keys %lines); my $down = 0; my $cols = $self->columns; my $table = $self->table; while ( $line > 0 ) { if ( exists $lines{$line} ) { $self->remove_cell($line, $_) for 1..$cols; $down++; } elsif ( $down ) { $self->move_cell($line, $_, $line+$down, $_) for 1..$cols; } $line--; } return $down; } sub eliminate_line_maybe { my $self = shift; my @lines = @_; $self->eliminate_line( grep { $self->test_fill($_); } @lines ); } sub test_fill { my $self = shift; my $line = shift; $line--; my $fill = 1; my $cols = $self->columns; my $table = $self->table; foreach ( 1..$cols ) { if ( !defined $table->[$line][$_-1] ) { $fill = 0; last; } } return $fill; } sub clear { my $self = shift; my $table = $self->{table}; my ($rows, $cols) = ($self->{rows}, $self->{columns}); foreach my $i( 1..$rows ) { foreach my $j( 1..$cols ) { $self->remove_cell($i, $j); } } $self->{table} = []; } sub is_full { my $self = shift; my $full = 0; my $table = $self->{table}; foreach ( @{$table->[0]} ) { if ( $_ ) { $full = 1; last; } } return $full; } #}}} #{{{ package Shape package Tetris::Shape; use List::Util qw(min max sum); use Data::Dumper qw(Dumper); sub new { my $_class = shift; my $class = ref $_class || $_class; my $self = {}; bless $self, $class; my %options = @_; foreach ( keys %options ) { next unless /^-/; $self->{substr($_, 1)} = $options{$_}; } return $self; } sub draw { my $self = shift; my $shape = $self->{shape}[$self->{type}]; my $i = $#$shape; while ( $i>-1 && !grep {$_>0} @{$shape->[$i]} ) { $i--; } my $table = $self->{table}; my $color = $self->{color}; my ($row, $col) = ($self->{row}, $self->{col}); if ( !defined $row ) { # if no row give, put the shape visible my @r = map { sum(@{$_}) } @{$shape}; my $i = $#r; while ( $i>-1 ) { last if $r[$i]>0; $i--; } $row = -$i+1; $self->{row} = $row; } my @cells; foreach my $r( @$shape ) { foreach ( 0..$#$r ) { if ( $r->[$_] > 0 ) { my $put = 0; if ( $row > 0 ) { # print "$table $row, $col+$_, $color\n"; $table->put_cell($row, $col+$_, -color => $color); $put = 1; } push @cells, [$row, $col+$_, $put]; } } $row++; } $self->{cells} = \@cells; } sub move_down { my $self = shift; if ( $self->hit_test(1, 0) ) { return 1; } my $cells = $self->{cells}; my $table = $self->{table}; my $color = $self->{color}; foreach ( sort { $b->[0]<=>$a->[0] } @$cells ) { # move the max row first my ($r, $c, $put) = @{$_}; if ( $put ) { $table->move_cell($r, $c, $r+1, $c); } elsif ( $r >= 0 ) { $table->put_cell($r+1, $c, -color => $color); $_->[2] = 1; } $_->[0]++; } $self->{row}++; return 0; } sub move_left { my $self = shift; my $cells = $self->{cells}; my $table = $self->{table}; if ( $self->hit_test(0, -1) ) { return; } foreach ( sort {$a->[1] <=> $b->[1] } @$cells ) { my ($r, $c, $put) = @{$_}; if ( $put ) { $table->move_cell($r, $c, $r, $c-1); } $_->[1]--; } $self->{col}--; } sub move_right { my $self = shift; my $cells = $self->{cells}; my $table = $self->{table}; if ( $self->hit_test(0, 1) ) { return; } foreach ( sort {$b->[1]<=>$a->[1] } @$cells ) { my ($r, $c, $put) = @{$_}; if ( $put ) { $table->move_cell($r, $c, $r, $c+1); } $_->[1]++; } $self->{col}++; } sub rotate { my $self = shift; my $cells = $self->{cells}; my $shapes = $self->{shape}; my $table = $self->{table}; my $type = $self->{type}; # backup my $col = $self->{col}; # backup my $cols = $table->columns; $self->{type} = ($type+1) % scalar(@$shapes); my ($hit, $collide_cells) = $self->hit_test(0, 0); # print Dumper($hit, $collide_cells), "\n"; if ( $hit ) { my $reason = 0; my @cols = sort {$a<=>$b} map {$_->[1]} @$collide_cells; if ( $cols[0] < 1 ) { $self->{col} = $self->{col} + (1-$cols[0]); } elsif ( $cols[-1] > $cols ) { $self->{col} = $col - ($cols[-1]-$cols); } else { $self->{type} = $type; $self->{col} = $col; return; } if ( $self->hit_test(0, 0) ) { $self->{type} = $type; $self->{col} = $col; return; } } # main::dump_table($table->{table}); # print join("\n", map {join("\t", @{$_})} @$cells), "\n"; foreach ( @$cells ) { $table->remove_cell($_->[0], $_->[1]) if $_->[2]; } $self->draw(); # main::dump_table($table->{table}); # print join("\n", map {join("\t", @{$_})} @$cells), "\n"; } sub hit_test { my $self = shift; my ($dx, $dy) = @_; my ($row, $col) = ($self->{row}, $self->{col}); $row += $dx; $col += $dy; my @cells; my $collides = 0; my $table = $self->{table}; my $shape = $self->{shape}[$self->{type}]; my %cells; map { $cells{$_->[0]}{$_->[1]} = 1 } @{$self->{cells}}; foreach my $r ( @$shape ) { foreach ( 0..$#$r ) { if ( $r->[$_] > 0 ) { next if exists $cells{$row}{$col+$_}; if ($row>$table->rows || $col+$_ > $table->columns || $col+$_ < 1 || $table->cell($row, $col+$_)) { push @cells, [$row, $col+$_]; # print "$row, $col+$_\n"; $collides = 1; } } } $row++; } if ( wantarray ) { return ($collides, \@cells); } else { return $collides; } } sub cells { return shift->{cells}; } #}}} package main; use List::Util qw(min max sum); use Goo::Canvas; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use FindBin qw($Bin); use Data::Dumper qw(Dumper); use Encode qw(encode decode); our $lh = Tetris::L18N->get_handle() || Tetris::L18N->get_handle('en'); sub gettext { return decode('utf8', $lh->maketext(@_)) } #{{{ Configuration our $history; our $shapes = parse_shapes(); our $next_shape; our $timer; our $timer_pause; our $game_start; our $after_load_function; our %Config = ( keybindings => { 65361 => \&move_left, # left 65362 => \&rotate, # up 65363 => \&move_right, # right 65364 => \&move_down, # down ord(' ') => \&down, # space ord('p') => \&pause, # p 65293 => \&new_game, # enter }, rows => 20, cols => 10, style => [ 'blue', 'purple', 'yellow', 'magenta', 'cyan', 'green', 'red', 'deeppink', 'hotpink', 'skyblue', 'gold', ], start_level => 0, down_step => 3, max_rank_list => 10, ); my $default_conf_file = ".perltetris"; my $config_file; my $home; eval { require File::HomeDir }; if ( $@ ) { $home = $ENV{HOME} || $Bin; } else { $home = File::HomeDir->my_home; } if ( -e "$home/.tetris" ) { $config_file = "$home/$default_conf_file"; eval { require "$home/$default_conf_file" }; if ( $@ ) { print STDERR "Error when load config file $home/$default_conf_file: $@\n"; } } else { eval { require Tetris::Config; }; $config_file = $INC{'Tetris/Config.pm'}; } our ($score, $lines, $level) = (0, 0, $Config{start_level}); #}}} our $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); our $vbox = Gtk2::VBox->new(); our $menu = create_menu(); our $canvas = create_canvas(); $vbox->add($menu); $vbox->add($canvas); $window->add($vbox); $window->show_all; if ( defined $after_load_function && ref $after_load_function eq 'CODE' ) { $after_load_function->(); } Gtk2->main; sub END { write_history(); } sub setting { return if $game_start; my $dia = Gtk2::Dialog->new( gettext('Setting'), $window, 'modal', 'gtk-ok' => 'ok', 'gtk-cancel' => 'cancel', ); my $vbox = $dia->vbox; my $table = Gtk2::Table->new(2, 2); my $label = Gtk2::Label->new(gettext("Start level")); my $but = Gtk2::SpinButton->new_with_range(0, 10, 1); $but->set_value($Config{start_level}); $table->attach_defaults($label, 0, 1, 0, 1); $table->attach_defaults($but, 1, 2, 0, 1); $vbox->add($table); $vbox->show_all(); score(0); my $response = $dia->run; if ( $response eq 'ok' ) { $Config{start_level} = $but->get_value; $level = $Config{start_level}; update_label(); } $dia->destroy; } sub about { return if $game_start; my $dia = Gtk2::AboutDialog->new(); $dia->set_authors(gettext('Ye Wenbin')); $dia->run; $dia->destroy; } sub stop_game { if ( $timer ) { Glib::Source->remove($timer); } remove_heading(); ($score, $lines, $level) = (0, 0, $Config{start_level}); update_label(); $canvas->{table}->clear; $canvas->{preview}->clear; $game_start = 0; } sub create_menu { my $menu_bar = Gtk2::MenuBar->new; # File my $file_menu = Gtk2::Menu->new; # |- New my $new_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-new', undef); $new_menuitem->signal_connect('activate' => \&new_game); $file_menu->append($new_menuitem); # |- Stop my $stop_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-close', undef); $stop_menuitem->signal_connect('activate' => \&stop_game); $file_menu->append($stop_menuitem); # |- Rank my $rank_menuitem = Gtk2::MenuItem->new_with_mnemonic(gettext('_Rank')); $rank_menuitem->signal_connect( 'activate' => sub { rank_dia() } ); $file_menu->append($rank_menuitem); # |- Exit my $exit_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-quit', undef); $exit_menuitem->signal_connect('activate' => sub { Gtk2->main_quit }); $file_menu->append($exit_menuitem); # Setting my $setting_menu = Gtk2::Menu->new; # |- Settings my $setting_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-preferences', undef); $setting_menuitem->signal_connect('activate' => \&setting); $setting_menu->append($setting_menuitem); # Help my $help_menu = Gtk2::Menu->new; # |- About my $about_menuitem = Gtk2::ImageMenuItem->new_from_stock('gtk-about', undef); $about_menuitem->signal_connect('activate' => \&about); $help_menu->append($about_menuitem); my $file_menuitem = Gtk2::MenuItem->new(gettext("_File")); $file_menuitem->set_submenu($file_menu); $menu_bar->append( $file_menuitem ); my $setting_menuitem2 = Gtk2::MenuItem->new(gettext("_Setting")); $setting_menuitem2->set_submenu($setting_menu); $menu_bar->append($setting_menuitem2); my $help_menuitem = Gtk2::MenuItem->new(gettext("_Help")); $help_menuitem->set_submenu($help_menu); $menu_bar->append($help_menuitem); return $menu_bar; } sub create_canvas { my $canvas = Goo::Canvas->new; $canvas->set_size_request(330, 400); my $root = $canvas->get_root_item; my ($rows, $cols) = ($Config{rows}, $Config{cols}); my $offset = [ 10, 10 ]; my $border = 1; my $padding = 16; $canvas->{table} = Tetris::Table->new( $root, $offset->[0], $offset->[1], -columns => $cols, -rows => $rows, -border => $border, ); my $px = $offset->[0]+($cols+( $border ? 2 : 0) )*Tetris::Cell::SIZE + $padding; $canvas->{preview} = Tetris::Table->new( $root, $px, $offset->[1], -columns => 4, -rows => 4, -border => $border, ); use_keymap( $window, $Config{keybindings} ); my $text_group = Goo::Canvas::Group->new($root); $text_group->translate( $px, $offset->[1] + 7 * Tetris::Cell::SIZE ); my $text_spacing = 20; my @label = ( Gtk2::Label->new(make_string('Scores', $score)), Gtk2::Label->new(make_string('Lines', $lines)), Gtk2::Label->new(make_string('Level', $level)), ); foreach ( 0..$#label ) { $label[$_]->set_alignment(0, 0); Goo::Canvas::Widget->new( $text_group, $label[$_], 0, $text_spacing*$_, 100, 20, ); } $canvas->{labels} = \@label; # $canvas->{labels} = [ # Goo::Canvas::Text->new( # $text_group, make_string('Scores', $score), 0, 0, -1, 'nw', # ), # Goo::Canvas::Text->new( # $text_group, make_string("Lines", $lines), 0, $text_spacing, -1, 'nw', # ), # Goo::Canvas::Text->new( # $text_group, make_string("Level", $level), 0, $text_spacing*2, -1, 'nw', # ) # ]; return $canvas; } sub make_string { my ($text, $num) = @_; my $str = gettext($text) . ": " . $num; return $str; } sub use_keymap { my ($wid, $keymap) = @_; if ( exists $wid->{keymap_sigid} ) { $wid->signal_handler_disconnect($wid->{keymap_sigid}); } $wid->{keymap_sigid} = $wid->signal_connect( 'key-press-event' => \&on_key_pressed, $keymap ); } sub on_key_pressed { my ($w, $ev, $keymap) = @_; my $key_nr = $ev->keyval; my $cb = $keymap->{$key_nr}; $cb->($w) if $cb; return FALSE; } sub new_game { if ( $game_start ) { local $timer_pause = 1; my $stop = 1; my $dia = Gtk2::MessageDialog->new( $window, 'destroy-with-parent', 'question', 'yes-no', gettext("Cancel current game?"), ); $dia->set_default_response('yes'); my $response = $dia->run(); $dia->destroy; if ( $response eq 'no' ) { return; } } remove_heading(); $timer_pause = 0; $game_start = 1; ($score, $lines, $level) = (0, 0, $Config{start_level}); update_label(); if ( $timer ) { Glib::Source->remove($timer); } $timer = Glib::Timeout->add(speed(), \&update); $canvas->{table}->clear; my $s = int(rand(scalar(@$shapes))); my $t = int(rand(scalar(@{$shapes->[$s]}))); $next_shape = [$s, $t]; new_shape(); } sub show_heading { my $text = shift; if ( exists $canvas->{heading} && $canvas->{heading} ) { $canvas->{heading}->set( 'text' => $text ); } else { $canvas->{heading} = Goo::Canvas::Text->new( $canvas->get_root_item, $text, 50, 200, -1, 'nw', 'font' => 'Sans Bold 24', 'fill-color' => 'red' ); } } sub remove_heading { if ( exists $canvas->{heading} && $canvas->{heading} ) { my $root = $canvas->get_root_item; $root->remove_child($root->find_child($canvas->{heading})); $canvas->{heading} = undef; } } sub new_shape { my $shape = Tetris::Shape->new( -shape => $shapes->[$next_shape->[0]], -type => $next_shape->[1], -color => $Config{style}[$next_shape->[0] % @{$Config{style}}], -col => int($Config{cols}/2)-2, -table => $canvas->{table}, ); $shape->draw(); $canvas->{shape} = $shape; # Draw preview my $s = int(rand(scalar(@$shapes))); my $t = int(rand(scalar(@{$shapes->[$s]}))); $next_shape = [$s, $t]; $canvas->{preview}->clear; $shape = Tetris::Shape->new( -shape => $shapes->[$s], -type => $t, -color => $Config{style}[$s % @{$Config{style}}], -row => 1, -col => 1, -table => $canvas->{preview}, ); $shape->draw(); } sub update { # print "update $timer_pause\n"; return TRUE if $timer_pause; my $shape = $canvas->{shape}; my $hit = $shape->move_down; if ( $hit ) { done(); } return TRUE; } sub done { my $shape = $canvas->{shape}; my $table = $canvas->{table}; my %row = map { $_->[0] => 1 } @{$shape->cells}; my $ln = $table->eliminate_line_maybe( keys %row ); score($ln); if ( $table->is_full ) { game_over(); } else { new_shape(); } } sub score { my $ln = shift || 0; my $oldscore = $score; my @score = ( 0, 10, 20, 40, 60 ); # my @score = ( 0, 20, 40, 70, 100 ); $score += $score[$ln]; $lines += $ln; if ( int($score/100) > int($oldscore/100) ) { # print "levelup $level at $score\n"; $level++; $level = $level % 11; # level: 0-10 Glib::Source->remove($timer); $timer = Glib::Timeout->add(speed(), \&update); } update_label(); } sub update_label { my $labels = $canvas->{labels}; $labels->[0]->set_label( make_string("Scores", $score)); $labels->[1]->set_label( make_string("Lines", $lines)); $labels->[2]->set_label( make_string("Level", $level)); } sub speed { return int(500/($level*0.5+1)); } sub rank_dia { my $score = shift; my ($idx, $new_iter, $new_entry); my $max = $Config{max_rank_list}-1; if ( defined $score ) { if ( !defined $history ) { $history = [ $new_entry ]; $idx = 0; } else { $new_entry = [$Config{name} || getlogin || getpwuid($<) || 'Nobody', $score]; $history = [ sort {$b->[1] <=> $a->[1]} @$history ]; $idx = 0; while ( $idx <= $#$history ) { last if $score >= $history->[$idx][1]; $idx++; } if ( $idx > $max && $idx > $#$history ) { return; } else { splice(@$history, $idx, 0, $new_entry); if ( $#$history > $max ) { $#$history = $max; } } } } if ( @$history == 0 ) { my $dia = Gtk2::MessageDialog->new( $window, 'destroy-with-parent', 'info', 'ok', "No rank list yet!", ); $dia->run; $dia->destroy; return FALSE; } my $dia = Gtk2::Dialog->new( 'Rank', $window, ['modal', 'destroy-with-parent'], 'gtk-ok' => 'ok', ); my $vbox = $dia->vbox; my $store = Gtk2::ListStore->new( qw/Glib::String Glib::Int/ ); foreach ( 0..$#$history ) { my $iter = $store->append(); $store->set($iter, 0, $history->[$_][0], 1, $history->[$_][1], ); if ( defined $idx && $idx == $_ ) { $new_iter = $iter; } } my $treeview = Gtk2::TreeView->new($store); my $col = Gtk2::TreeViewColumn->new(); $col->set_title('name'); my $ren = Gtk2::CellRendererText->new; if ( defined $score ) { $ren->set_property('editable' => TRUE); $ren->{'renderer_number'} = 0; $ren->signal_connect( edited => sub { my ($cell, $path_string, $new_text) = @_; $new_entry->[0] = $new_text; $store->set($new_iter, 0, $new_text); $cell->set_property('editable' => FALSE); return FALSE; } ); } $col->pack_start($ren, FALSE); $col->add_attribute($ren, text=>0); $treeview->append_column($col); my $col2 = Gtk2::TreeViewColumn->new(); $col2->set_title('score'); my $ren2 = Gtk2::CellRendererText->new; $col2->pack_start($ren2, FALSE); $col2->add_attribute($ren2, text=>1); $treeview->append_column($col2); $vbox->pack_start($treeview, FALSE, FALSE, 0); $dia->show_all; if ( defined $score ) { $treeview->set_cursor($store->get_path($new_iter), $col, TRUE); } $dia->signal_connect( response => sub { $dia->destroy; return FALSE; } ); } sub game_over { Glib::Source->remove($timer); show_heading('Game Over'); $game_start = 0; rank_dia($score); } sub rotate { return unless $game_start; # print "rotate\n"; $canvas->{shape}->rotate; } sub down { return unless $game_start; my $shape = $canvas->{shape}; while ( !$shape->move_down ) { } done(); } sub move_down { return unless $game_start; # print "down\n"; foreach ( 1..$Config{down_step} ) { $canvas->{shape}->move_down; } } sub move_right { return unless $game_start; # print "right\n"; $canvas->{shape}->move_right; } sub move_left { return unless $game_start; # print "left\n"; $canvas->{shape}->move_left; } sub pause { # print "pause $timer_pause\n"; $timer_pause = !$timer_pause; if ( $timer_pause ) { show_heading('Pause'); } else { remove_heading(); } return FALSE; } sub parse_shapes { my $str; while ( ) { next if /^#/; last if /^__END__/; $str .= $_; } my @shapes = grep {defined $_} map { shape_from_string($_) } ( split /\n\n/, $str ); return \@shapes; } sub shape_from_string { my $str = shift; my @lines = grep {$_} split /\n/, $str; return if grep {/^#/} @lines; return if $#lines != 3; my @shape; foreach ( 0..$#lines ) { my @p = map {[split / /]} split / +/, $lines[$_]; map { push @{$shape[$_]}, $p[$_] } 0..$#p; } return \@shape; } sub dump_table { my $table = shift; for my $i( 1..$Config{rows} ) { for my $j( 1..$Config{cols} ) { if ( $table->[$i-1][$j-1] ) { print "$i, $j\n"; } } } } sub write_history { my $str; my $found_mark; open(my $out, ">", \$str) or die "Can't write to string: $!\n"; my $start_mark = "# HISTORY: Don't edit from this line to the line marked with END HISTORY."; my $end_mark = "# END HISTORY"; my $conf = $start_mark . "\n" . Data::Dumper->Dump([$history], ['history']) . $end_mark . "\n"; if ( -e $config_file ) { open(my $fh, $config_file) or die "Can't open file $config_file: $!"; while ( <$fh> ) { if ( /\Q$start_mark/ ) { $found_mark = 1; while ( <$fh>) { last if /\Q$end_mark/; } print $out $conf; } else { print $out $_; } } close($fh); } if ( !$found_mark ) { print $out $conf; print $out "1;\n"; } close($out); open(my $fh, ">$config_file") or die "Can't create file $config_file: $!"; print $fh $str; close($fh); } 1; __DATA__ 0 0 0 0 0 1 1 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 7 0 7 7 7 7 0 0 7 0 0 0 0 0 0 0 7 0 0 0 0 0 0 0 7 0 0 0 0 0 0 0 0 4 0 4 4 0 0 0 4 4 0 0 4 4 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 0 0 0 5 5 0 0 5 5 0 5 5 0 0 0 0 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 0 0 2 0 0 0 0 2 2 0 2 2 2 0 0 2 0 0 2 2 2 0 0 2 0 0 0 0 2 0 2 2 0 0 0 0 0 0 0 2 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 3 3 0 0 0 0 0 0 0 3 0 0 3 3 3 0 0 3 0 0 0 0 3 0 0 3 0 0 3 0 0 0 0 3 0 0 3 3 3 0 0 3 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 6 0 0 0 0 0 0 0 6 0 0 6 6 6 0 0 6 6 0 6 6 6 0 6 6 0 0 0 0 0 0 0 6 0 0 0 6 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 __END__ =head1 NAME tetris - A tetris game =head1 SYNOPSIS perl tetris.pl =head1 CONFIGURATION The configuration file should be the file with name ".tetris" under HOME directory. Another option is using Tetris/Config.pm in any directory of @INC. Here is an example of configuration: # -*- perl -*- %Config = ( %Config, 'start_level' => 3, 'down_step' => 2, 'keybindings' => { %{$Config{keybindings}}, ord('j') => \&move_left, ord('l') => \&move_right, ord('k') => \&rotate, ord('n') => \&new_game, } ); push @$shapes, shape_from_string(<new ('toplevel'); $window->signal_connect (delete_event => sub { Gtk2->main_quit }); $window->signal_connect('key-press-event' => \&show_key); my $label = Gtk2::Label->new(); $label->set_markup("Type something on the keyboard!"); $window->add ($label); $window->show_all; $window->set_position ('center-always'); Gtk2->main; sub show_key { my ($widget,$event,$parameter)= @_; my $key_nr = $event->keyval(); foreach my $key (keys %Gtk2::Gdk::Keysyms) { my $key_compare = $Gtk2::Gdk::Keysyms{$key}; if ($key_compare == $key_nr) { print "'$key' => $key_nr,\n"; } } return FALSE; } Code to run after the GUI setup, add to code ref $after_load_function. =cut Goo-Canvas-0.06/Makefile.PL0000644000175000017500000001217410772721425013546 0ustar ywbywb#! /usr/bin/perl -w use 5.008; use strict; use warnings; use Cwd; use File::Spec; use ExtUtils::MakeMaker; # minimum required version of dependancies we need to build our %build_reqs = ( 'perl-ExtUtils-Depends' => '0.2', 'perl-ExtUtils-PkgConfig' => '1.0', 'perl-Glib' => '1.103', 'perl-Gtk2' => '1.100', 'perl-Cairo' => '1.00', 'goocanvas' => '0.9', ); our %prereqs = ( 'Glib' => $build_reqs{'perl-Glib'}, 'Gtk2' => $build_reqs{'perl-Gtk2'}, 'Cairo' => $build_reqs{'perl-Cairo'}, 'ExtUtils::Depends' => $build_reqs{'perl-ExtUtils-Depends'}, 'ExtUtils::PkgConfig' => $build_reqs{'perl-ExtUtils-PkgConfig'}, ); # Writing a fake Makefile ensures that CPAN will pick up the correct # dependencies and install them. unless ( eval "use ExtUtils::Depends;" . "use ExtUtils::PkgConfig;" . "use Gtk2::CodeGen;" . "use Cairo;" # just seeing if Glib is available isn't enough, make sure # it's recent enough, too . "use Glib '$build_reqs{'perl-Glib'}';" . "use Gtk2 '$build_reqs{'perl-Gtk2'}';" . "use Glib::MakeHelper;" . "1" ) { warn "$@\n"; WriteMakefile( PREREQ_FATAL => 1, PREREQ_PM => \%prereqs, ); exit 1; # not reached } mkdir 'build', 0777; our %pkgcfg = ExtUtils::PkgConfig->find ('goocanvas'); # now we're ready to start creating the makefile. # we need to use ExtUtils::Depends to get relevant information out of # the Glib extension, and to save config information for other modules which # will chain from this one. our @xs_files = ; our %pm_files = ( 'lib/Goo/Canvas.pm' => '$(INST_LIBDIR)/Canvas.pm', ); our %pod_files; %pod_files = ( 'lib/Goo/Canvas.pm' => '$(INST_MAN3DIR)/Goo::Canvas.$(MAN3EXT)', Glib::MakeHelper->do_pod_files (@xs_files), ); ExtUtils::PkgConfig->write_version_macros ( "build/goocanvas-perl-version.h", 'goocanvas' => 'GOO_CANVAS' ); # # autogeneration # Gtk2::CodeGen->parse_maps ('goocanvas-perl'); Gtk2::CodeGen->write_boot (ignore => '^Goo::Canvas$'); my $goo = ExtUtils::Depends->new ('Goo::Canvas', 'Gtk2', 'Glib', 'Cairo'); $goo->set_inc ($pkgcfg{cflags} . ' -I./build '); if ( $^O eq 'MSWin32' ) { my @a = split /\s+/,$pkgcfg{libs}; for (@a) { next if /gdi32|imm32|shell32|ole32|\-lm/; $_ = '-luser32',next if /user32/; $_ = '-luuid',next if /uuid/; $_ .= '.dll.a' if /^-l/; } $goo->set_libs (join(' ',@a) . find_extra_libs()); } else { $goo->set_libs ($pkgcfg{libs}); } $goo->add_xs (@xs_files); $goo->add_pm (%pm_files); my $cwd = cwd(); $goo->add_typemaps ( File::Spec->catfile( $cwd, 'build/goocanvas-perl.typemap'), File::Spec->catfile( $cwd, 'goocanvas.typemap'), ); $goo->install (qw(goocanvas-perl.h build/goocanvas-perl-autogen.h build/goocanvas-perl-version.h)); $goo->save_config ('build/IFiles.pm'); use Data::Dumper qw(Dumper); WriteMakefile( NAME => 'Goo::Canvas', VERSION_FROM => 'lib/Goo/Canvas.pm', # finds $VERSION PREREQ_PM => \%prereqs, ABSTRACT_FROM => 'lib/Goo/Canvas.pm', # retrieve abstract from module XSPROTOARG => '-noprototypes', 'EXE_FILES' => ['bin/perltetris.pl', 'bin/perlmine.pl'], MAN3PODS => \%pod_files, ( $^O eq 'MSWin32' ? (dynamic_lib => { OTHERLDFLAGS=>"-Wl,-out-implib,blib\\arch\\auto\\Goo\\Canvas\\Canvas.lib.a \$(EXPORT_LIST) " }) : ()), $goo->get_makefile_vars, ); # this probably needs to go into ExtUtils::Depends. sub find_extra_libs { # right now we need this terrible hack only for windows. # unfortunately, this code doesn't work on cygwin. :-/ return "" unless $^O eq "MSWin32"; # win32 does not allow unresolved symbols in libraries, but # Gtk2 uses on symbols in the dll created for Glib. # so, we have to break all this nice abstraction and encapsulation # and find the actual Glib.dll and Glib.lib installed by perl when # the Glib module was built, and add it to the list of lib files. # # when we depend on Cairo, the same applies to Cairo.lib. # # say it with me: "i hate win32." my $retstring = ""; use File::Find; find (sub { $retstring .= " ".$File::Find::name if /(Glib\.lib|libGlib|Glib\.dll)/i; $retstring .= " ".$File::Find::name if /(Cairo\.lib|libCairo|Cairo\.dll)/i; $retstring .= " ".$File::Find::name if /(Gtk2\.lib|libGtk2|Gtk2\.dll)/i; }, @INC); return $retstring; } sub MY::postamble { my $res = Glib::MakeHelper->postamble_clean () . Glib::MakeHelper->postamble_docs (@main::xs_files) . Glib::MakeHelper->postamble_rpms ( 'GOO_CANVAS' => $build_reqs{'goocanvas'}, 'PERL_EXTUTILS_DEPENDS' => $build_reqs{'perl-ExtUtils-Depends'}, 'PERL_EXTUTILS_PKGCONFIG' => $build_reqs{'perl-ExtUtils-PkgConfig'}, 'PERL_GLIB' => $build_reqs{'perl-Glib'}, 'PERL_GTK' => $build_reqs{'perl-Gtk2'}, 'PERL_CAIRO' => $build_reqs{'perl-Cairo'}, ); return $res; } Goo-Canvas-0.06/demo/0000755000175000017500000000000011200440442012473 5ustar ywbywbGoo-Canvas-0.06/demo/demo.pl0000755000175000017500000021111510712424053013767 0ustar ywbywb#!/usr/bin/perl -w # demo.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/26 13:31:45 # Author: Ye Wenbin use strict; use warnings; use FindBin; use lib "$FindBin::Bin/../blib/arch"; use lib "$FindBin::Bin/../blib/lib"; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use Goo::Canvas; my $window = create_window(); Gtk2->main; #{{{ Main window sub create_window { my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); $window->show; my $notebook = Gtk2::Notebook->new; $window->add($notebook); $notebook->show; foreach my $pkg ( "Primitives", "Arrowhead", "Fifteen", "Reparent", "Scalability", "Grabs", "Events", "Paths", "Focus", "Animation", "Clipping", ) { $notebook->append_page( $pkg->create_canvas, Gtk2::Label->new($pkg) ); } return $window; } #}}} #{{{ Primitives package Primitives; use Gtk2; use Glib qw(TRUE FALSE); use constant { VERTICES => 10, RADIUS => 60, SCALE => 7, }; use Math::Trig qw/pi/; sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my $group; my ($hbox, $w, $swin, $canvas, $adj); my $bg_color = Gtk2::Gdk::Color->new(50000, 50000, 65535); $vbox->set_border_width(4); $vbox->show; $w = Gtk2::Label->new("Drag an item with button 1. Click button 2 on an item to lower it, or button 3 to raise it."); $vbox->pack_start($w, FALSE, FALSE, 0); $w->show; $hbox = Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); $hbox->show; # Create the canvas $canvas = Goo::Canvas->new; $canvas->modify_base('normal', $bg_color); $canvas->set_bounds(0, 0, 604, 454); ###### Frist Row # Zoom $w = Gtk2::Label->new("Zoom:"); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $adj = Gtk2::Adjustment->new(1, 0.05, 100, 0.05, 0.5, 0.5); $w = Gtk2::SpinButton->new($adj, 0, 2); $adj->signal_connect("value-changed", \&zoom_changed, $canvas); $w->set_size_request(50, -1); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; # Center $w = Gtk2::CheckButton->new_with_label("Center scroll region"); $hbox->pack_start($w, FALSE, FALSE, 0); # $w->show; $w->signal_connect("toggled", \¢er_toggled, $canvas); # Move Ellipse $w = Gtk2::Button->new_with_label('Move Ellipse'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&move_ellipse_clicked, $canvas); # Animate Ellipse $w = Gtk2::Button->new_with_label('Animate Ellipse'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&animate_ellipse_clicked, $canvas); # Stop Animation $w = Gtk2::Button->new_with_label('Stop Animation'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&stop_animation_clicked, $canvas); # Create PDF $w = Gtk2::Button->new_with_label('Write PDF'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&write_pdf_clicked, $canvas); ##### Start anothor Row $hbox = Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); $hbox->show; # Scroll to $w = Gtk2::Label->new('Scroll to:'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w = Gtk2::Button->new_with_label('50,50'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&scroll_to_50_50_clicked, $canvas); $w = Gtk2::Button->new_with_label('250,250'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&scroll_to_250_250_clicked, $canvas); $w = Gtk2::Button->new_with_label('500,500'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&scroll_to_500_500_clicked, $canvas); # Scroll anchor $w = Gtk2::Label->new('Anchor:'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; foreach my $anchor( 'NW', 'N', 'NE', 'W', 'SW', 'S', 'SE' ) { $w = Gtk2::RadioButton->new_with_label($group, $anchor); $group = $w; $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect('toggled', \&anchor_toggled, $canvas); $w->{anchor} = lc($anchor); } # Layout the stuff $swin = Gtk2::ScrolledWindow->new(); $swin->show; $vbox->pack_start($swin, TRUE, TRUE, 0); $canvas->show; $swin->add($canvas); setup_canvas($canvas); if ( 0 ) { $canvas->signal_connect_after('key_press_event', \&key_press); $canvas->can_focus(TRUE); $canvas->grab_focus; } return $vbox; } sub setup_canvas { my $canvas = shift; my $root = $canvas->get_root_item; $root->signal_connect('button_press_event', \&on_background_button_press); setup_divisions($root); setup_rectangles($root); setup_ellipses($root); setup_lines($root); setup_polygons($root); setup_texts($root); setup_images($root); setup_invisible_texts($root); } sub setup_divisions { my $root = shift; my ($group, $item); $group = Goo::Canvas::Group->new($root); $group->translate(2, 2); $item = Goo::Canvas::Rect->new( $group, 0, 0, 600, 450, 'line-width' => 4 ); $item = Goo::Canvas::Polyline->new_line( $group, 0, 150, 600, 150, 'line-width' => 4, ); $item = Goo::Canvas::Polyline->new_line( $group, 0, 300, 600, 300, 'line-width' => 4, ); $item = Goo::Canvas::Polyline->new_line( $group, 200, 0, 200, 450, 'line-width' => 4, ); $item = Goo::Canvas::Polyline->new_line( $group, 400, 0, 400, 450, 'line-width' => 4, ); setup_heading ($group, "Rectangles", 0); setup_heading ($group, "Ellipses", 1); setup_heading ($group, "Texts", 2); setup_heading ($group, "Images", 3); setup_heading ($group, "Lines", 4); setup_heading ($group, "Polygons", 7); } sub setup_heading { my ($root, $text, $pos) = @_; my $x = ($pos%3)*200 + 100; my $y = (int($pos/3))*150 + 5; # print("$text $pos($x, $y)\n"); my $item = Goo::Canvas::Text->new( $root, $text, $x, $y, -1, 'n', 'font' => 'Sans 12' ); $item->skew_y(30, $x, $y); } sub setup_rectangles { my $root = shift; my ($item, $pattern); my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); $item = Goo::Canvas::Rect->new( $root, 20, 30, 50, 30, 'stroke-color' => 'red', 'line-width' => 8, ); setup_item_signals($item); $pattern = create_stipple('mediumseagreen', \@stipple_data); $item = Goo::Canvas::Rect->new( $root, 90, 40, 90, 60, 'fill-pattern' => $pattern, 'stroke-color' => 'black', 'line-width' => 4, ); setup_item_signals($item); $item = Goo::Canvas::Rect->new( $root, 10, 80, 70, 60, 'fill-color' => 'steelblue', ); setup_item_signals($item); $item = Goo::Canvas::Rect->new( $root, 20, 90, 70, 60, 'fill-color-rgba' => 0x3cb37180, 'stroke-color' => 'blue', 'line-width' => 2, ); setup_item_signals($item); $item = Goo::Canvas::Rect->new( $root, 110, 80, 50, 30, 'radius-x' => 20, 'radius-y' => 10, 'stroke-color' => 'yellow', 'fill-color-rgba' => 0x3cb3f180, ); setup_item_signals($item); $item = Goo::Canvas::Rect->new( $root, 30, 20, 50, 30, 'fill-color' => 'yellow', ); setup_item_signals($item); } sub create_stipple { our @stipples; my($color_name, $stipple_data) = @_; my $color = Gtk2::Gdk::Color->parse($color_name); $stipple_data->[2] = $stipple_data->[14] = $color->red >> 8; $stipple_data->[1] = $stipple_data->[13] = $color->green >> 8; $stipple_data->[0] = $stipple_data->[12] = $color->blue >> 8; my $stipple_str = join('', map {chr} @$stipple_data); push @stipples, \$stipple_str; # make $stipple_str refcnt increase my $surface = Cairo::ImageSurface->create_for_data( $stipple_str, 'argb32', 2, 2, 8 ); my $pattern = Cairo::SurfacePattern->create($surface); $pattern->set_extend('repeat'); return Goo::Cairo::Pattern->new($pattern); } sub setup_ellipses { my $root = shift; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my $ellipse1 = Goo::Canvas::Ellipse->new( $root, 245, 45, 25, 15, 'stroke-color' => 'goldenrod', 'line-width' => 8 ); setup_item_signals($ellipse1); my $ellipse2 = Goo::Canvas::Ellipse->new( $root, 335, 70, 45, 30, 'fill-color' => 'wheat', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'An ellipse' ); setup_item_signals($ellipse2); $ellipse2->get_canvas->{ellipse} = $ellipse2; my $pattern = create_stipple('cadetblue', \@stipple_data); my $ellipse3 = Goo::Canvas::Ellipse->new( $root, 245, 110, 35, 30, 'fill-pattern' => $pattern, 'stroke-color' => 'black', 'line-width' => 1, ); setup_item_signals($ellipse3); } sub setup_lines { my $root = shift; my $line; polish_diamond($root); make_hilbert($root); $line = Goo::Canvas::Polyline->new( $root, FALSE, [ 340, 170, 340, 230, 390, 230, 390, 170 ], 'stroke-color' => 'midnightblue', 'line-width' => 3, 'start-arrow' => TRUE, 'end-arrow' => TRUE, 'arrow-tip-length' => 3, 'arrow-length' => 4, 'arrow-width' => 3.5 ); setup_item_signals($line); $line = Goo::Canvas::Polyline->new( $root, FALSE, [ 356, 180, 374, 220, ], 'stroke-color' => 'blue', 'line-width' => 1, 'start-arrow' => TRUE, 'end-arrow' => TRUE, 'arrow-tip-length' => 5, 'arrow-length' => 6, 'arrow-width' => 6, ); setup_item_signals($line); $line = Goo::Canvas::Polyline->new( $root, FALSE, [356, 220, 374, 180,], 'stroke-color' => 'blue', 'line-width' => 1, 'start-arrow' => TRUE, 'end-arrow' => TRUE, 'arrow-tip-length' => 5, 'arrow-length' => 6, 'arrow-width' => 6, ); setup_item_signals($line); $line = Goo::Canvas::Polyline->new($root, FALSE, undef); setup_item_signals($line); $line = Goo::Canvas::Polyline->new( $root, FALSE, [356, 220], 'start-arrow' => TRUE, 'end-arrow' => TRUE, ); setup_item_signals($line); } sub polish_diamond { my $root = shift; my $item; my ($a, $x1, $y1, $x2, $y2); my $group = Goo::Canvas::Group->new( $root, 'line-width' => 1, 'line-cap' => 'round' ); $group->translate(270, 230); setup_item_signals($group); for my $i ( 0..VERTICES ) { $a = 2*pi*$i/VERTICES; $x1 = RADIUS * cos($a); $y1 = RADIUS * sin($a); for my $j( $i+1..VERTICES ) { $a = 2*pi*$j/VERTICES; $x2 = RADIUS * cos($a); $y2 = RADIUS * sin($a); $item = Goo::Canvas::Polyline->new_line( $group, $x1, $y1, $x2, $y2 ); } } } sub make_hilbert { my $root = shift; my $hilbert = "urdrrulurulldluuruluurdrurddldrrruluurdrurddldrddlulldrdldrrurd"; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my $pattern = create_stipple('red', \@stipple_data); my @points = ( [340, 290] ); my $pp = $points[0]; foreach ( 0..length($hilbert)-1 ) { my @p; my $c = substr($hilbert, $_, 1); if ( $c eq 'u' ) { $p[0] = $pp->[0]; $p[1] = $pp->[1] - SCALE; } elsif ( $c eq 'd' ) { $p[0] = $pp->[0]; $p[1] = $pp->[1] + SCALE; } elsif ( $c eq 'l' ) { $p[0] = $pp->[0] - SCALE; $p[1] = $pp->[1]; } elsif ( $c eq 'r' ) { $p[0] = $pp->[0] + SCALE; $p[1] = $pp->[1]; } push @points, \@p; $pp = \@p; } my $item = Goo::Canvas::Polyline->new( $root, FALSE, [map {@{$_}} @points], 'line-width' => 4, 'stroke-pattern' => $pattern, 'line-cap' => 'square', 'line-join' => 'miter' ); setup_item_signals($item); } sub setup_polygons { my $root = shift; my $line; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my @points = ( 210, 320, 210, 380, 260, 350 ); my $pattern = create_stipple('blue', \@stipple_data); $line = Goo::Canvas::Polyline->new( $root, TRUE, \@points, 'line-width' => 1, 'fill-pattern' => $pattern, 'stroke-color' => 'black' ); setup_item_signals($line); @points = ( 270.0, 330.0, 270.0, 430.0, 390.0, 430.0, 390.0, 330.0, 310.0, 330.0, 310.0, 390.0, 350.0, 390.0, 350.0, 370.0, 330.0, 370.0, 330.0, 350.0, 370.0, 350.0, 370.0, 410.0, 290.0, 410.0, 290.0, 330.0, ); $line = Goo::Canvas::Polyline->new( $root, TRUE, \@points, 'fill-color' => 'tan', 'stroke-color' => 'black', 'line-width' => 3, ); setup_item_signals($line); } sub setup_texts { my $root = shift; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my $pattern = create_stipple('blue', \@stipple_data); my $item; $item = Goo::Canvas::Text->new( make_anchor($root, 420, 20), 'Anchor NW', 0, 0, -1, 'nw', 'font' => 'Sans Bold 24', 'fill-pattern' => $pattern, ); setup_item_signals($item); $item = Goo::Canvas::Text->new( make_anchor($root, 470, 75), "Anchor center\nJustify center\nMultiline text\nb8bit text ÅÄÖåäö", 0, 0, -1, 'center', "font" => "monospace bold 14", "alignment" => 'center', "fill-color" => "firebrick", ); setup_item_signals($item); $item = Goo::Canvas::Text->new( make_anchor($root, 590, 140), "Clipped text\nClipped text\nClipped text\nClipped text\nClipped text\nClipped text", 0, 0, -1, 'se', 'font' =>'Sans 12', 'fill-color' => 'darkgreen' ); setup_item_signals($item); $item = Goo::Canvas::Text->new( make_anchor($root, 420, 240), "This is a very long paragraph that will need to be wrapped over several lines so we can see what happens to line-breaking as the view is zoomed in and out.", 0, 0, 180, 'w', 'font' => 'Sans 12', 'fill-color' => 'goldenrod' ); setup_item_signals($item); } sub make_anchor { my($root, $x, $y) = @_; my $group = Goo::Canvas::Group->new($root); my $transform = Goo::Cairo::Matrix->new( Cairo::Matrix->init(0.8, 0.2, -0.3, 0.5, $x, $y ), ); my $item; $group->translate($x, $y); $group->set( 'transform' => $transform ); $item = Goo::Canvas::Rect->new( $group, -2.5, -2.5, 4, 4, 'line-width' => 1, ); setup_item_signals($item); return $group; } sub setup_images { my $root = shift; my ($im, $image); use Data::Dumper qw(Dumper); $im = Gtk2::Gdk::Pixbuf->new_from_file("$FindBin::Bin/toroid.png"); if ( $im ) { my $w = $im->get_width; my $h = $im->get_height; $image = Goo::Canvas::Image->new( $root, $im, 100-$w/2, 225-$h/2, 'width' => $w, 'height' => $h ); setup_item_signals($image); } else { warn "Could not foundhe toroid.png sample file\n"; } plant_flower ($root, 20.0, 170.0, 'nw'); plant_flower ($root, 180.0, 170.0, 'ne'); plant_flower ($root, 20.0, 280.0, 'sw'); plant_flower ($root, 180.0, 280.0, 'se'); } sub plant_flower { my ($root, $x, $y, $anchor) = @_; my $surface = Cairo::ImageSurface->create_from_png("$FindBin::Bin/flower.png"); my $w = $surface->get_width; my $h = $surface->get_height; my $pattern = Cairo::SurfacePattern->create($surface); my $image = Goo::Canvas::Image->new( $root, undef, $x, $y, 'pattern' => Goo::Cairo::Pattern->new($pattern), 'width' => $w, 'height' => $h, ); setup_item_signals($image); } sub setup_invisible_texts { my $root = shift; Goo::Canvas::Text->new( $root, "Visible above 0.8x", 500, 330, -1, 'center', "visibility" => 'visible_above_threshold', "visibility-threshold" => 0.8, ); Goo::Canvas::Rect->new( $root, 410.5, 322.5, 180, 15, "line-width" => 1.0, "visibility" => 'visible-above-threshold', "visibility-threshold" => 0.8, ); Goo::Canvas::Text->new( $root, "Visible above 1.5x", 500, 350, -1, 'center', "visibility" => 'visible-above-threshold', "visibility-threshold" => 1.5, ); Goo::Canvas::Rect->new( $root, 410.5, 342.5, 180, 15, "line-width" => 1.0, "visibility" => 'visible-above-threshold', "visibility-threshold" => 1.5, ); Goo::Canvas::Text->new( $root, "Visible above 3.0x", 500, 370, -1, 'center', "visibility" => 'visible-above-threshold', "visibility-threshold" => 3.0, ); Goo::Canvas::Rect->new( $root, 410.5, 362.5, 180, 15, "line-width" => 1.0, "visibility" => 'visible-above-threshold', "visibility-threshold" => 3.0, ); # This should never be seen. Goo::Canvas::Text->new( $root, "Always Invisible", 500, 390, -1, 'center', "visibility" => 'invisible', ); Goo::Canvas::Rect->new( $root, 410.5, 350.5, 180, 15, "line-width" => 1.0, "visibility" => 'invisible', ); } #{{{ Signals sub setup_item_signals { my $item = shift; $item->signal_connect('motion_notify_event', \&on_motion_notify); $item->signal_connect('button_press_event', \&on_button_press); $item->signal_connect('button_release_event', \&on_button_release); } sub on_motion_notify { my ($item, $target, $ev) = @_; # print "Ev state: ", $ev->state, "\n"; if ( $item->{dragging} && $ev->state >= 'button1-mask' ) { $item->translate($ev->x - $item->{drag_x}, $ev->y - $item->{drag_y}); } return TRUE; } sub on_button_press { my ($item, $target, $ev) = @_; if ( $ev->button == 1 ) { if ( $ev->state >= 'shift-mask' ) { my $parent = $item->get_parent; $parent->remove_child($parent->find_child($item)); } else { $item->{drag_x} = $ev->x; $item->{drag_y} = $ev->y; my $fleur = Gtk2::Gdk::Cursor->new('fleur'); my $canvas = $item->get_canvas; $canvas->pointer_grab($item, ['pointer-motion-mask', 'button-release-mask'], $fleur, $ev->time); $item->{dragging} = TRUE; } } elsif ( $ev->button == 2 ) { $item->lower; } elsif ( $ev->button == 3 ) { $item->raise; } return TRUE; } sub on_button_release { my ($item, $target, $ev) = @_; my $canvas = $item->get_canvas; $canvas->pointer_ungrab($item, $ev->time); $item->{dragging} = FALSE; return TRUE; } sub on_background_button_press { return TRUE; } sub zoom_changed { my ($adj, $canvas) = @_; $canvas->set_scale($adj->get_value); } sub center_toggled { } sub anchor_toggled { my ($but, $canvas) = @_; if ( $but->get_active ) { $canvas->set("anchor" => $but->{anchor}); } } sub scroll_to_50_50_clicked { my ($but, $canvas) = @_; $canvas->scroll_to(50, 50); } sub scroll_to_250_250_clicked { my ($but, $canvas) = @_; $canvas->scroll_to(250, 250); } sub scroll_to_500_500_clicked { my ($but, $canvas) = @_; $canvas->scroll_to(500, 500); } sub animate_ellipse_clicked { my ($but, $canvas) = @_; $canvas->{ellipse}->animate(100, 100, 1, 90, TRUE, 1000, 40, 'bounce'); } sub stop_animation_clicked { my ($but, $canvas) = @_; $canvas->{ellipse}->stop_animation(); } sub move_ellipse_clicked { my ($but, $canvas) = @_; my $ellipse = $canvas->{ellipse}; if ( !exists $ellipse->{last_state} ) { $ellipse->{last_state} = 0; } my $last_state = $ellipse->{last_state}; if ( $last_state == 0 ) { $ellipse->set( 'center-x' => 300, 'center-y' => 70, 'radius-x' => 45, 'radius-y' => 30, 'fill-color' => 'red', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'A red ellipse' ); $last_state = 1; } elsif ( $last_state == 1 ) { $ellipse->set( 'center-x' => 390, 'center-y' => 150, 'radius-x' => 45, 'radius-y' => 40, 'fill-color' => 'brown', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'A brown ellipse' ); $last_state = 2; } elsif ( $last_state == 2 ) { $ellipse->set( 'center-x' => 0, 'center-y' => 0, 'radius-y' => 30, ); $ellipse->set_simple_transform(100, 100, 1, 0); $last_state = 3; } elsif ( $last_state == 3 ) { $ellipse->set_simple_transform(200, 200, 2, 0); $last_state = 4; } elsif ( $last_state == 4 ) { $ellipse->set_simple_transform(200, 200, 1, 45); $last_state = 5; } elsif ( $last_state == 5 ) { $ellipse->set_simple_transform(-50, -50, 0.2, 225); $last_state = 6; } else { $ellipse->set( 'center-x' => 335, 'center-y' => 70, 'radius-x' => 45, 'radius-y' => 30, 'fill-color' => 'purple', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'A purple ellipse' ); $last_state = 0; } $ellipse->{last_state} = $last_state; return TRUE; } sub write_pdf_clicked { my ($but, $canvas) = @_; print "Write PDF...\n"; my $surface = Cairo::PdfSurface->create("demo.pdf", 9*72, 10*72); my $cr = Cairo::Context->create($surface); $cr->translate(20, 130); $canvas->render($cr, undef, 1); $cr->show_page; return TRUE; } #}}} #}}} #{{{ Arrowhead package Arrowhead; use Gtk2; use Glib qw(TRUE FALSE); use constant { LEFT => 50.0, RIGHT => 350.0, MIDDLE => 150.0, DEFAULT_WIDTH => 2, DEFAULT_SHAPE_A => 4, DEFAULT_SHAPE_B => 5, DEFAULT_SHAPE_C => 4, }; sub create_canvas { my $pkg = shift; my ($w, $frame, $canvas, $root, $item); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $w = Gtk2::Label->new( <pack_start($w, FALSE, FALSE, 0); $w->show; $w = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($w, TRUE, TRUE, 0); $w->show; $frame = Gtk2::Frame->new; $frame->set_shadow_type('in'); $w->add($frame); $frame->show; $canvas = Goo::Canvas->new; $canvas->set_size_request(500, 350); $canvas->set_bounds(0, 0, 500, 350); $frame->add($canvas); $canvas->show; $canvas->{width} = DEFAULT_WIDTH; $canvas->{shape_a} = DEFAULT_SHAPE_A; $canvas->{shape_b} = DEFAULT_SHAPE_B; $canvas->{shape_c} = DEFAULT_SHAPE_C; $root = $canvas->get_root_item; # Big arrow $item = Goo::Canvas::Polyline->new_line( $root, LEFT, MIDDLE, RIGHT, MIDDLE, 'stroke-color' => 'mediumseagreen', 'end_arrow' => TRUE, ); $canvas->{big_arrow} = $item; # Arrow outline $item = Goo::Canvas::Polyline->new( $root, TRUE, undef, "stroke-color" => 'black', 'line-width' => 2, 'line-cap' => 'round', 'line-join' => 'round' ); $canvas->{outline} = $item; # Drag boxes create_drag_box($canvas, $root, 'width_drag_box'); create_drag_box($canvas, $root, 'shape_a_drag_box'); create_drag_box($canvas, $root, 'shape_b_c_drag_box'); # Dimensions create_dimension ($canvas, $root, "width_arrow", "width_text", 'e'); create_dimension ($canvas, $root, "shape_a_arrow", "shape_a_text", 'n'); create_dimension ($canvas, $root, "shape_b_arrow", "shape_b_text", 'n'); create_dimension ($canvas, $root, "shape_c_arrow", "shape_c_text", 'w'); # Info create_info ($canvas, $root, "width_info", LEFT, 260); create_info ($canvas, $root, "shape_a_info", LEFT, 280); create_info ($canvas, $root, "shape_b_info", LEFT, 300); create_info ($canvas, $root, "shape_c_info", LEFT, 320); # Division line Goo::Canvas::Polyline->new_line( $root, RIGHT + 50, 0, RIGHT+ 50, 1000, 'fill-color' => 'black', 'line-width' => 2 ); # Sample arrows create_sample_arrow ($canvas, $root, "sample_1", RIGHT + 100, 30, RIGHT + 100, MIDDLE - 30); create_sample_arrow ($canvas, $root, "sample_2", RIGHT + 70, MIDDLE, RIGHT + 130, MIDDLE); create_sample_arrow ($canvas, $root, "sample_3", RIGHT + 70, MIDDLE + 30, RIGHT + 130, MIDDLE + 120); # Done set_arrow_shape($canvas); return $vbox; } sub set_dimension { my ($canvas, $arrow_name, $text_name, $x1, $y1, $x2, $y2, $tx, $ty, $dim) = @_; my $points = Goo::Canvas::Points->new([$x1, $y1, $x2, $y2]); $canvas->{$arrow_name}->set(points => $points); $canvas->{$text_name}->set(text => sprintf("%.2f", $dim), x => $tx, y => $ty); } sub move_drag_box { my ($item, $x, $y) = @_; $item->set(x => $x-5, y => $y-5); } sub set_arrow_shape { my $canvas = shift; my $width = $canvas->{width}; my $shape_a = $canvas->{shape_a}; my $shape_b = $canvas->{shape_b}; my $shape_c = $canvas->{shape_c}; # Big arrow $canvas->{big_arrow}->set( 'line-width' => 10*$width, 'arrow-tip-length' => $shape_a, 'arrow-length' => $shape_b, 'arrow-width' => $shape_c ); # Outline my @points; $points[0] = RIGHT -int(10 *$shape_a*$width); $points[1] = MIDDLE-int(10*$width/2); $points[2] = RIGHT - 10 * $shape_b * $width; $points[3] = MIDDLE - 10 * ($shape_c * $width / 2.0); $points[4] = RIGHT; $points[5] = MIDDLE; $points[6] = RIGHT - 10 * $shape_b * $width; $points[7] = MIDDLE + 10 * ($shape_c * $width / 2.0); $points[8] = RIGHT -int(10 *$shape_a*$width); $points[9] = MIDDLE + 10 * $width / 2; $canvas->{outline}->set( points => Goo::Canvas::Points->new(\@points) ); move_drag_box($canvas->{width_drag_box}, LEFT, MIDDLE-10*$width/2); move_drag_box($canvas->{shape_a_drag_box}, RIGHT-10*$shape_a*$width, MIDDLE); move_drag_box($canvas->{shape_b_c_drag_box}, RIGHT-10*$shape_b*$width, MIDDLE-10*($shape_c*$width/2)); # Dimensions set_dimension($canvas, 'width_arrow', 'width_text', LEFT - 10, MIDDLE - 10 * $width / 2.0, LEFT - 10, MIDDLE + 10 * $width / 2.0, LEFT - 15, MIDDLE, $width); set_dimension ($canvas, "shape_a_arrow", "shape_a_text", RIGHT - 10 * $shape_a * $width, MIDDLE + 10 * ($shape_c * $width / 2.0) + 10, RIGHT, MIDDLE + 10 * ($shape_c * $width / 2.0) + 10, RIGHT - 10 * $shape_a * $width / 2.0, MIDDLE + 10 * ($shape_c * $width / 2.0) + 15, $shape_a); set_dimension ($canvas, "shape_b_arrow", "shape_b_text", RIGHT - 10 * $shape_b * $width, MIDDLE + 10 * ($shape_c * $width / 2.0) + 35, RIGHT, MIDDLE + 10 * ($shape_c * $width / 2.0) + 35, RIGHT - 10 * $shape_b * $width / 2.0, MIDDLE + 10 * ($shape_c * $width / 2.0) + 40, $shape_b); set_dimension ($canvas, "shape_c_arrow", "shape_c_text", RIGHT + 10, MIDDLE - 10 * $shape_c * $width / 2.0, RIGHT + 10, MIDDLE + 10 * $shape_c * $width / 2.0, RIGHT + 15, MIDDLE, $shape_c); # Info $canvas->{width_info}->set( text => sprintf("line-width: %.2f", $width) ); $canvas->{shape_a_info}->set( text => sprintf("arrow-tip-length: %.2f (* line-width)", $shape_a) ); $canvas->{shape_b_info}->set( text => sprintf("arrow-length: %.2f (* line-width)", $shape_b) ); $canvas->{shape_c_info}->set( text => sprintf("arrow-width: %.2f (* line-width)", $shape_c) ); # Sample arrows for ( qw/ sample_1 sample_2 sample_3 / ) { $canvas->{$_}->set( "line-width" => $width, "arrow-tip-length" => $shape_a, "arrow-length" => $shape_b, "arrow-width" => $shape_c, ); } } sub create_dimension { my ($canvas, $root, $arrow_name, $text_name, $anchor) = @_; my $item; $item = Goo::Canvas::Polyline->new( $root, FALSE, undef, 'fill-color' => 'black', 'start-arrow' => TRUE, 'end-arrow' => TRUE, ); $canvas->{$arrow_name} = $item; $item = Goo::Canvas::Text->new( $root, "", 0, 0, -1, $anchor, 'fill-color' => 'black', 'font' => 'Sans 12', ); $canvas->{$text_name} = $item; } sub create_info { my ($canvas, $root, $info_name, $x, $y) = @_; my $item = Goo::Canvas::Text->new( $root, "", $x, $y, -1, 'nw', 'fill-color' => 'black', 'font' => 'Sans 12', ); $canvas->{$info_name} = $item; } sub create_sample_arrow { my ($canvas, $root, $sample_name, $x1, $y1, $x2, $y2) = @_; my $item = Goo::Canvas::Polyline->new_line( $root, $x1, $y1, $x2, $y2, 'start-arrow' => TRUE, 'end-arrow' => TRUE, ); $canvas->{$sample_name} = $item; } sub on_enter_notify { my $item = shift; $item->set('fill-color' => 'red'); return TRUE; } sub on_leave_notify { my $item = shift; $item->set('fill-color' => 'black'); return TRUE; } sub on_button_press { my ($item, $target, $ev) = @_; my $fleur = Gtk2::Gdk::Cursor->new('fleur'); $item->get_canvas->pointer_grab( $item, ['pointer-motion-mask', 'button-release-mask'], $fleur, $ev->time); return TRUE; } sub on_button_release { my ($item, $target, $ev) = @_; $item->get_canvas->pointer_ungrab( $item, $ev->time ); return TRUE; } sub on_motion { my ($item, $target, $ev)= @_; my $canvas = $item->get_canvas; my ($x, $y, $width, $shape_a, $shape_b, $shape_c); my $change = FALSE; unless ( $ev->state >= 'button1-mask' ) { return FALSE; } if ( $item == $canvas->{width_drag_box} ) { $y = $ev->y; $width = (MIDDLE-$y)/5; if ( $width < 0) { return FALSE; } $canvas->{width} = $width; set_arrow_shape($canvas); } elsif ( $item == $canvas->{shape_a_drag_box} ) { $x = $ev->x; $width = $canvas->{width}; $shape_a = (RIGHT-$x)/10/$width; if ( ($shape_a < 0) || ($shape_a>30) ) { return FALSE; } $canvas->{shape_a} =$shape_a; set_arrow_shape($canvas); } elsif ( $item == $canvas->{shape_b_c_drag_box} ) { $x = $ev->x; $width = $canvas->{width}; $shape_b = (RIGHT-$x)/10/$width; if ( ($shape_b >= 0) && ($shape_b <=30) ) { $canvas->{shape_b} = $shape_b; $change = TRUE; } $y = $ev->y; $shape_c = (MIDDLE-$y) * 2/10/$width; if ( $shape_c >= 0 ) { $canvas->{shape_c} = $shape_c; $change = TRUE; } if ( $change ) { set_arrow_shape($canvas); } } return TRUE; } sub create_drag_box { my ($canvas, $root, $box_name) = @_; my $item = Goo::Canvas::Rect->new( $root, 0, 0, 10, 10, 'fill-color' => 'black', 'stroke-color' => 'black', 'line-width' => 1, ); $canvas->{$box_name} = $item; $item->signal_connect( 'enter_notify_event' => \&on_enter_notify ); $item->signal_connect( 'leave_notify_event' => \&on_leave_notify, ); $item->signal_connect( 'button_press_event' => \&on_button_press ); $item->signal_connect( 'button_release_event' => \&on_button_release ); $item->signal_connect( 'motion_notify_event' => \&on_motion ); } #}}} #{{{ Fifteen package Fifteen; use Gtk2; use Glib qw(TRUE FALSE); use constant { PIECE_SIZE => 50, SCRAMBLE_MOVES => 256, }; sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my ($alignment, $frame, $canvas, $root, $button); my ($x, $y, @board); $vbox->set_border_width(4); $vbox->show; $alignment = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($alignment, TRUE, TRUE, 0); $alignment->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $alignment->add($frame); $frame->show; # Create the canvas and board $canvas = Goo::Canvas->new; $root = $canvas->get_root_item; $canvas->set_size_request( PIECE_SIZE * 4 + 1, PIECE_SIZE * 4 + 1); $canvas->set_bounds(0, 0, PIECE_SIZE * 4+1, PIECE_SIZE * 4 + 1); $frame->add($canvas); $canvas->show; foreach my $i( 0..14 ) { $x = $i % 4; $y = int($i / 4); my $item = Goo::Canvas::Group->new($root); $item->translate($x * PIECE_SIZE, $y * PIECE_SIZE); setup_item_signals($item); my $rect = Goo::Canvas::Rect->new( $item, 0, 0, PIECE_SIZE, PIECE_SIZE, 'fill-color' => get_piece_color($i), 'stroke-color' => 'black', 'line-width' => 1 ); my $text = Goo::Canvas::Text->new( $item, $i+1, PIECE_SIZE/2, PIECE_SIZE/2, -1, 'center', 'font' => 'Sans bold 24', 'fill-color' => 'black' ); $item->{text} = $text; $item->{piece_num} = $i; $item->{piece_pos} = $i; push @board, $item; } push @board, undef; $canvas->{board} = \@board; $button = Gtk2::Button->new("Scramble"); $vbox->pack_start($button, FALSE, FALSE, 0); $button->signal_connect('clicked', \&scramble, $canvas); $button->show; return $vbox; } sub get_piece_color { use integer; my $i = shift; my $x = $i % 4; my $y = $i / 4; my $r = (( 4- $x) * 255) /4; my $g = (( 4- $y) * 255) /4; my $b = 128; return sprintf("#%02x%02x%02x", $r, $g, $b); } sub piece_enter_notify { my $item = shift; $item->{text}->set( 'fill-color' => 'white' ); return FALSE; } sub piece_leave_notify { my $item = shift; $item->{text}->set( 'fill-color' => 'black' ); return FALSE; } sub piece_button_press { my ($item, $target, $event, $data) = @_; my ($num, $pos, $text, $x, $y, $move, $dx, $dy, $newpos); my $canvas = $item->get_canvas; my $board = $canvas->{board}; $num = $item->{piece_num}; $pos = $item->{piece_pos}; $text = $item->{text}; $x = $pos % 4; $y = int($pos / 4); $move = TRUE; if ( $y>0 && !$board->[($y-1)*4+$x] ) { $dx = 0; $dy = -1; $y--; } elsif ( $y<3 && !$board->[($y+1)*4+$x] ) { $dx = 0; $dy = 1; $y++; } elsif ( $x>0 && !$board->[$y*4+$x-1] ) { $dx = -1; $dy = 0; $x--; } elsif ( $x<3 && !$board->[$y*4+$x+1] ) { $dx = 1; $dy = 0; $x++; } else { $move = FALSE; } if ( $move ) { $newpos = $y*4+$x; $board->[$pos] = undef; $board->[$newpos] = $item; $item->{piece_pos} = $newpos; $item->translate($dx*PIECE_SIZE, $dy*PIECE_SIZE); test_win($board); } return FALSE; } sub test_win { my $board = shift; foreach ( 0..14 ) { if ( !$board->[$_] || $board->[$_]{piece_num} != $_ ) { return; } } if ( 1 ) { my $item = ($board->[0] || $board->[1]); my $dia = Gtk2::MessageDialog->new( $item->get_canvas->get_toplevel, 'destroy-with-parent', 'info', 'ok', 'You stud, you win!', ); $dia->show; $dia->signal_connect( 'response' => sub { $dia->destroy; } ); } return TRUE; } sub setup_item_signals { my $item = shift; $item->signal_connect( 'enter_notify_event' => \&piece_enter_notify ); $item->signal_connect( 'leave_notify_event' => \&piece_leave_notify, ); $item->signal_connect( 'button-press-event' => \&piece_button_press, ); } sub scramble { my ($but, $canvas) = @_; my $board = $canvas->{board}; my ($x, $y, $dir, $oldpos); my $pos = 0; foreach ( @$board ) { last unless $_; $pos++; } for ( 0..SCRAMBLE_MOVES ) { my $done = 0; $x = $y = 0; while ( !$done ) { $dir = int(rand(4)); $done = 1; if ( $dir == 0 && $pos > 3 ) { $y = -1; } elsif ( $dir==1 && $pos < 12 ) { $y = 1; } elsif ( $dir == 2 && ($pos%4) != 0 ) { $x = -1; } elsif ( $dir == 3 && ($pos %4) != 3 ) { $x = 1; } else { $done = 0; } } $oldpos = $pos + $y*4 + $x; $board->[$pos] = $board->[$oldpos]; $board->[$oldpos] = undef; $board->[$pos]->{piece_pos} = $pos; $board->[$pos]->translate(-$x*PIECE_SIZE, -$y*PIECE_SIZE); $pos = $oldpos; } } #}}} #{{{ Reparent package Reparent; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($w, $alignment, $frame, $canvas, $root, $parent1, $parent2, $item, $group); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); # Instructions $w = Gtk2::Label->new("Reparent test: click on the items to switch them between parents"); $vbox->pack_start($w, FALSE, FALSE, 0); $w->show; # Frame and canvas $alignment = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($alignment, FALSE, FALSE, 0); $alignment->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $alignment->add($frame); $frame->show; $canvas = Goo::Canvas->new; $root = $canvas->get_root_item; $canvas->set_size_request( 400, 200); $canvas->set_bounds( 0, 0, 400, 200); $frame->add($canvas); $canvas->show; # First parent and box $parent1 = Goo::Canvas::Group->new($root); Goo::Canvas::Rect->new( $parent1, 0, 0, 200, 200, 'fill-color' => 'tan' ); # Second parent and box $parent2 = Goo::Canvas::Group->new($root); $parent2->translate(200, 0); Goo::Canvas::Rect->new( $parent2, 0, 0, 200, 200, 'fill-color' => '#204060' ); # Big circle to be reparented $item = Goo::Canvas::Ellipse->new( $parent1, 100, 100, 90, 90, 'stroke-color' => 'black', 'fill-color' => 'mediumseagreen', 'line-width' => 3, ); $item->{parent1} = $parent1; $item->{parent2} = $parent2; $item->signal_connect( 'button-press-event' => \&on_button_press ); # A group to be reparented $group = Goo::Canvas::Group->new($parent2); $group->translate(100, 100); Goo::Canvas::Ellipse->new( $group, 0, 0, 50, 50, 'stroke-color' => 'black', 'fill-color' => 'wheat', 'line-width' => 3, ); Goo::Canvas::Ellipse->new( $group, 0, 0, 25, 25, 'fill-color' => 'steelblue', ); $group->{parent1} = $parent1; $group->{parent2} = $parent2; $group->signal_connect( 'button-press-event' => \&on_button_press ); return $vbox; } sub on_button_press { my ($item, $target, $ev) = @_; if ( $ev->button != 1 || $ev->type ne 'button-press' ) { return FALSE; } my $parent1 = $item->{parent1}; my $parent2 = $item->{parent2}; my $parent = $item->get_parent; my $child_num = $parent->find_child($item); $parent->remove_child($child_num); if ( $parent == $parent1 ) { $parent2->add_child($item, -1); } else { $parent1->add_child($item, -1); } return TRUE; } #}}} #{{{ Scalability package Scalability; use Gtk2; use Glib qw(TRUE FALSE); use constant { N_COLS => 5, N_ROWS => 20, PADDING => 10, }; sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my ($table, $frame, $canvas, $root, $width, $height, $pixbuf, $swin, $item); my $use_image = 1; $vbox->show; $vbox->set_border_width(4); $table = Gtk2::Table->new(2, 2, FALSE); $table->set_row_spacings(4); $table->set_col_spacings(4); $vbox->pack_start($table, TRUE, TRUE, 0); $table->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $table->attach($frame, 0,1, 0,1, ['expand', 'fill', 'shrink'], ['expand', 'fill', 'shrink'], 0, 0); $frame->show; # Create the canvas and board $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file("$FindBin::Bin/toroid.png"); if ( $use_image ) { $width = $pixbuf->get_width + 3; $height = $pixbuf->get_height + 1; } else { $width = 37; $height = 19; } $canvas = Goo::Canvas->new; $root = $canvas->get_root_item; $canvas->set_size_request( 600, 450); $canvas->set_bounds( 0, 0, N_COLS*($width+PADDING), N_ROWS*($height+PADDING)); $canvas->show; $swin = Gtk2::ScrolledWindow->new(); $swin->show; $frame->add($swin); $swin->add($canvas); for my $i( 0..N_COLS-1 ) { for my $j ( 0..N_ROWS-1 ) { if ( $use_image ) { $item = Goo::Canvas::Image->new( $root, $pixbuf, $i*($width+PADDING), $j*($height+PADDING), ); } else { $item = Goo::Canvas::Rect->new( $root, $i*($width+PADDING), $j*($height+PADDING), $width, $height, 'fill-color' => (($i+$j)%2 ? 'mediumseagreen' : 'steelblue'), ); } } } return $vbox; } #}}} #{{{ Grabs package Grabs; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($w); my $table = Gtk2::Table->new(5, 2, FALSE); $table->set_border_width(12); $table->set_row_spacings(12); $table->set_col_spacings(12); $table->show; $w = Gtk2::Label->new(<attach($w, 0,2, 0,1, [],[],0,0); $w->show; # Drawing area with explicit grabs. create_fixed ($table, 1, "Widget with Explicit Grabs:", "widget-explicit"); # Drawing area with implicit grabs. create_fixed ($table, 2, "Widget with Implicit Grabs:", "widget-implicit"); # Canvas with explicit grabs. _create_canvas ($table, 3, "Canvas with Explicit Grabs:", "canvas-explicit"); # Canvas with implicit grabs. _create_canvas ($table, 4, "Canvas with Implicit Grabs:", "canvas-implicit"); return $table; } sub create_fixed { my ($table, $row, $text, $id) = @_; my ($label, $fixed, $drawing_area, $view_id); $label = Gtk2::Label->new($text); $table->attach($label, 0, 1, $row, $row+1, [], [], 0, 0); $label->show; $fixed = Gtk2::Fixed->new; $fixed->set_has_window(TRUE); $fixed->set_events( ['exposure_mask', 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'key_press_mask', 'key_release_mask', 'enter_notify_mask', 'leave_notify_mask', 'focus_change_mask'] ); $fixed->set_size_request(200, 100); $table->attach($fixed, 1, 2, $row, $row+1, [], [], 0, 0); $fixed->show; $view_id = "$id-background"; $fixed->signal_connect( 'expose_event', \&on_widget_expose, $view_id ); $fixed->signal_connect( "enter_notify_event", \&on_widget_enter_notify, $view_id); $fixed->signal_connect( "leave_notify_event", \&on_widget_leave_notify, $view_id); $fixed->signal_connect( "motion_notify_event", \&on_widget_motion_notify, $view_id); $fixed->signal_connect( "button_press_event", \&on_widget_button_press, $view_id); $fixed->signal_connect( "button_release_event", \&on_widget_button_release, $view_id); # Left my $pos = 20; for ( 'left', 'right' ) { $drawing_area = Gtk2::DrawingArea->new; $drawing_area->set_events( ['exposure_mask', 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'key_press_mask', 'key_release_mask', 'enter_notify_mask', 'leave_notify_mask', 'focus_change_mask'] ); $drawing_area->set_size_request(60, 60); $fixed->put($drawing_area, $pos, 20); $pos += 100; $drawing_area->show; $view_id = "$id-$_"; $drawing_area->signal_connect( "enter_notify_event", \&on_widget_enter_notify, $view_id); $drawing_area->signal_connect( "leave_notify_event", \&on_widget_leave_notify, $view_id); $drawing_area->signal_connect( "motion_notify_event", \&on_widget_motion_notify, $view_id); $drawing_area->signal_connect( "button_press_event", \&on_widget_button_press, $view_id); $drawing_area->signal_connect( "button_release_event", \&on_widget_button_release, $view_id); } } sub _create_canvas { my ($table, $row, $text, $id) = @_; my ($label, $canvas, $root, $rect); $label = Gtk2::Label->new($text); $table->attach($label, 0, 1, $row, $row+1, [], [], 0, 0); $label->show; $canvas = Goo::Canvas->new; $canvas->set_size_request(200, 100); $canvas->set_bounds(0, 0, 200, 100); $table->attach($canvas, 1, 2, $row, $row+1, [], [], 0, 0); $canvas->show; $root = $canvas->get_root_item; $rect = Goo::Canvas::Rect->new( $root, 0, 0, 200, 100, 'stroke-pattern' => undef, 'fill-color' => 'yellow', ); $rect->{id} = "$id-yellow"; setup_item_signals($rect); $rect = Goo::Canvas::Rect->new( $root, 20, 20, 60, 60, 'stroke-pattern' => undef, 'fill-color' => 'blue', ); $rect->{id} = $id.'-blue'; setup_item_signals($rect); $rect = Goo::Canvas::Rect->new( $root, 120, 20, 60, 60, 'stroke-pattern' => undef, 'fill-color' => 'red', ); $rect->{id} = $id.'-red'; setup_item_signals($rect); } sub setup_item_signals { my $item = shift; $item->signal_connect( "enter_notify_event", \&on_enter_notify); $item->signal_connect( "leave_notify_event", \&on_leave_notify); $item->signal_connect( "motion_notify_event", \&on_motion_notify); $item->signal_connect( "button_press_event", \&on_button_press); $item->signal_connect( "button_release_event", \&on_button_release); } # FIXME: the box is not showed sub on_widget_expose { my ($widget, $ev, $id) = @_; print "$id received 'expose' signal\n"; $widget->style->paint_box( $widget->window, 'normal','in',$ev->area, $widget, undef, 0, 0, $widget->allocation->width, $widget->allocation->height ); return FALSE; } sub on_widget_enter_notify { my ($widget, $ev, $id) = @_; print "$id received 'enter-notify' signal\n"; return TRUE; } sub on_widget_leave_notify { my ($widget, $ev, $id) = @_; print "$id received 'leave-notify' signal\n"; return TRUE; } sub on_widget_motion_notify { my ($widget, $ev, $id) = @_; print "$id received 'motion-notify' signal(window: ", sprintf("0x%x", $ev->window->get_pointer), ")\n"; if ( $ev->is_hint ) { $ev->window->get_pointer(); } return TRUE; } sub on_widget_button_press { my ($widget, $ev, $id) = @_; print "$id received 'button-press' signal\n"; if ( $id =~ /explicit/ ) { my $mask = [ 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'enter_notify_mask', 'leave_notify_mask', ]; my $staus = $widget->window->pointer_grab(FALSE, $mask, FALSE, undef, $ev->time); if ( $staus eq 'success' ) { print "grabbed pointer\n"; } else { print "pointer grab failed\n"; } } return TRUE; } sub on_widget_button_release { my ($widget, $ev, $id) = @_; print "$id received 'button-release' signal\n"; if ( $id =~ /explicit/ ) { my $display = $widget->get_display; $display->pointer_ungrab($ev->time); print "released pointer grab\n"; } return TRUE; } sub on_enter_notify { my ($item, $target, $ev) = @_; print "$item->{id} received 'enter-notify' signal\n"; return FALSE; } sub on_leave_notify { my ($item, $target, $ev) = @_; print "$item->{id} received 'leave-notify' signal\n"; return FALSE; } sub on_motion_notify { my ($item, $target, $ev) = @_; print "$item->{id} received 'motion-notify' signal\n"; return FALSE; } sub on_button_press { my ($item, $target, $ev) = @_; print "$item->{id} received 'button-press' signal\n"; if ( $item->{id} =~ /explicit/ ) { my $mask = [ 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'enter_notify_mask', 'leave_notify_mask', ]; my $canvas = $item->get_canvas; my $staus = $canvas->pointer_grab( $item, $mask, undef, $ev->time); if ( $staus eq 'success' ) { print "grabbed pointer\n"; } else { print "pointer grab failed\n"; } } return FALSE; } sub on_button_release { my ($item, $target, $ev) = @_; print "$item->{id} received 'button-released' signal\n"; if ( $item->{id} =~ /explicit/ ) { my $canvas = $item->get_canvas; $canvas->pointer_ungrab($item, $ev->time); print "released pointer grab\n"; } return FALSE; } #}}} #{{{ Events package Events; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my ($alignment, $frame, $label, $canvas); $vbox->show; $vbox->set_border_width(4); # Instructions $label = Gtk2::Label->new(<show; $vbox->pack_start($label, FALSE, FALSE, 0); # Frame and canvas $alignment = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($alignment, FALSE, FALSE, 0); $alignment->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $alignment->add($frame); $frame->show; $canvas = Goo::Canvas->new; $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 600, 450); $frame->add($canvas); $canvas->show; create_events_area($canvas, 0, 'none', 'none'); create_events_area($canvas, 1, 'visible-painted', 'visible-painted'); create_events_area($canvas, 2, 'visible-fill', 'visible-fill'); create_events_area($canvas, 3, 'visible-stroke', 'visible-stroke'); create_events_area($canvas, 4, 'visible', 'visible'); create_events_area($canvas, 5, 'painted', 'painted'); create_events_area($canvas, 6, 'fill', 'fill'); create_events_area($canvas, 7, 'stroke', 'stroke'); create_events_area($canvas, 8, 'all', 'all'); return $vbox; } sub create_events_area { my ($canvas, $area_num, $pointer_events, $label) = @_; my $row = int($area_num/3); my $col = $area_num%3; my $x = $col * 200; my $y = $row * 150; my $root = $canvas->get_root_item; my $dash = Goo::Canvas::LineDash->new([5, 5]); my $rect; # Create invisible item $rect = Goo::Canvas::Rect->new( $root, $x+45, $y+35, 30, 30, 'fill-color' => 'red', 'visibility' => 'invisible', 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' invisible'; setup_item_signals($rect); # Display a thin rect around it to indicate it is there $rect = Goo::Canvas::Rect->new( $root, $x+42.5, $y+32.5, 36, 36, 'line-dash' => $dash, 'line-width' => 1, 'stroke-color' => 'gray', ); # Create unpainted item. $rect = Goo::Canvas::Rect->new( $root, $x+85, $y+35, 30, 30, 'stroke-pattern' => undef, 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' unpainted'; setup_item_signals($rect); # Display a thin rect around it to indicate it is there $rect = Goo::Canvas::Rect->new( $root, $x+82.5, $y+32.5, 36, 36, 'line-dash' => $dash, 'line-width' => 1, 'stroke-color' => 'gray', ); # Create stroked item $rect = Goo::Canvas::Rect->new( $root, $x+125, $y+35, 30, 30, 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' stroked'; setup_item_signals($rect); # Create filled item $rect = Goo::Canvas::Rect->new( $root, $x+60, $y+75, 30, 30, 'fill-color' => 'red', 'stroke-pattern' => undef, 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' filled'; setup_item_signals($rect); # Create filled & filled item $rect = Goo::Canvas::Rect->new( $root, $x+100, $y+75, 30, 30, 'fill-color' => 'red', 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' filled & filled'; setup_item_signals($rect); Goo::Canvas::Text->new( $root, $label, $x+100, $y+130, -1, 'center', 'font' => 'Sans 12', 'fill-color' => 'blue', ); } sub setup_item_signals { my $item = shift; $item->signal_connect( 'motion_notify_event' => \&on_motion_notify ); } sub on_motion_notify { my $item = shift; print "$item->{id} received 'motion-notify' signal\n"; } #}}} #{{{ Paths package Paths; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $swin->add($canvas); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; my $root = $canvas->get_root_item; my $path; $path = Goo::Canvas::Path->new( $root, "M 20 20 L 40 40", ); $path = Goo::Canvas::Path->new( $root, "M30 20 l20, 20", ); $path = Goo::Canvas::Path->new( $root, "M 60 20 H 80", ); $path = Goo::Canvas::Path->new( $root, "M60 40 h20", ); $path = Goo::Canvas::Path->new( $root, "M 100,20 V 40", ); $path = Goo::Canvas::Path->new( $root, "M 120 20 v 20", ); $path = Goo::Canvas::Path->new( $root, "M 140 20 h20 v20 h-20 z", ); $path = Goo::Canvas::Path->new( $root, "M 180 20 h20 v20 h-20 z m 5,5 h10 v10 h-10 z", "fill-color", "red", "fill-rule", 'even_odd', ); $path = Goo::Canvas::Path->new( $root, "M 220 20 L 260 20 L 240 40 z", "fill-color", "red", "stroke-color", "blue", "line-width", 3.0, ); # Test the bezier curve commands: CcSsQqTt. $path = Goo::Canvas::Path->new( $root, "M20,100 C20,50 100,50 100,100 S180,150 180,100", ); $path = Goo::Canvas::Path->new( $root, "M220,100 c0,-50 80,-50 80,0 s80,50 80,0", ); $path = Goo::Canvas::Path->new( $root, "M20,200 Q60,130 100,200 T180,200", ); $path = Goo::Canvas::Path->new( $root, "M220,200 q40,-70 80,0 t80,0", ); # Test the elliptical arc commands: Aa. $path = Goo::Canvas::Path->new( $root, "M200,500 h-150 a150,150 0 1,0 150,-150 z", "fill-color", "red", "stroke-color", "blue", "line-width", 5.0, ); $path = Goo::Canvas::Path->new( $root, "M175,475 v-150 a150,150 0 0,0 -150,150 z", "fill-color", "yellow", "stroke-color", "blue", "line-width", 5.0, ); $path = Goo::Canvas::Path->new( $root, "M400,600 l 50,-25 " . "a25,25 -30 0,1 50,-25 l 50,-25 " . "a25,50 -30 0,1 50,-25 l 50,-25 " . "a25,75 -30 0,1 50,-25 l 50,-25 " . "a25,100 -30 0,1 50,-25 l 50,-25", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::Path->new( $root, "M 525,75 a100,50 0 0,0 100,50", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::Path->new( $root, "M 725,75 a100,50 0 0,1 100,50", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::Path->new( $root, "M 525,200 a100,50 0 1,0 100,50", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::Path->new( $root, "M 725,200 a100,50 0 1,1 100,50", "stroke-color", "red", "line-width", 5.0, ); } #}}} #{{{ Focus package Focus; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($label, $swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $label = Gtk2::Label->new("Use Tab, Shift+Tab or the arrow keys to move the keyboard focus between the canvas items."); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->can_focus(TRUE); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $swin->add($canvas); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; create_focus_box ($canvas, 110, 80, 50, 30, "red"); create_focus_box ($canvas, 300, 160, 50, 30, "orange"); create_focus_box ($canvas, 500, 50, 50, 30, "yellow"); create_focus_box ($canvas, 70, 400, 50, 30, "blue"); create_focus_box ($canvas, 130, 200, 50, 30, "magenta"); create_focus_box ($canvas, 200, 160, 50, 30, "green"); create_focus_box ($canvas, 450, 450, 50, 30, "cyan"); create_focus_box ($canvas, 300, 350, 50, 30, "grey"); create_focus_box ($canvas, 900, 900, 50, 30, "gold"); create_focus_box ($canvas, 800, 150, 50, 30, "thistle"); create_focus_box ($canvas, 600, 800, 50, 30, "azure"); create_focus_box ($canvas, 700, 250, 50, 30, "moccasin"); create_focus_box ($canvas, 500, 100, 50, 30, "cornsilk"); create_focus_box ($canvas, 200, 750, 50, 30, "plum"); create_focus_box ($canvas, 400, 800, 50, 30, "orchid"); } sub create_focus_box { my ($canvas, $x, $y, $width, $height, $color) = @_; my $root = $canvas->get_root_item; my $item = Goo::Canvas::Rect->new( $root, $x, $y, $width, $height, 'stroke-pattern' => undef, 'fill-color' => $color, 'line-width' => 5, 'can-focus' => TRUE, ); $item->{id} = $color; $item->signal_connect('focus_in_event' => \&on_focus_in); $item->signal_connect('focus_out_event' => \&on_focus_out); $item->signal_connect('button_press_event' => \&on_button_press); $item->signal_connect('key_press_event' => \&on_key_press); } sub on_key_press { my($item, $target, $ev) = @_; print $item->{id} || "Unknown", " received key_press event\n"; return FALSE; } sub on_button_press { my($item, $target, $ev) = @_; print $item->{id} || "Unknown", " received button_press event\n"; my $canvas = $item->get_canvas; $canvas->grab_focus($item); return TRUE; } sub on_focus_out { my ($item, $target, $ev) = @_; print $item->{id} || "Unknown", " received focus_out event\n"; $item->set("stroke-pattern" => undef); return FALSE; } sub on_focus_in { my ($item, $target, $ev) = @_; print $item->{id} || "Unknown", " received focus_in event\n"; $item->set("stroke-color" => "black"); return FALSE; } #}}} #{{{ Animation package Animation; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($hbox, $w, $swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $hbox = Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); $hbox->show; $w = Gtk2::ToggleButton->new('Start Animation'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect('toggled', \&toggle_animation_clicked); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $w->{canvas} = $canvas; $swin->add($canvas); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; my $root = $canvas->get_root_item; my ($rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2); # Absolute $ellipse1 = Goo::Canvas::Ellipse->new( $root, 0, 0, 25, 15, 'fill-color' => 'blue', ); $ellipse1->translate(100, 100); $rect1 = Goo::Canvas::Rect->new( $root, -10, -10, 20, 20, 'fill-color' => 'blue', ); $rect1->translate(100, 200); $rect3 = Goo::Canvas::Rect->new( $root, -10, -10, 20, 20, 'fill-color' => 'blue', ); $rect3->translate(200, 200); # Relative $ellipse2 = Goo::Canvas::Ellipse->new( $root, 0, 0, 25, 15, 'fill-color' => 'red', ); $ellipse2->translate(100, 400); $rect2 = Goo::Canvas::Rect->new( $root, -10, -10, 20, 20, 'fill-color' => 'red', ); $rect2->translate(100, 500); $rect4 = Goo::Canvas::Rect->new( $root, -10, -10, 20, 20, 'fill-color' => 'red', ); $rect4->translate(200, 500); $canvas->{items} = [$rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2]; } sub toggle_animation_clicked { my $but = shift; if ( $but->get_active ) { $but->set_label('Stop Animation'); start_animation($but); } else { $but->set_label('Start Animation'); stop_animation($but); } } sub start_animation { my $but = shift; my ($rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2) = @{$but->{canvas}{items}}; # Absolute $ellipse1->set_simple_transform (100, 100, 1, 0); $ellipse1->animate (500, 100, 2, 720, TRUE, 2000, 40, 'bounce'); $rect1->set_simple_transform (100, 200, 1, 0); $rect1->animate (100, 200, 1, 350, TRUE, 40 * 36, 40, 'restart'); $rect3->set_simple_transform (200, 200, 1, 0); $rect3->animate (200, 200, 3, 0, TRUE, 400, 40, 'bounce'); # Relative $ellipse2->set_simple_transform (100, 400, 1, 0); $ellipse2->animate (400, 0, 2, 720, FALSE, 2000, 40, 'bounce'); $rect2->set_simple_transform (100, 500, 1, 0); $rect2->animate (0, 0, 1, 350, FALSE, 40 * 36, 40, 'restart'); $rect4->set_simple_transform (200, 500, 1, 0); $rect4->animate (0, 0, 3, 0, FALSE, 400, 40, 'bounce'); } sub stop_animation { my $but = shift; my ($rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2) = @{$but->{canvas}{items}}; $ellipse1->stop_animation (); $ellipse2->stop_animation (); $rect1->stop_animation (); $rect2->stop_animation (); $rect3->stop_animation (); $rect4->stop_animation (); } #}}} #{{{ Clipping package Clipping; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($hbox, $swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $swin->add($canvas); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; my $root = $canvas->get_root_item; my $item; $item = Goo::Canvas::Ellipse->new( $root, 0, 0, 50, 30, 'fill-color' => 'blue', ); $item->translate(100, 100); $item->rotate(30, 0, 0); $item->signal_connect('button-press-event' => \&on_button_press, "Blue ellipse (unclipped)"); $item = Goo::Canvas::Rect->new( $root, 200, 50, 100, 100, 'fill-color' => 'red', 'clip-fill-rule' => 'even-odd' ); $item->signal_connect('button-press-event' => \&on_button_press, "Red rectangle (unclipped)"); $item = Goo::Canvas::Rect->new( $root, 380, 50, 100, 100, 'fill-color' => 'yellow' ); $item->signal_connect('button-press-event' => \&on_button_press, "Yellow rectangle(unclipped)"); # clipped items $item = Goo::Canvas::Ellipse->new( $root, 0, 0, 50, 30, 'fill-color' => 'blue', 'clip-path' => "M 0 0 h 100 v 100 h -100 Z" ); $item->translate (100, 300); $item->rotate (30, 0, 0); $item->signal_connect('button-press-event' => \&on_button_press, "Blue ellipse"); $item = Goo::Canvas::Rect->new( $root, 200, 250, 100, 100, 'fill-color' => 'red', 'clip-path' => "M 250 300 h 100 v 100 h -100 Z", 'clip-fill-rule' => 'even-odd' ); $item->signal_connect('button-press-event' => \&on_button_press, "Red rectangle"); $item = Goo::Canvas::Rect->new( $root, 380, 250, 100, 100, 'fill-color' => 'yellow', 'clip-path' => "M480,230 l40,100 l-80 0 z", ); $item->signal_connect('button-press-event' => \&on_button_press, 'Yellow rectangle'); # Table with clipped items my $table = Goo::Canvas::Table->new($root); $table->translate (200, 400); $table->rotate (30, 0, 0); $item = Goo::Canvas::Ellipse->new( $table, 0, 0, 50, 30, 'fill-color' => 'blue', 'clip-path' => "M 0 0 h 100 v 100 h -100 Z", ); $item->translate (100, 300); $item->rotate (30, 0, 0); $item->signal_connect('button-press-event' => \&on_button_press, 'Blue ellipse'); $item = Goo::Canvas::Rect->new( $table, 200, 250, 100, 100, 'fill-color' => 'red', "clip-path" => "M 250 300 h 100 v 100 h -100 Z", "clip-fill-rule" => 'even-odd', ); $table->set_child_properties( $item, 'column' => 1, ); $item->signal_connect('button-press-event' => \&on_button_press, 'Red rectangle'); $item = Goo::Canvas::Rect->new( $table, 380, 250, 100, 100, 'fill-color' => 'yellow', 'clip-path' => "M480,230 l40,100 l-80 0 z" ); $table->set_child_properties( $item, 'column' => 2, ); $item->signal_connect('button-press-event' => \&on_button_press, 'Yellow rectangle'); } sub on_button_press { my ($item, $target, $ev, $id) = @_; printf "%s received 'button-press' at %g, %g, (root: %g, %g)\n", $id, $ev->x, $ev->y, $ev->x_root, $ev->y_root; return TRUE; } #}}} Goo-Canvas-0.06/demo/table.pl0000755000175000017500000001331310677127407014147 0ustar ywbywb#!/usr/bin/perl -w # table.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/26 19:32:49 # Author: Ye Wenbin use strict; use warnings; use FindBin qw/$Bin/; use lib "$Bin/../blib/arch"; use lib "$Bin/../blib/lib"; use Goo::Canvas; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use constant { DEMO_RECT_ITEM => 0, DEMO_TEXT_ITEM => 1, DEMO_WIDGET_ITEM => 2, }; use Data::Dumper qw(Dumper); my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); my $vbox = Gtk2::VBox->new(FALSE, 4); $vbox->set_border_width(4); $window->add($vbox); my $hbox = Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); my $swin = Gtk2::ScrolledWindow->new; $swin->set_shadow_type('in'); $vbox->pack_start($swin, TRUE, TRUE, 0); my $canvas = Goo::Canvas->new; $canvas->can_focus(TRUE); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $swin->add($canvas); my $root = $canvas->get_root_item; create_demo_table($root) if 1; if ( 1 ) { create_table($root, -1, -1, 0, 10, 10, 0, 1.0, DEMO_TEXT_ITEM); create_table($root, -1, -1, 0, 180, 10, 30, 1.0, DEMO_TEXT_ITEM); create_table($root, -1, -1, 0, 350, 10, 60, 1.0, DEMO_TEXT_ITEM); create_table($root, -1, -1, 0, 500, 10, 90, 1.0, DEMO_TEXT_ITEM); } if ( 1 ) { my $table = create_table($root, -1, -1, 0, 30, 150, 0, 1.0, DEMO_TEXT_ITEM); $table->set( width => 300, height => 100 ); } create_table($root, -1, -1, 1, 200, 200, 30, 0.8, DEMO_TEXT_ITEM) if 1; if ( 1 ) { my $table = create_table($root, -1, -1, 0, 10, 700, 0, 1.0, DEMO_WIDGET_ITEM); $table->set( width => 300, height => 100 ); } $window->show_all(); # FIXME: get warnings Gtk2->main; sub create_demo_table { my $root = shift; my $table = Goo::Canvas::Table->new( $root, 'row-spacing' => 4, 'column-spacing' => 4, ); $table->translate(400, 200); my $square = Goo::Canvas::Rect->new( $table, 0, 0, 50, 50, 'fill-color' => 'red', ); $table->set_child_properties( $square, 'row' => 0, 'column' => 0, ); my $circle = Goo::Canvas::Ellipse->new( $table, 0, 0, 25, 25, 'fill-color' => 'blue', ); $table->set_child_properties( $circle, 'row' => 0, 'column' => 1, ); my $triangle = Goo::Canvas::Polyline->new( $table, TRUE, [25,0, 0,50, 50,50], 'fill-color' => 'yellow', ); $table->set_child_properties( $triangle, 'row' => 0, 'column' => 2, ); } sub create_table { my ($parent, $row, $col, $embedding_level, $x, $y, $rotation, $scale, $demo_item_type) = @_; my $table = Goo::Canvas::Table->new( $parent, 'row-spacing' => 4, 'column-spacing' => 4, ); $table->translate($x, $y); $table->rotate($rotation, 0, 0); $table->scale($scale, $scale); if ( $row != -1 ) { $parent->set_child_properties( $table, "row" => $row, "column" => $col, 'x-expand' => TRUE, 'y-fill' => FALSE, ); } if ( $embedding_level ) { my $level = $embedding_level -1; create_table($table, 0, 0, $level, 50, 50, 0, 0.7, $demo_item_type); create_table($table, 0, 1, $level, 50, 50, 45, 1.0, $demo_item_type); create_table($table, 0, 2, $level, 50, 50, 90, 1.0, $demo_item_type); create_table($table, 1, 0, $level, 50, 50, 135, 1.0, $demo_item_type); create_table($table, 1, 1, $level, 50, 50, 180, 1.5, $demo_item_type); create_table($table, 1, 2, $level, 50, 50, 225, 1.0, $demo_item_type); create_table($table, 2, 0, $level, 50, 50, 270, 1.0, $demo_item_type); create_table($table, 2, 1, $level, 50, 50, 315, 1.0, $demo_item_type); create_table($table, 2, 2, $level, 50, 50, 360, 2.0, $demo_item_type); } else { create_demo_item ($table, $demo_item_type, 0, 0, 1, 1, "(0,0)"); create_demo_item ($table, $demo_item_type, 0, 1, 1, 1, "(1,0)"); create_demo_item ($table, $demo_item_type, 0, 2, 1, 1, "(2,0)"); create_demo_item ($table, $demo_item_type, 1, 0, 1, 1, "(0,1)"); create_demo_item ($table, $demo_item_type, 1, 1, 1, 1, "(1,1)"); create_demo_item ($table, $demo_item_type, 1, 2, 1, 1, "(2,1)"); create_demo_item ($table, $demo_item_type, 2, 0, 1, 1, "(0,2)"); create_demo_item ($table, $demo_item_type, 2, 1, 1, 1, "(1,2)"); create_demo_item ($table, $demo_item_type, 2, 2, 1, 1, "(2,2)"); } return $table; } sub create_demo_item { my ($table, $demo_item_type, $row, $column, $rows, $columns, $text) = @_; my ($widget, $item); if ( $demo_item_type == DEMO_RECT_ITEM ) { $item = Goo::Canvas::Rect->new( $table, 0, 0, 38, 19, 'fill-color' => 'red', ); } elsif ( $demo_item_type == DEMO_TEXT_ITEM ) { $item = Goo::Canvas::Text->new( $table, $text, 0, 0, -1, 'nw' ); } elsif ( $demo_item_type == DEMO_WIDGET_ITEM ) { $widget = Gtk2::Button->new_with_label($text); $item = Goo::Canvas::Widget->new( $table, $widget, 0, 0, -1,-1 ); } $table->set_child_properties( $item, 'row' => $row, 'column' => $column, 'rows' => $rows, 'columns' => $columns, 'x-expand' => TRUE, 'x-fill' => TRUE, 'y-expand' => TRUE, 'y-fill' => TRUE, ); $item->{id} = $text; $item->signal_connect("button-press-event", \&on_button_press); } sub on_button_press { my $item = shift; print "$item->{id} is pressed\n"; return FALSE; } Goo-Canvas-0.06/demo/mv-demo.pl0000755000175000017500000021632710702161623014421 0ustar ywbywb#!/usr/bin/perl -w # mv-demo.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/26 13:31:45 # Author: Ye Wenbin use strict; use warnings; use FindBin qw/$Bin/; use lib "$Bin/../blib/arch"; use lib "$Bin/../blib/lib"; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use Goo::Canvas; my $window = create_window(); Gtk2->main; #{{{ Main window sub create_window { my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); $window->show; my $notebook = Gtk2::Notebook->new; $window->add($notebook); $notebook->show; foreach my $pkg ( "Primitives", "Arrowhead", "Fifteen", "Reparent", "Scalability", "Grabs", "Events", "Paths", "Focus", "Animation", "Clipping", ) { $notebook->append_page( $pkg->create_canvas(), Gtk2::Label->new($pkg) ); } return $window; } #}}} #{{{ Primitives package Primitives; use Gtk2; use Glib qw(TRUE FALSE); use constant { VERTICES => 10, RADIUS => 60, SCALE => 7, }; use Math::Trig qw/pi/; sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my $group; my ($hbox, $w, $swin, $canvas, $adj); my $bg_color = Gtk2::Gdk::Color->new(50000, 50000, 65535); $vbox->set_border_width(4); $vbox->show; $w = Gtk2::Label->new("Drag an item with button 1. Click button 2 on an item to lower it, or button 3 to raise it."); $vbox->pack_start($w, FALSE, FALSE, 0); $w->show; $hbox = Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); $hbox->show; # Create the canvas $canvas = Goo::Canvas->new; $canvas->modify_base('normal', $bg_color); $canvas->set_bounds(0, 0, 604, 454); ###### Frist Row # Zoom $w = Gtk2::Label->new("Zoom:"); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $adj = Gtk2::Adjustment->new(1, 0.05, 100, 0.05, 0.5, 0.5); $w = Gtk2::SpinButton->new($adj, 0, 2); $adj->signal_connect("value-changed", \&zoom_changed, $canvas); $w->set_size_request(50, -1); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; # Center $w = Gtk2::CheckButton->new_with_label("Center scroll region"); $hbox->pack_start($w, FALSE, FALSE, 0); # $w->show; $w->signal_connect("toggled", \¢er_toggled, $canvas); # Move Ellipse $w = Gtk2::Button->new_with_label('Move Ellipse'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&move_ellipse_clicked, $canvas); # Animate Ellipse $w = Gtk2::Button->new_with_label('Animate Ellipse'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&animate_ellipse_clicked, $canvas); # Stop Animation $w = Gtk2::Button->new_with_label('Stop Animation'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&stop_animation_clicked, $canvas); # Create PDF $w = Gtk2::Button->new_with_label('Write PDF'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&write_pdf_clicked, $canvas); ##### Start anothor Row $hbox = Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); $hbox->show; # Scroll to $w = Gtk2::Label->new('Scroll to:'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w = Gtk2::Button->new_with_label('50,50'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&scroll_to_50_50_clicked, $canvas); $w = Gtk2::Button->new_with_label('250,250'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&scroll_to_250_250_clicked, $canvas); $w = Gtk2::Button->new_with_label('500,500'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect("clicked", \&scroll_to_500_500_clicked, $canvas); # Scroll anchor $w = Gtk2::Label->new('Anchor:'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; foreach my $anchor( 'NW', 'N', 'NE', 'W', 'SW', 'S', 'SE' ) { $w = Gtk2::RadioButton->new_with_label($group, $anchor); $group = $w; $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect('toggled', \&anchor_toggled, $canvas); $w->{anchor} = lc($anchor); } # Layout the stuff $swin = Gtk2::ScrolledWindow->new(); $swin->show; $vbox->pack_start($swin, TRUE, TRUE, 0); $canvas->show; $swin->add($canvas); $canvas->signal_connect('item-created', \&on_item_created); my $model = Goo::Canvas::GroupModel->new; create_model($model); $canvas->set_root_item_model($model); if ( 0 ) { $canvas->signal_connect_after('key_press_event', \&key_press); $canvas->can_focus(TRUE); $canvas->grab_focus; } return $vbox; } sub create_model { my $root = shift; setup_divisions($root); setup_rectangles($root); setup_ellipses($root); setup_lines($root); setup_polygons($root); setup_texts($root); setup_images($root); setup_invisible_texts($root); } sub setup_divisions { my $root = shift; my ($group, $item); $group = Goo::Canvas::GroupModel->new($root); $group->{'skip-signal-connection'} = TRUE; $group->translate(2, 2); $item = Goo::Canvas::RectModel->new( $group, 0, 0, 600, 450, 'line-width' => 4 ); $item->{'skip-signal-connection'} = TRUE; $item = Goo::Canvas::PolylineModel->new_line( $group, 0, 150, 600, 150, 'line-width' => 4, ); $item->{'skip-signal-connection'} = TRUE; $item = Goo::Canvas::PolylineModel->new_line( $group, 0, 300, 600, 300, 'line-width' => 4, ); $item->{'skip-signal-connection'} = TRUE; $item = Goo::Canvas::PolylineModel->new_line( $group, 200, 0, 200, 450, 'line-width' => 4, ); $item->{'skip-signal-connection'} = TRUE; $item = Goo::Canvas::PolylineModel->new_line( $group, 400, 0, 400, 450, 'line-width' => 4, ); $item->{'skip-signal-connection'} = TRUE; setup_heading ($group, "Rectangles", 0); setup_heading ($group, "Ellipses", 1); setup_heading ($group, "Texts", 2); setup_heading ($group, "Images", 3); setup_heading ($group, "Lines", 4); setup_heading ($group, "Polygons", 7); } sub setup_heading { my ($root, $text, $pos) = @_; my $x = ($pos%3)*200 + 100; my $y = (int($pos/3))*150 + 5; my $item = Goo::Canvas::TextModel->new( $root, $text, $x, $y, -1, 'n', 'font' => 'Sans 12' ); $item->skew_y(30, $x, $y); } sub setup_rectangles { my $root = shift; my ($item, $pattern); my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); $item = Goo::Canvas::RectModel->new( $root, 20, 30, 50, 30, 'stroke-color' => 'red', 'line-width' => 8, ); $pattern = create_stipple('mediumseagreen', \@stipple_data); $item = Goo::Canvas::RectModel->new( $root, 90, 40, 90, 60, 'fill-pattern' => $pattern, 'stroke-color' => 'black', 'line-width' => 4, ); $item = Goo::Canvas::RectModel->new( $root, 10, 80, 70, 60, 'fill-color' => 'steelblue', ); $item = Goo::Canvas::RectModel->new( $root, 20, 90, 70, 60, 'fill-color-rgba' => 0x3cb37180, 'stroke-color' => 'blue', 'line-width' => 2, ); $item = Goo::Canvas::RectModel->new( $root, 110, 80, 50, 30, 'radius-x' => 20, 'radius-y' => 10, 'stroke-color' => 'yellow', 'fill-color-rgba' => 0x3cb3f180, ); $item = Goo::Canvas::RectModel->new( $root, 30, 20, 50, 30, 'fill-color' => 'yellow', ); } sub create_stipple { our @stipples; my($color_name, $stipple_data) = @_; my $color = Gtk2::Gdk::Color->parse($color_name); $stipple_data->[2] = $stipple_data->[14] = $color->red >> 8; $stipple_data->[1] = $stipple_data->[13] = $color->green >> 8; $stipple_data->[0] = $stipple_data->[12] = $color->blue >> 8; my $stipple_str = join('', map {chr} @$stipple_data); push @stipples, \$stipple_str; # make $stipple_str refcnt increase my $surface = Cairo::ImageSurface->create_for_data( $stipple_str, 'argb32', 2, 2, 8 ); my $pattern = Cairo::SurfacePattern->create($surface); $pattern->set_extend('repeat'); return Goo::Cairo::Pattern->new($pattern); } sub setup_ellipses { my $root = shift; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my $ellipse1 = Goo::Canvas::EllipseModel->new( $root, 245, 45, 25, 15, 'stroke-color' => 'goldenrod', 'line-width' => 8 ); my $ellipse2 = Goo::Canvas::EllipseModel->new( $root, 335, 70, 45, 30, 'fill-color' => 'wheat', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'An ellipse' ); $root->{ellipse} = $ellipse2; my $pattern = create_stipple('cadetblue', \@stipple_data); my $ellipse3 = Goo::Canvas::EllipseModel->new( $root, 245, 110, 35, 30, 'fill-pattern' => $pattern, 'stroke-color' => 'black', 'line-width' => 1, ); } sub setup_lines { my $root = shift; my $line; polish_diamond($root); make_hilbert($root); $line = Goo::Canvas::PolylineModel->new( $root, FALSE, [ 340, 170, 340, 230, 390, 230, 390, 170 ], 'stroke-color' => 'midnightblue', 'line-width' => 3, 'start-arrow' => TRUE, 'end-arrow' => TRUE, 'arrow-tip-length' => 3, 'arrow-length' => 4, 'arrow-width' => 3.5 ); $line = Goo::Canvas::PolylineModel->new( $root, FALSE, [ 356, 180, 374, 220, ], 'stroke-color' => 'blue', 'line-width' => 1, 'start-arrow' => TRUE, 'end-arrow' => TRUE, 'arrow-tip-length' => 5, 'arrow-length' => 6, 'arrow-width' => 6, ); $line = Goo::Canvas::PolylineModel->new( $root, FALSE, [356, 220, 374, 180,], 'stroke-color' => 'blue', 'line-width' => 1, 'start-arrow' => TRUE, 'end-arrow' => TRUE, 'arrow-tip-length' => 5, 'arrow-length' => 6, 'arrow-width' => 6, ); $line = Goo::Canvas::PolylineModel->new($root, FALSE, []); $line = Goo::Canvas::PolylineModel->new( $root, FALSE, [356, 220], 'start-arrow' => TRUE, 'end-arrow' => TRUE, ); } sub polish_diamond { my $root = shift; my $item; my ($a, $x1, $y1, $x2, $y2); my $group = Goo::Canvas::GroupModel->new( $root, 'line-width' => 1, 'line-cap' => 'round' ); $group->translate(270, 230); for my $i ( 0..VERTICES ) { $a = 2*pi*$i/VERTICES; $x1 = RADIUS * cos($a); $y1 = RADIUS * sin($a); for my $j ( $i+1..VERTICES ) { $a = 2*pi*$j/VERTICES; $x2 = RADIUS * cos($a); $y2 = RADIUS * sin($a); $item = Goo::Canvas::PolylineModel->new_line( $group, $x1, $y1, $x2, $y2 ); $item->{'skip-signal-connection'} = TRUE; } } } sub make_hilbert { my $root = shift; my $hilbert = "urdrrulurulldluuruluurdrurddldrrruluurdrurddldrddlulldrdldrrurd"; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my $pattern = create_stipple('red', \@stipple_data); my @points = ( [340, 290] ); my $pp = $points[0]; foreach ( 0..length($hilbert)-1 ) { my @p; my $c = substr($hilbert, $_, 1); if ( $c eq 'u' ) { $p[0] = $pp->[0]; $p[1] = $pp->[1] - SCALE; } elsif ( $c eq 'd' ) { $p[0] = $pp->[0]; $p[1] = $pp->[1] + SCALE; } elsif ( $c eq 'l' ) { $p[0] = $pp->[0] - SCALE; $p[1] = $pp->[1]; } elsif ( $c eq 'r' ) { $p[0] = $pp->[0] + SCALE; $p[1] = $pp->[1]; } push @points, \@p; $pp = \@p; } my $item = Goo::Canvas::PolylineModel->new( $root, FALSE, [map {@{$_}} @points], 'line-width' => 4, 'stroke-pattern' => $pattern, 'line-cap' => 'square', 'line-join' => 'miter' ); } sub setup_polygons { my $root = shift; my $line; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my @points = ( 210, 320, 210, 380, 260, 350 ); my $pattern = create_stipple('blue', \@stipple_data); $line = Goo::Canvas::PolylineModel->new( $root, TRUE, \@points, 'line-width' => 1, 'fill-pattern' => $pattern, 'stroke-color' => 'black' ); @points = ( 270.0, 330.0, 270.0, 430.0, 390.0, 430.0, 390.0, 330.0, 310.0, 330.0, 310.0, 390.0, 350.0, 390.0, 350.0, 370.0, 330.0, 370.0, 330.0, 350.0, 370.0, 350.0, 370.0, 410.0, 290.0, 410.0, 290.0, 330.0, ); $line = Goo::Canvas::PolylineModel->new( $root, TRUE, \@points, 'fill-color' => 'tan', 'stroke-color' => 'black', 'line-width' => 3, ); } sub setup_texts { my $root = shift; my @stipple_data = ( 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 255 ); my $pattern = create_stipple('blue', \@stipple_data); my $item; $item = Goo::Canvas::TextModel->new( make_anchor($root, 420, 20), 'Anchor NW', 0, 0, -1, 'nw', 'font' => 'Sans Bold 24', 'fill-pattern' => $pattern, ); $item = Goo::Canvas::TextModel->new( make_anchor($root, 470, 75), "Anchor center\nJustify center\nMultiline text\nb8bit text ÅÄÖåäö", 0, 0, -1, 'center', "font" => "monospace bold 14", "alignment" => 'center', "fill-color" => "firebrick", ); $item = Goo::Canvas::TextModel->new( make_anchor($root, 590, 140), "Clipped text\nClipped text\nClipped text\nClipped text\nClipped text\nClipped text", 0, 0, -1, 'se', 'font' =>'Sans 12', 'fill-color' => 'darkgreen' ); $item = Goo::Canvas::TextModel->new( make_anchor($root, 420, 240), "This is a very long paragraph that will need to be wrapped over several lines so we can see what happens to line-breaking as the view is zoomed in and out.", 0, 0, 180, 'w', 'font' => 'Sans 12', 'fill-color' => 'goldenrod' ); } sub make_anchor { my($root, $x, $y) = @_; my $group = Goo::Canvas::GroupModel->new($root); my $transform = Goo::Cairo::Matrix->new( Cairo::Matrix->init(0.8, 0.2, -0.3, 0.5, $x, $y ), ); my $item; $group->translate($x, $y); $group->set( 'transform' => $transform ); $item = Goo::Canvas::RectModel->new( $group, -2.5, -2.5, 4, 4, 'line-width' => 1, ); return $group; } sub setup_images { my $root = shift; my ($im, $image); use Data::Dumper qw(Dumper); $im = Gtk2::Gdk::Pixbuf->new_from_file("$FindBin::Bin/toroid.png"); if ( $im ) { my $w = $im->get_width; my $h = $im->get_height; $image = Goo::Canvas::ImageModel->new( $root, $im, 100-$w/2, 225-$h/2, 'width' => $w, 'height' => $h ); } else { warn "Could not foundhe toroid.png sample file\n"; } plant_flower ($root, 20.0, 170.0, 'nw'); plant_flower ($root, 180.0, 170.0, 'ne'); plant_flower ($root, 20.0, 280.0, 'sw'); plant_flower ($root, 180.0, 280.0, 'se'); } sub plant_flower { my ($root, $x, $y, $anchor) = @_; my $surface = Cairo::ImageSurface->create_from_png("$FindBin::Bin/flower.png"); my $w = $surface->get_width; my $h = $surface->get_height; my $pattern = Cairo::SurfacePattern->create($surface); my $image = Goo::Canvas::ImageModel->new( $root, undef, $x, $y, 'pattern' => Goo::Cairo::Pattern->new($pattern), 'width' => $w, 'height' => $h, ); } sub setup_invisible_texts { my $root = shift; Goo::Canvas::TextModel->new( $root, "Visible above 0.8x", 500, 330, -1, 'center', "visibility" => 'visible_above_threshold', "visibility-threshold" => 0.8, ); Goo::Canvas::RectModel->new( $root, 410.5, 322.5, 180, 15, "line-width" => 1.0, "visibility" => 'visible-above-threshold', "visibility-threshold" => 0.8, ); Goo::Canvas::TextModel->new( $root, "Visible above 1.5x", 500, 350, -1, 'center', "visibility" => 'visible-above-threshold', "visibility-threshold" => 1.5, ); Goo::Canvas::RectModel->new( $root, 410.5, 342.5, 180, 15, "line-width" => 1.0, "visibility" => 'visible-above-threshold', "visibility-threshold" => 1.5, ); Goo::Canvas::TextModel->new( $root, "Visible above 3.0x", 500, 370, -1, 'center', "visibility" => 'visible-above-threshold', "visibility-threshold" => 3.0, ); Goo::Canvas::RectModel->new( $root, 410.5, 362.5, 180, 15, "line-width" => 1.0, "visibility" => 'visible-above-threshold', "visibility-threshold" => 3.0, ); # This should never be seen. Goo::Canvas::TextModel->new( $root, "Always Invisible", 500, 390, -1, 'center', "visibility" => 'invisible', ); Goo::Canvas::RectModel->new( $root, 410.5, 350.5, 180, 15, "line-width" => 1.0, "visibility" => 'invisible', ); } #{{{ Signals sub on_item_created { my ($canvas, $item, $model, $data) = @_; if ( ! $model->get_parent ) { $item->signal_connect('button_press_event', \&on_background_button_press); } elsif ( not $model->{'skip-signal-connection'} ) { $item->signal_connect('motion_notify_event', \&on_motion_notify); $item->signal_connect('button_press_event', \&on_button_press); $item->signal_connect('button_release_event', \&on_button_release); } } sub on_motion_notify { my ($item, $target, $ev) = @_; my $model = $item->get_model; if ( $model->{dragging} && $ev->state >= 'button1-mask' ) { $model->translate($ev->x - $model->{drag_x}, $ev->y - $model->{drag_y}); } return TRUE; } sub on_button_press { my ($item, $target, $ev) = @_; my $model = $item->get_model; if ( $ev->button == 1 ) { if ( $ev->state >= 'shift-mask' ) { my $parent = $model->get_parent; $parent->remove_child($parent->find_child($model)); } else { $model->{drag_x} = $ev->x; $model->{drag_y} = $ev->y; my $fleur = Gtk2::Gdk::Cursor->new('fleur'); my $canvas = $item->get_canvas; $canvas->pointer_grab($item, ['pointer-motion-mask', 'button-release-mask'], $fleur, $ev->time); $model->{dragging} = TRUE; } } elsif ( $ev->button == 2 ) { $model->lower; } elsif ( $ev->button == 3 ) { $model->raise; } return TRUE; } sub on_button_release { my ($item, $target, $ev) = @_; my $canvas = $item->get_canvas; $canvas->pointer_ungrab($item, $ev->time); $item->get_model->{dragging} = FALSE; return TRUE; } sub on_background_button_press { return TRUE; } sub zoom_changed { my ($adj, $canvas) = @_; $canvas->set_scale($adj->get_value); } sub center_toggled { } sub anchor_toggled { my ($but, $canvas) = @_; if ( $but->get_active ) { $canvas->set("anchor" => $but->{anchor}); } } sub scroll_to_50_50_clicked { my ($but, $canvas) = @_; $canvas->scroll_to(50, 50); } sub scroll_to_250_250_clicked { my ($but, $canvas) = @_; $canvas->scroll_to(250, 250); } sub scroll_to_500_500_clicked { my ($but, $canvas) = @_; $canvas->scroll_to(500, 500); } sub animate_ellipse_clicked { my ($but, $canvas) = @_; $canvas->get_root_item_model->{ellipse}->animate(100, 100, 1, 90, TRUE, 1000, 40, 'bounce'); } sub stop_animation_clicked { my ($but, $canvas) = @_; $canvas->get_root_item_model->{ellipse}->stop_animation(); } sub move_ellipse_clicked { my ($but, $canvas) = @_; my $ellipse = $canvas->get_root_item_model->{ellipse}; if ( !exists $ellipse->{last_state} ) { $ellipse->{last_state} = 0; } my $last_state = $ellipse->{last_state}; if ( $last_state == 0 ) { $ellipse->set( 'center-x' => 300, 'center-y' => 70, 'radius-x' => 45, 'radius-y' => 30, 'fill-color' => 'red', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'A red ellipse' ); $last_state = 1; } elsif ( $last_state == 1 ) { $ellipse->set( 'center-x' => 390, 'center-y' => 150, 'radius-x' => 45, 'radius-y' => 40, 'fill-color' => 'brown', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'A brown ellipse' ); $last_state = 2; } elsif ( $last_state == 2 ) { $ellipse->set( 'center-x' => 0, 'center-y' => 0, 'radius-y' => 30, ); $ellipse->set_simple_transform(100, 100, 1, 0); $last_state = 3; } elsif ( $last_state == 3 ) { $ellipse->set_simple_transform(200, 200, 2, 0); $last_state = 4; } elsif ( $last_state == 4 ) { $ellipse->set_simple_transform(200, 200, 1, 45); $last_state = 5; } elsif ( $last_state == 5 ) { $ellipse->set_simple_transform(-50, -50, 0.2, 225); $last_state = 6; } else { $ellipse->set( 'center-x' => 335, 'center-y' => 70, 'radius-x' => 45, 'radius-y' => 30, 'fill-color' => 'purple', 'stroke-color' => 'midnightblue', 'line-width' => 4, 'title' => 'A purple ellipse' ); $last_state = 0; } $ellipse->{last_state} = $last_state; return TRUE; } sub write_pdf_clicked { my ($but, $canvas) = @_; print "Write PDF...\n"; my $surface = Cairo::PdfSurface->create("demo.pdf", 9*72, 10*72); my $cr = Cairo::Context->create($surface); $cr->translate(20, 130); $canvas->render($cr, undef, 1); $cr->show_page; return TRUE; } #}}} #}}} #{{{ Arrowhead package Arrowhead; use Gtk2; use Glib qw(TRUE FALSE); use constant { LEFT => 50.0, RIGHT => 350.0, MIDDLE => 150.0, DEFAULT_WIDTH => 2, DEFAULT_SHAPE_A => 4, DEFAULT_SHAPE_B => 5, DEFAULT_SHAPE_C => 4, }; sub create_canvas { my $pkg = shift; my ($w, $frame, $canvas, $root, $item); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $w = Gtk2::Label->new( <pack_start($w, FALSE, FALSE, 0); $w->show; $w = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($w, TRUE, TRUE, 0); $w->show; $frame = Gtk2::Frame->new; $frame->set_shadow_type('in'); $w->add($frame); $frame->show; $canvas = Goo::Canvas->new; $canvas->set_size_request(500, 350); $canvas->set_bounds(0, 0, 500, 350); $frame->add($canvas); $canvas->show; $canvas->{width} = DEFAULT_WIDTH; $canvas->{shape_a} = DEFAULT_SHAPE_A; $canvas->{shape_b} = DEFAULT_SHAPE_B; $canvas->{shape_c} = DEFAULT_SHAPE_C; $canvas->signal_connect('item-created', \&on_item_created); $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); # Big arrow $item = Goo::Canvas::PolylineModel->new_line( $root, LEFT, MIDDLE, RIGHT, MIDDLE, 'stroke-color' => 'mediumseagreen', 'end_arrow' => TRUE, ); $canvas->{big_arrow} = $item; # Arrow outline $item = Goo::Canvas::PolylineModel->new( $root, TRUE, undef, "stroke-color" => 'black', 'line-width' => 2, 'line-cap' => 'round', 'line-join' => 'round' ); $canvas->{outline} = $item; # Drag boxes create_drag_box($canvas, $root, 'width_drag_box'); create_drag_box($canvas, $root, 'shape_a_drag_box'); create_drag_box($canvas, $root, 'shape_b_c_drag_box'); # Dimensions create_dimension ($canvas, $root, "width_arrow", "width_text", 'e'); create_dimension ($canvas, $root, "shape_a_arrow", "shape_a_text", 'n'); create_dimension ($canvas, $root, "shape_b_arrow", "shape_b_text", 'n'); create_dimension ($canvas, $root, "shape_c_arrow", "shape_c_text", 'w'); # Info create_info ($canvas, $root, "width_info", LEFT, 260); create_info ($canvas, $root, "shape_a_info", LEFT, 280); create_info ($canvas, $root, "shape_b_info", LEFT, 300); create_info ($canvas, $root, "shape_c_info", LEFT, 320); # Division line Goo::Canvas::PolylineModel->new_line( $root, RIGHT + 50, 0, RIGHT+ 50, 1000, 'fill-color' => 'black', 'line-width' => 2 ); # Sample arrows create_sample_arrow ($canvas, $root, "sample_1", RIGHT + 100, 30, RIGHT + 100, MIDDLE - 30); create_sample_arrow ($canvas, $root, "sample_2", RIGHT + 70, MIDDLE, RIGHT + 130, MIDDLE); create_sample_arrow ($canvas, $root, "sample_3", RIGHT + 70, MIDDLE + 30, RIGHT + 130, MIDDLE + 120); # Done set_arrow_shape($canvas); return $vbox; } sub set_dimension { my ($canvas, $arrow_name, $text_name, $x1, $y1, $x2, $y2, $tx, $ty, $dim) = @_; my $points = Goo::Canvas::Points->new([$x1, $y1, $x2, $y2]); $canvas->{$arrow_name}->set(points => $points); $canvas->{$text_name}->set(text => sprintf("%.2f", $dim), x => $tx, y => $ty); } sub move_drag_box { my ($item, $x, $y) = @_; $item->set(x => $x-5, y => $y-5); } sub set_arrow_shape { my $canvas = shift; my $width = $canvas->{width}; my $shape_a = $canvas->{shape_a}; my $shape_b = $canvas->{shape_b}; my $shape_c = $canvas->{shape_c}; # Big arrow $canvas->{big_arrow}->set( 'line-width' => 10*$width, 'arrow-tip-length' => $shape_a, 'arrow-length' => $shape_b, 'arrow-width' => $shape_c ); # Outline my @points; $points[0] = RIGHT -int(10 *$shape_a*$width); $points[1] = MIDDLE-int(10*$width/2); $points[2] = RIGHT - 10 * $shape_b * $width; $points[3] = MIDDLE - 10 * ($shape_c * $width / 2.0); $points[4] = RIGHT; $points[5] = MIDDLE; $points[6] = RIGHT - 10 * $shape_b * $width; $points[7] = MIDDLE + 10 * ($shape_c * $width / 2.0); $points[8] = RIGHT -int(10 *$shape_a*$width); $points[9] = MIDDLE + 10 * $width / 2; $canvas->{outline}->set( points => Goo::Canvas::Points->new(\@points) ); move_drag_box($canvas->{width_drag_box}, LEFT, MIDDLE-10*$width/2); move_drag_box($canvas->{shape_a_drag_box}, RIGHT-10*$shape_a*$width, MIDDLE); move_drag_box($canvas->{shape_b_c_drag_box}, RIGHT-10*$shape_b*$width, MIDDLE-10*($shape_c*$width/2)); # Dimensions set_dimension($canvas, 'width_arrow', 'width_text', LEFT - 10, MIDDLE - 10 * $width / 2.0, LEFT - 10, MIDDLE + 10 * $width / 2.0, LEFT - 15, MIDDLE, $width); set_dimension ($canvas, "shape_a_arrow", "shape_a_text", RIGHT - 10 * $shape_a * $width, MIDDLE + 10 * ($shape_c * $width / 2.0) + 10, RIGHT, MIDDLE + 10 * ($shape_c * $width / 2.0) + 10, RIGHT - 10 * $shape_a * $width / 2.0, MIDDLE + 10 * ($shape_c * $width / 2.0) + 15, $shape_a); set_dimension ($canvas, "shape_b_arrow", "shape_b_text", RIGHT - 10 * $shape_b * $width, MIDDLE + 10 * ($shape_c * $width / 2.0) + 35, RIGHT, MIDDLE + 10 * ($shape_c * $width / 2.0) + 35, RIGHT - 10 * $shape_b * $width / 2.0, MIDDLE + 10 * ($shape_c * $width / 2.0) + 40, $shape_b); set_dimension ($canvas, "shape_c_arrow", "shape_c_text", RIGHT + 10, MIDDLE - 10 * $shape_c * $width / 2.0, RIGHT + 10, MIDDLE + 10 * $shape_c * $width / 2.0, RIGHT + 15, MIDDLE, $shape_c); # Info $canvas->{width_info}->set( text => sprintf("line-width: %.2f", $width) ); $canvas->{shape_a_info}->set( text => sprintf("arrow-tip-length: %.2f (* line-width)", $shape_a) ); $canvas->{shape_b_info}->set( text => sprintf("arrow-length: %.2f (* line-width)", $shape_b) ); $canvas->{shape_c_info}->set( text => sprintf("arrow-width: %.2f (* line-width)", $shape_c) ); # Sample arrows for ( qw/ sample_1 sample_2 sample_3 / ) { $canvas->{$_}->set( "line-width" => $width, "arrow-tip-length" => $shape_a, "arrow-length" => $shape_b, "arrow-width" => $shape_c, ); } } sub create_dimension { my ($canvas, $root, $arrow_name, $text_name, $anchor) = @_; my $item; $item = Goo::Canvas::PolylineModel->new( $root, FALSE, undef, 'fill-color' => 'black', 'start-arrow' => TRUE, 'end-arrow' => TRUE, ); $canvas->{$arrow_name} = $item; $item = Goo::Canvas::TextModel->new( $root, "", 0, 0, -1, $anchor, 'fill-color' => 'black', 'font' => 'Sans 12', ); $canvas->{$text_name} = $item; } sub create_info { my ($canvas, $root, $info_name, $x, $y) = @_; my $item = Goo::Canvas::TextModel->new( $root, "", $x, $y, -1, 'nw', 'fill-color' => 'black', 'font' => 'Sans 12', ); $canvas->{$info_name} = $item; } sub create_sample_arrow { my ($canvas, $root, $sample_name, $x1, $y1, $x2, $y2) = @_; my $item = Goo::Canvas::PolylineModel->new_line( $root, $x1, $y1, $x2, $y2, 'start-arrow' => TRUE, 'end-arrow' => TRUE, ); $canvas->{$sample_name} = $item; } sub on_enter_notify { my ($item, $target, $ev) = @_; my $model = $target->get_model; $model->set('fill-color' => 'red'); return TRUE; } sub on_leave_notify { my ($item, $target, $ev) = @_; my $model= $target->get_model; $model->set('fill-color' => 'black'); return TRUE; } sub on_button_press { my ($item, $target, $ev) = @_; my $fleur = Gtk2::Gdk::Cursor->new('fleur'); $item->get_canvas->pointer_grab( $item, ['pointer-motion-mask', 'button-release-mask'], $fleur, $ev->time); return TRUE; } sub on_button_release { my ($item, $target, $ev) = @_; $item->get_canvas->pointer_ungrab( $item, $ev->time ); return TRUE; } sub on_motion { my ($item, $target, $ev)= @_; my $canvas = $item->get_canvas; my $model = $target->get_model; my ($x, $y, $width, $shape_a, $shape_b, $shape_c); my $change = FALSE; unless ( $ev->state >= 'button1-mask' ) { return FALSE; } if ( $model == $canvas->{width_drag_box} ) { $y = $ev->y; $width = (MIDDLE-$y)/5; if ( $width < 0) { return FALSE; } $canvas->{width} = $width; set_arrow_shape($canvas); } elsif ( $model == $canvas->{shape_a_drag_box} ) { $x = $ev->x; $width = $canvas->{width}; $shape_a = (RIGHT-$x)/10/$width; if ( ($shape_a < 0) || ($shape_a>30) ) { return FALSE; } $canvas->{shape_a} =$shape_a; set_arrow_shape($canvas); } elsif ( $model == $canvas->{shape_b_c_drag_box} ) { $x = $ev->x; $width = $canvas->{width}; $shape_b = (RIGHT-$x)/10/$width; if ( ($shape_b >= 0) && ($shape_b <=30) ) { $canvas->{shape_b} = $shape_b; $change = TRUE; } $y = $ev->y; $shape_c = (MIDDLE-$y) * 2/10/$width; if ( $shape_c >= 0 ) { $canvas->{shape_c} = $shape_c; $change = TRUE; } if ( $change ) { set_arrow_shape($canvas); } } return TRUE; } sub create_drag_box { my ($canvas, $root, $box_name) = @_; my $item = Goo::Canvas::RectModel->new( $root, 0, 0, 10, 10, 'fill-color' => 'black', 'stroke-color' => 'black', 'line-width' => 1, ); $canvas->{$box_name} = $item; } sub on_item_created { my ($canvas, $item, $model) = @_; if ( $model->isa("Goo::Canvas::RectModel")) { $item->signal_connect( 'enter_notify_event' => \&on_enter_notify ); $item->signal_connect( 'leave_notify_event' => \&on_leave_notify, ); $item->signal_connect( 'button_press_event' => \&on_button_press ); $item->signal_connect( 'button_release_event' => \&on_button_release ); $item->signal_connect( 'motion_notify_event' => \&on_motion ); } } #}}} #{{{ Fifteen package Fifteen; use Gtk2; use Glib qw(TRUE FALSE); use constant { PIECE_SIZE => 50, SCRAMBLE_MOVES => 256, }; sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my ($alignment, $frame, $canvas, $root, $button); my ($x, $y, @board); $vbox->set_border_width(4); $vbox->show; $alignment = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($alignment, TRUE, TRUE, 0); $alignment->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $alignment->add($frame); $frame->show; # Create the canvas and board $canvas = Goo::Canvas->new; $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); $canvas->signal_connect('item-created', \&on_item_created); $canvas->set_size_request( PIECE_SIZE * 4 + 1, PIECE_SIZE * 4 + 1); $canvas->set_bounds(0, 0, PIECE_SIZE * 4+1, PIECE_SIZE * 4 + 1); $frame->add($canvas); $canvas->show; foreach my $i( 0..14 ) { $x = $i % 4; $y = int($i / 4); my $item = Goo::Canvas::GroupModel->new($root); $item->translate($x * PIECE_SIZE, $y * PIECE_SIZE); my $rect = Goo::Canvas::RectModel->new( $item, 0, 0, PIECE_SIZE, PIECE_SIZE, 'fill-color' => get_piece_color($i), 'stroke-color' => 'black', 'line-width' => 1 ); my $text = Goo::Canvas::TextModel->new( $item, $i+1, PIECE_SIZE/2, PIECE_SIZE/2, -1, 'center', 'font' => 'Sans bold 24', 'fill-color' => 'black' ); $item->{text} = $text; $item->{piece_num} = $i; $item->{piece_pos} = $i; push @board, $item; } push @board, undef; $canvas->{board} = \@board; $button = Gtk2::Button->new("Scramble"); $vbox->pack_start($button, FALSE, FALSE, 0); $button->signal_connect('clicked', \&scramble, $canvas); $button->show; return $vbox; } sub get_piece_color { use integer; my $i = shift; my $x = $i % 4; my $y = $i / 4; my $r = (( 4- $x) * 255) /4; my $g = (( 4- $y) * 255) /4; my $b = 128; return sprintf("#%02x%02x%02x", $r, $g, $b); } sub piece_enter_notify { my ($item, $target, $ev)= @_; my $model = $item->get_model; $model->{text}->set( 'fill-color' => 'white' ); return FALSE; } sub piece_leave_notify { my ($item, $target, $ev)= @_; my $model = $item->get_model; $model->{text}->set( 'fill-color' => 'black' ); return FALSE; } sub piece_button_press { my ($item, $target, $event, $data) = @_; my ($num, $pos, $text, $x, $y, $move, $dx, $dy, $newpos); my $canvas = $item->get_canvas; my $model = $item->get_model; my $board = $canvas->{board}; $num = $model->{piece_num}; $pos = $model->{piece_pos}; $text = $model->{text}; $x = $pos % 4; $y = int($pos / 4); $move = TRUE; if ( $y>0 && !$board->[($y-1)*4+$x] ) { $dx = 0; $dy = -1; $y--; } elsif ( $y<3 && !$board->[($y+1)*4+$x] ) { $dx = 0; $dy = 1; $y++; } elsif ( $x>0 && !$board->[$y*4+$x-1] ) { $dx = -1; $dy = 0; $x--; } elsif ( $x<3 && !$board->[$y*4+$x+1] ) { $dx = 1; $dy = 0; $x++; } else { $move = FALSE; } if ( $move ) { $newpos = $y*4+$x; $board->[$pos] = undef; $board->[$newpos] = $model; $model->{piece_pos} = $newpos; $model->translate($dx*PIECE_SIZE, $dy*PIECE_SIZE); test_win($board, $canvas); } return FALSE; } sub test_win { my ($board, $canvas) = @_; foreach ( 0..14 ) { if ( !$board->[$_] || $board->[$_]{piece_num} != $_ ) { return; } } if ( 1 ) { my $item = ($board->[0] || $board->[1]); my $dia = Gtk2::MessageDialog->new( $canvas->get_toplevel, 'destroy-with-parent', 'info', 'ok', 'You stud, you win!', ); $dia->show; $dia->signal_connect( 'response' => sub { $dia->destroy; } ); } return TRUE; } sub on_item_created { my ($canvas, $item, $model) = @_; if ( $model->get_parent && $model->isa("Goo::Canvas::GroupModel") ) { $item->signal_connect( 'enter_notify_event' => \&piece_enter_notify ); $item->signal_connect( 'leave_notify_event' => \&piece_leave_notify, ); $item->signal_connect( 'button-press-event' => \&piece_button_press, ); } } sub scramble { my ($but, $canvas) = @_; my $board = $canvas->{board}; my ($x, $y, $dir, $oldpos); my $pos = 0; foreach ( @$board ) { last unless $_; $pos++; } for ( 0..SCRAMBLE_MOVES ) { my $done = 0; $x = $y = 0; while ( !$done ) { $dir = int(rand(4)); $done = 1; if ( $dir == 0 && $pos > 3 ) { $y = -1; } elsif ( $dir==1 && $pos < 12 ) { $y = 1; } elsif ( $dir == 2 && ($pos%4) != 0 ) { $x = -1; } elsif ( $dir == 3 && ($pos %4) != 3 ) { $x = 1; } else { $done = 0; } } $oldpos = $pos + $y*4 + $x; $board->[$pos] = $board->[$oldpos]; $board->[$oldpos] = undef; $board->[$pos]->{piece_pos} = $pos; $board->[$pos]->translate(-$x*PIECE_SIZE, -$y*PIECE_SIZE); $pos = $oldpos; } } #}}} #{{{ Reparent package Reparent; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($w, $alignment, $frame, $canvas, $root, $parent1, $parent2, $item, $group); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); # Instructions $w = Gtk2::Label->new("Reparent test: click on the items to switch them between parents"); $vbox->pack_start($w, FALSE, FALSE, 0); $w->show; # Frame and canvas $alignment = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($alignment, FALSE, FALSE, 0); $alignment->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $alignment->add($frame); $frame->show; $canvas = Goo::Canvas->new; $canvas->show; $canvas->signal_connect('item-created', \&on_item_created); $root = Goo::Canvas::GroupModel->new; $canvas->set_size_request( 400, 200); $canvas->set_bounds( 0, 0, 300, 200); $frame->add($canvas); # First parent and box $parent1 = Goo::Canvas::GroupModel->new($root); Goo::Canvas::RectModel->new( $parent1, 0, 0, 200, 200, 'fill-color' => 'tan' ); # Second parent and box $parent2 = Goo::Canvas::GroupModel->new($root); $parent2->translate(200, 0); Goo::Canvas::RectModel->new( $parent2, 0, 0, 200, 200, 'fill-color' => '#204060' ); # Big circle to be reparented $item = Goo::Canvas::EllipseModel->new( $parent1, 100, 100, 90, 90, 'stroke-color' => 'black', 'fill-color' => 'mediumseagreen', 'line-width' => 3, ); $item->{parent1} = $parent1; $item->{parent2} = $parent2; # A group to be reparented $group = Goo::Canvas::GroupModel->new($parent2); $group->{parent1} = $parent1; $group->{parent2} = $parent2; $group->translate(100, 100); Goo::Canvas::EllipseModel->new( $group, 0, 0, 50, 50, 'stroke-color' => 'black', 'fill-color' => 'wheat', 'line-width' => 3, ); Goo::Canvas::EllipseModel->new( $group, 0, 0, 25, 25, 'fill-color' => 'steelblue', ); $canvas->set_root_item_model($root); return $vbox; } sub on_item_created { my ($canvas, $item, $model) = @_; if ( $model->{parent1} ) { $item->signal_connect( 'button-press-event' => \&on_button_press ); } } sub on_button_press { my ($item, $target, $ev) = @_; if ( $ev->button != 1 || $ev->type ne 'button-press' ) { return FALSE; } my $model = $item->get_model; my $parent1 = $model->{parent1}; my $parent2 = $model->{parent2}; my $parent = $model->get_parent; my $child_num = $parent->find_child($model); $parent->remove_child($child_num); if ( $parent == $parent1 ) { $parent2->add_child($model, -1); } else { $parent1->add_child($model, -1); } return TRUE; } #}}} #{{{ Scalability package Scalability; use Gtk2; use Glib qw(TRUE FALSE); use constant { N_COLS => 5, N_ROWS => 20, PADDING => 10, }; sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my ($table, $frame, $canvas, $root, $width, $height, $pixbuf, $swin, $item); my $use_image = 1; $vbox->show; $vbox->set_border_width(4); $table = Gtk2::Table->new(2, 2, FALSE); $table->set_row_spacings(4); $table->set_col_spacings(4); $vbox->pack_start($table, TRUE, TRUE, 0); $table->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $table->attach($frame, 0,1, 0,1, ['expand', 'fill', 'shrink'], ['expand', 'fill', 'shrink'], 0, 0); $frame->show; # Create the canvas and board $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file("$FindBin::Bin/toroid.png"); if ( $use_image ) { $width = $pixbuf->get_width + 3; $height = $pixbuf->get_height + 1; } else { $width = 37; $height = 19; } $canvas = Goo::Canvas->new; $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); $canvas->set_size_request( 600, 450); $canvas->set_bounds( 0, 0, N_COLS*($width+PADDING), N_ROWS*($height+PADDING)); $canvas->show; $swin = Gtk2::ScrolledWindow->new(); $swin->show; $frame->add($swin); $swin->add($canvas); for my $i( 0..N_COLS-1 ) { for my $j ( 0..N_ROWS-1 ) { if ( $use_image ) { $item = Goo::Canvas::ImageModel->new( $root, $pixbuf, $i*($width+PADDING), $j*($height+PADDING), ); } else { $item = Goo::Canvas::RectModel->new( $root, $i*($width+PADDING), $j*($height+PADDING), $width, $height, 'fill-color' => (($i+$j)%2 ? 'mediumseagreen' : 'steelblue'), ); } } } return $vbox; } #}}} #{{{ Grabs package Grabs; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($w); my $table = Gtk2::Table->new(5, 2, FALSE); $table->set_border_width(12); $table->set_row_spacings(12); $table->set_col_spacings(12); $table->show; $w = Gtk2::Label->new(<attach($w, 0,2, 0,1, [],[],0,0); $w->show; # Drawing area with explicit grabs. create_fixed ($table, 1, "Widget with Explicit Grabs:", "widget-explicit"); # Drawing area with implicit grabs. create_fixed ($table, 2, "Widget with Implicit Grabs:", "widget-implicit"); # Canvas with explicit grabs. _create_canvas ($table, 3, "Canvas with Explicit Grabs:", "canvas-explicit"); # Canvas with implicit grabs. _create_canvas ($table, 4, "Canvas with Implicit Grabs:", "canvas-implicit"); return $table; } sub create_fixed { my ($table, $row, $text, $id) = @_; my ($label, $fixed, $drawing_area, $view_id); $label = Gtk2::Label->new($text); $table->attach($label, 0, 1, $row, $row+1, [], [], 0, 0); $label->show; $fixed = Gtk2::Fixed->new; $fixed->set_has_window(TRUE); $fixed->set_events( ['exposure_mask', 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'key_press_mask', 'key_release_mask', 'enter_notify_mask', 'leave_notify_mask', 'focus_change_mask'] ); $fixed->set_size_request(200, 100); $table->attach($fixed, 1, 2, $row, $row+1, [], [], 0, 0); $fixed->show; $view_id = "$id-background"; $fixed->signal_connect( 'expose_event', \&on_widget_expose, $view_id ); $fixed->signal_connect( "enter_notify_event", \&on_widget_enter_notify, $view_id); $fixed->signal_connect( "leave_notify_event", \&on_widget_leave_notify, $view_id); $fixed->signal_connect( "motion_notify_event", \&on_widget_motion_notify, $view_id); $fixed->signal_connect( "button_press_event", \&on_widget_button_press, $view_id); $fixed->signal_connect( "button_release_event", \&on_widget_button_release, $view_id); # Left my $pos = 20; for ( 'left', 'right' ) { $drawing_area = Gtk2::DrawingArea->new; $drawing_area->set_events( ['exposure_mask', 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'key_press_mask', 'key_release_mask', 'enter_notify_mask', 'leave_notify_mask', 'focus_change_mask'] ); $drawing_area->set_size_request(60, 60); $fixed->put($drawing_area, $pos, 20); $pos += 100; $drawing_area->show; $view_id = "$id-$_"; $drawing_area->signal_connect( "enter_notify_event", \&on_widget_enter_notify, $view_id); $drawing_area->signal_connect( "leave_notify_event", \&on_widget_leave_notify, $view_id); $drawing_area->signal_connect( "motion_notify_event", \&on_widget_motion_notify, $view_id); $drawing_area->signal_connect( "button_press_event", \&on_widget_button_press, $view_id); $drawing_area->signal_connect( "button_release_event", \&on_widget_button_release, $view_id); } } sub _create_canvas { my ($table, $row, $text, $id) = @_; my ($label, $canvas, $root, $rect); $label = Gtk2::Label->new($text); $table->attach($label, 0, 1, $row, $row+1, [], [], 0, 0); $label->show; $canvas = Goo::Canvas->new; $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); $canvas->signal_connect('item-created', \&on_item_created); $canvas->set_size_request(200, 100); $canvas->set_bounds(0, 0, 200, 100); $table->attach($canvas, 1, 2, $row, $row+1, [], [], 0, 0); $canvas->show; $rect = Goo::Canvas::RectModel->new( $root, 0, 0, 200, 100, 'stroke-pattern' => undef, 'fill-color' => 'yellow', ); $rect->{id} = "$id-yellow"; $rect = Goo::Canvas::RectModel->new( $root, 20, 20, 60, 60, 'stroke-pattern' => undef, 'fill-color' => 'blue', ); $rect->{id} = $id.'-blue'; $rect = Goo::Canvas::RectModel->new( $root, 120, 20, 60, 60, 'stroke-pattern' => undef, 'fill-color' => 'red', ); $rect->{id} = $id.'-red'; } sub on_item_created { my ($canvas, $item, $model) = @_; if ( $model->isa("Goo::Canvas::RectModel")) { $item->signal_connect( "enter_notify_event", \&on_enter_notify); $item->signal_connect( "leave_notify_event", \&on_leave_notify); $item->signal_connect( "motion_notify_event", \&on_motion_notify); $item->signal_connect( "button_press_event", \&on_button_press); $item->signal_connect( "button_release_event", \&on_button_release); } } # FIXME: the box is not showed sub on_widget_expose { my ($widget, $ev, $id) = @_; print "$id received 'expose' signal\n"; $widget->style->paint_box( $widget->window, 'normal','in',$ev->area, $widget, undef, 0, 0, $widget->allocation->width, $widget->allocation->height ); return FALSE; } sub on_widget_enter_notify { my ($widget, $ev, $id) = @_; print "$id received 'enter-notify' signal\n"; return TRUE; } sub on_widget_leave_notify { my ($widget, $ev, $id) = @_; print "$id received 'leave-notify' signal\n"; return TRUE; } sub on_widget_motion_notify { my ($widget, $ev, $id) = @_; print "$id received 'motion-notify' signal(window: ", sprintf("0x%x", $ev->window->get_pointer), ")\n"; if ( $ev->is_hint ) { $ev->window->get_pointer(); } return TRUE; } sub on_widget_button_press { my ($widget, $ev, $id) = @_; print "$id received 'button-press' signal\n"; if ( $id =~ /explicit/ ) { my $mask = [ 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'enter_notify_mask', 'leave_notify_mask', ]; my $staus = $widget->window->pointer_grab(FALSE, $mask, FALSE, undef, $ev->time); if ( $staus eq 'success' ) { print "grabbed pointer\n"; } else { print "pointer grab failed\n"; } } return TRUE; } sub on_widget_button_release { my ($widget, $ev, $id) = @_; print "$id received 'button-release' signal\n"; if ( $id =~ /explicit/ ) { my $display = $widget->get_display; $display->pointer_ungrab($ev->time); print "released pointer grab\n"; } return TRUE; } sub on_enter_notify { my ($item, $target, $ev) = @_; my $model = $target->get_model; print "$model->{id} received 'enter-notify' signal\n"; return FALSE; } sub on_leave_notify { my ($item, $target, $ev) = @_; my $model = $target->get_model; print "$model->{id} received 'leave-notify' signal\n"; return FALSE; } sub on_motion_notify { my ($item, $target, $ev) = @_; my $model = $target->get_model; print "$model->{id} received 'motion-notify' signal\n"; return FALSE; } sub on_button_press { my ($item, $target, $ev) = @_; my $model = $item->get_model; print "$model->{id} received 'button-press' signal\n"; if ( $model->{id} =~ /explicit/ ) { my $mask = [ 'button_press_mask', 'button_release_mask', 'pointer_motion_mask', 'pointer_motion_hint_mask', 'enter_notify_mask', 'leave_notify_mask', ]; my $canvas = $item->get_canvas; my $staus = $canvas->pointer_grab( $item, $mask, undef, $ev->time); if ( $staus eq 'success' ) { print "grabbed pointer\n"; } else { print "pointer grab failed\n"; } } return FALSE; } sub on_button_release { my ($item, $target, $ev) = @_; my $model = $item->get_model; print "$model->{id} received 'button-released' signal\n"; if ( $model->{id} =~ /explicit/ ) { my $canvas = $item->get_canvas; $canvas->pointer_ungrab($item, $ev->time); print "released pointer grab\n"; } return FALSE; } #}}} #{{{ Events package Events; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my $vbox = Gtk2::VBox->new; my ($alignment, $frame, $label, $canvas); $vbox->show; $vbox->set_border_width(4); # Instructions $label = Gtk2::Label->new(<show; $vbox->pack_start($label, FALSE, FALSE, 0); # Frame and canvas $alignment = Gtk2::Alignment->new(0.5, 0.5, 0, 0); $vbox->pack_start($alignment, FALSE, FALSE, 0); $alignment->show; $frame = Gtk2::Frame->new(); $frame->set_shadow_type('in'); $alignment->add($frame); $frame->show; $canvas = Goo::Canvas->new; my $root = Goo::Canvas::GroupModel->new; $canvas->signal_connect('item-created', \&on_item_created); $canvas->set_root_item_model($root); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 600, 450); $frame->add($canvas); $canvas->show; create_events_area($canvas, 0, 'none', 'none'); create_events_area($canvas, 1, 'visible-painted', 'visible-painted'); create_events_area($canvas, 2, 'visible-fill', 'visible-fill'); create_events_area($canvas, 3, 'visible-stroke', 'visible-stroke'); create_events_area($canvas, 4, 'visible', 'visible'); create_events_area($canvas, 5, 'painted', 'painted'); create_events_area($canvas, 6, 'fill', 'fill'); create_events_area($canvas, 7, 'stroke', 'stroke'); create_events_area($canvas, 8, 'all', 'all'); return $vbox; } sub create_events_area { my ($canvas, $area_num, $pointer_events, $label) = @_; my $row = int($area_num/3); my $col = $area_num%3; my $x = $col * 200; my $y = $row * 150; my $root = $canvas->get_root_item_model; my $dash = Goo::Canvas::LineDash->new([5, 5]); my $rect; # Create invisible item $rect = Goo::Canvas::RectModel->new( $root, $x+45, $y+35, 30, 30, 'fill-color' => 'red', 'visibility' => 'invisible', 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' invisible'; # Display a thin rect around it to indicate it is there $rect = Goo::Canvas::RectModel->new( $root, $x+42.5, $y+32.5, 36, 36, 'line-dash' => $dash, 'line-width' => 1, 'stroke-color' => 'gray', ); # Create unpainted item. $rect = Goo::Canvas::RectModel->new( $root, $x+85, $y+35, 30, 30, 'stroke-pattern' => undef, 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' unpainted'; # Display a thin rect around it to indicate it is there $rect = Goo::Canvas::RectModel->new( $root, $x+82.5, $y+32.5, 36, 36, 'line-dash' => $dash, 'line-width' => 1, 'stroke-color' => 'gray', ); # Create stroked item $rect = Goo::Canvas::RectModel->new( $root, $x+125, $y+35, 30, 30, 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' stroked'; # Create filled item $rect = Goo::Canvas::RectModel->new( $root, $x+60, $y+75, 30, 30, 'fill-color' => 'red', 'stroke-pattern' => undef, 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' filled'; # Create filled & filled item $rect = Goo::Canvas::RectModel->new( $root, $x+100, $y+75, 30, 30, 'fill-color' => 'red', 'line-width' => 5, 'pointer_events' => $pointer_events ); $rect->{id} = $label . ' filled & filled'; Goo::Canvas::TextModel->new( $root, $label, $x+100, $y+130, -1, 'center', 'font' => 'Sans 12', 'fill-color' => 'blue', ); } sub on_item_created { my ($canvas, $item, $model) = @_; $item->signal_connect( 'motion_notify_event' => \&on_motion_notify ); } sub on_motion_notify { my ($item, $target, $ev) = @_; return unless $target; my $model = $target->get_model; return unless $model && $model->{id}; print "$model->{id} received 'motion-notify' signal\n"; } #}}} #{{{ Paths package Paths; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $swin->add($canvas); my $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; my $root = $canvas->get_root_item_model; my $path; $path = Goo::Canvas::PathModel->new( $root, "M 20 20 L 40 40", ); $path = Goo::Canvas::PathModel->new( $root, "M30 20 l20, 20", ); $path = Goo::Canvas::PathModel->new( $root, "M 60 20 H 80", ); $path = Goo::Canvas::PathModel->new( $root, "M60 40 h20", ); $path = Goo::Canvas::PathModel->new( $root, "M 100,20 V 40", ); $path = Goo::Canvas::PathModel->new( $root, "M 120 20 v 20", ); $path = Goo::Canvas::PathModel->new( $root, "M 140 20 h20 v20 h-20 z", ); $path = Goo::Canvas::PathModel->new( $root, "M 180 20 h20 v20 h-20 z m 5,5 h10 v10 h-10 z", "fill-color", "red", "fill-rule", 'even_odd', ); $path = Goo::Canvas::PathModel->new( $root, "M 220 20 L 260 20 L 240 40 z", "fill-color", "red", "stroke-color", "blue", "line-width", 3.0, ); # Test the bezier curve commands: CcSsQqTt. $path = Goo::Canvas::PathModel->new( $root, "M20,100 C20,50 100,50 100,100 S180,150 180,100", ); $path = Goo::Canvas::PathModel->new( $root, "M220,100 c0,-50 80,-50 80,0 s80,50 80,0", ); $path = Goo::Canvas::PathModel->new( $root, "M20,200 Q60,130 100,200 T180,200", ); $path = Goo::Canvas::PathModel->new( $root, "M220,200 q40,-70 80,0 t80,0", ); # Test the elliptical arc commands: Aa. $path = Goo::Canvas::PathModel->new( $root, "M200,500 h-150 a150,150 0 1,0 150,-150 z", "fill-color", "red", "stroke-color", "blue", "line-width", 5.0, ); $path = Goo::Canvas::PathModel->new( $root, "M175,475 v-150 a150,150 0 0,0 -150,150 z", "fill-color", "yellow", "stroke-color", "blue", "line-width", 5.0, ); $path = Goo::Canvas::PathModel->new( $root, "M400,600 l 50,-25 " . "a25,25 -30 0,1 50,-25 l 50,-25 " . "a25,50 -30 0,1 50,-25 l 50,-25 " . "a25,75 -30 0,1 50,-25 l 50,-25 " . "a25,100 -30 0,1 50,-25 l 50,-25", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::PathModel->new( $root, "M 525,75 a100,50 0 0,0 100,50", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::PathModel->new( $root, "M 725,75 a100,50 0 0,1 100,50", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::PathModel->new( $root, "M 525,200 a100,50 0 1,0 100,50", "stroke-color", "red", "line-width", 5.0, ); $path = Goo::Canvas::PathModel->new( $root, "M 725,200 a100,50 0 1,1 100,50", "stroke-color", "red", "line-width", 5.0, ); } #}}} #{{{ Focus package Focus; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($label, $swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $label = Gtk2::Label->new("Use Tab, Shift+Tab or the arrow keys to move the keyboard focus between the canvas items."); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->can_focus(TRUE); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $swin->add($canvas); my $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); $canvas->signal_connect('item-created', \&on_item_created); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; create_focus_box ($canvas, 110, 80, 50, 30, "red"); create_focus_box ($canvas, 300, 160, 50, 30, "orange"); create_focus_box ($canvas, 500, 50, 50, 30, "yellow"); create_focus_box ($canvas, 70, 400, 50, 30, "blue"); create_focus_box ($canvas, 130, 200, 50, 30, "magenta"); create_focus_box ($canvas, 200, 160, 50, 30, "green"); create_focus_box ($canvas, 450, 450, 50, 30, "cyan"); create_focus_box ($canvas, 300, 350, 50, 30, "grey"); create_focus_box ($canvas, 900, 900, 50, 30, "gold"); create_focus_box ($canvas, 800, 150, 50, 30, "thistle"); create_focus_box ($canvas, 600, 800, 50, 30, "azure"); create_focus_box ($canvas, 700, 250, 50, 30, "moccasin"); create_focus_box ($canvas, 500, 100, 50, 30, "cornsilk"); create_focus_box ($canvas, 200, 750, 50, 30, "plum"); create_focus_box ($canvas, 400, 800, 50, 30, "orchid"); } sub create_focus_box { my ($canvas, $x, $y, $width, $height, $color) = @_; my $root = $canvas->get_root_item_model; my $item = Goo::Canvas::RectModel->new( $root, $x, $y, $width, $height, 'stroke-pattern' => undef, 'fill-color' => $color, 'line-width' => 5, 'can-focus' => TRUE, ); $item->{id} = $color; } sub on_item_created { my ($canvas, $item, $model) = @_; if ( $model->isa('Goo::Canvas::RectModel')) { $item->signal_connect('focus_in_event' => \&on_focus_in); $item->signal_connect('focus_out_event' => \&on_focus_out); $item->signal_connect('button_press_event' => \&on_button_press); $item->signal_connect('key_press_event' => \&on_key_press); } } sub on_key_press { my($item, $target, $ev) = @_; my $model = $item->get_model; print $model->{id} || "Unknown", " received key_press event\n"; return FALSE; } sub on_button_press { my($item, $target, $ev) = @_; my $model = $item->get_model; print $model->{id} || "Unknown", " received button_press event\n"; my $canvas = $item->get_canvas; $canvas->grab_focus($item); return TRUE; } sub on_focus_out { my ($item, $target, $ev) = @_; my $model = $item->get_model; print $model->{id} || "Unknown", " received focus_out event\n"; $model->set("stroke-pattern" => undef); return FALSE; } sub on_focus_in { my ($item, $target, $ev) = @_; my $model = $item->get_model; print $model->{id} || "Unknown", " received focus_in event\n"; $model->set("stroke-color" => "black"); return FALSE; } #}}} #{{{ Animation package Animation; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($hbox, $w, $swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $hbox = Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); $hbox->show; $w = Gtk2::ToggleButton->new('Start Animation'); $hbox->pack_start($w, FALSE, FALSE, 0); $w->show; $w->signal_connect('toggled', \&toggle_animation_clicked); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $w->{canvas} = $canvas; $swin->add($canvas); my $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; my $root = $canvas->get_root_item_model; my ($rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2); # Absolute $ellipse1 = Goo::Canvas::EllipseModel->new( $root, 0, 0, 25, 15, 'fill-color' => 'blue', ); $ellipse1->translate(100, 100); $rect1 = Goo::Canvas::RectModel->new( $root, -10, -10, 20, 20, 'fill-color' => 'blue', ); $rect1->translate(100, 200); $rect3 = Goo::Canvas::RectModel->new( $root, -10, -10, 20, 20, 'fill-color' => 'blue', ); $rect3->translate(200, 200); # Relative $ellipse2 = Goo::Canvas::EllipseModel->new( $root, 0, 0, 25, 15, 'fill-color' => 'red', ); $ellipse2->translate(100, 400); $rect2 = Goo::Canvas::RectModel->new( $root, -10, -10, 20, 20, 'fill-color' => 'red', ); $rect2->translate(100, 500); $rect4 = Goo::Canvas::RectModel->new( $root, -10, -10, 20, 20, 'fill-color' => 'red', ); $rect4->translate(200, 500); $canvas->{items} = [$rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2]; } sub toggle_animation_clicked { my $but = shift; if ( $but->get_active ) { $but->set_label('Stop Animation'); start_animation($but); } else { $but->set_label('Start Animation'); stop_animation($but); } } sub start_animation { my $but = shift; my ($rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2) = @{$but->{canvas}{items}}; # Absolute $ellipse1->set_simple_transform (100, 100, 1, 0); $ellipse1->animate (500, 100, 2, 720, TRUE, 2000, 40, 'bounce'); $rect1->set_simple_transform (100, 200, 1, 0); $rect1->animate (100, 200, 1, 350, TRUE, 40 * 36, 40, 'restart'); $rect3->set_simple_transform (200, 200, 1, 0); $rect3->animate (200, 200, 3, 0, TRUE, 400, 40, 'bounce'); # Relative $ellipse2->set_simple_transform (100, 400, 1, 0); $ellipse2->animate (400, 0, 2, 720, FALSE, 2000, 40, 'bounce'); $rect2->set_simple_transform (100, 500, 1, 0); $rect2->animate (0, 0, 1, 350, FALSE, 40 * 36, 40, 'restart'); $rect4->set_simple_transform (200, 500, 1, 0); $rect4->animate (0, 0, 3, 0, FALSE, 400, 40, 'bounce'); } sub stop_animation { my $but = shift; my ($rect1, $rect2, $rect3, $rect4, $ellipse1, $ellipse2) = @{$but->{canvas}{items}}; $ellipse1->stop_animation (); $ellipse2->stop_animation (); $rect1->stop_animation (); $rect2->stop_animation (); $rect3->stop_animation (); $rect4->stop_animation (); } #}}} #{{{ Clipping package Clipping; use Gtk2; use Glib qw(TRUE FALSE); sub create_canvas { my $pkg = shift; my ($hbox, $swin, $canvas); my $vbox = Gtk2::VBox->new; $vbox->show; $vbox->set_border_width(4); $swin = Gtk2::ScrolledWindow->new(); $swin->set_shadow_type('in'); $swin->show; $vbox->add($swin); $canvas = Goo::Canvas->new; $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->show; $swin->add($canvas); setup_canvas($canvas); return $vbox; } sub setup_canvas { my $canvas = shift; my $root = Goo::Canvas::GroupModel->new; $canvas->set_root_item_model($root); my $model; $model = Goo::Canvas::EllipseModel->new( $root, 0, 0, 50, 30, 'fill-color' => 'blue', ); $model->translate(100, 100); $model->rotate(30, 0, 0); $canvas->get_item($model)->signal_connect( 'button-press-event' => \&on_button_press, "Blue ellipse (unclipped)" ); $model = Goo::Canvas::RectModel->new( $root, 200, 50, 100, 100, 'fill-color' => 'red', 'clip-fill-rule' => 'even-odd' ); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, "Red rectangle (unclipped)"); $model = Goo::Canvas::RectModel->new( $root, 380, 50, 100, 100, 'fill-color' => 'yellow' ); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, "Yellow rectangle(unclipped)"); # clipped items $model = Goo::Canvas::EllipseModel->new( $root, 0, 0, 50, 30, 'fill-color' => 'blue', 'clip-path' => "M 0 0 h 100 v 100 h -100 Z" ); $model->translate (100, 300); $model->rotate (30, 0, 0); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, "Blue ellipse"); $model = Goo::Canvas::RectModel->new( $root, 200, 250, 100, 100, 'fill-color' => 'red', 'clip-path' => "M 250 300 h 100 v 100 h -100 Z", 'clip-fill-rule' => 'even-odd' ); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, "Red rectangle"); $model = Goo::Canvas::RectModel->new( $root, 380, 250, 100, 100, 'fill-color' => 'yellow', 'clip-path' => "M480,230 l40,100 l-80 0 z", ); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, 'Yellow rectangle'); # Table with clipped items my $table = Goo::Canvas::TableModel->new($root); $table->translate (200, 400); $table->rotate (30, 0, 0); $model = Goo::Canvas::EllipseModel->new( $table, 0, 0, 50, 30, 'fill-color' => 'blue', 'clip-path' => "M 0 0 h 100 v 100 h -100 Z", ); $model->translate (100, 300); $model->rotate (30, 0, 0); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, 'Blue ellipse'); $model = Goo::Canvas::RectModel->new( $table, 200, 250, 100, 100, 'fill-color' => 'red', "clip-path" => "M 250 300 h 100 v 100 h -100 Z", "clip-fill-rule" => 'even-odd', ); $table->set_child_properties( $model, 'column' => 1, ); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, 'Red rectangle'); $model = Goo::Canvas::RectModel->new( $table, 380, 250, 100, 100, 'fill-color' => 'yellow', 'clip-path' => "M480,230 l40,100 l-80 0 z" ); $table->set_child_properties( $model, 'column' => 2, ); $canvas->get_item($model)->signal_connect('button-press-event' => \&on_button_press, 'Yellow rectangle'); } sub on_button_press { my ($item, $target, $ev, $id) = @_; printf "%s received 'button-press' at %g, %g, (root: %g, %g)\n", $id, $ev->x, $ev->y, $ev->x_root, $ev->y_root; return TRUE; } #}}} Goo-Canvas-0.06/demo/toroid.png0000644000175000017500000004102510417155140014512 0ustar ywbywbPNG  IHDRNgAMA1_ IDATx{UY{}}}{gz^f2 @eBʱŽ$`W*6qQeR$e 4h4g=^cv+Pe r~un߾}9Zw}=uyʼn -P\}&?ϊjrY=\oά5zf;,Ap&ao/ˮ/{/z)L,)DIW^f&n!oX/}sJi$u̅GD?(߷xO8gBu/+3w=$6 wZ5UWR*%60HNC麞Mٴ ]A䢿i/OoZnygng)$zpqAo:z^N3J+SR$BX !̡Zڋk]eR7RM10MM ե+!h wHKMsW}M<`_+,KW -rO*V"VUPIRgU%k@ޅ;5uH2E ՛ozрu"a牔TwZ/xYH!5*7:=)DTLĪj EU+f#a6R&G0"4amqk+UᯕHBBOLk՝fjγǗDR"$J@ѓanGnh  u(2]+E)|&,N1 !Pvt؅$5 AAT(o|Eצ?y\!ܺ+eui`9'X y<. vC/b$"v ԹɁģ^Q*Bw{x|<')TY~AAZ.~[7|%T ayw.VfU8WBY|:-eqs#9f3 +&Ī .֋"&DŦPY(TokPP5@7:|>4]C5@9& ן(YB7yۛ;"Aġ *w#v*Z "\Jh ,/ut ,VX Բr u3+;/|eH+;݋o|' ' Zm[!U0 $hO VR$ t>j> :h`]1:CvA 6xzVQ@%g`9լ0FP$lҙa:<R<Xy77XQTIĤ 4 U*f0+N2`p/Ji[x%@`#Ձ}TZjx+նrZ< Ts_wq-h$(!]H͡(,IA1+d+YLIgMbJULwnpsZK9 2ɥ?(SX/NpKjH%#) 5LUZ)pY%(L0 隠VhP t* ׷#`=j8~_(+Z6,ͯ% z}ٟ/vJ/:yI;ˡ,NG G ha2qTf l<ѡ|DC ``4!6 Zˆ×5V%y³+X\ O( O/ ;Jqd: wT3>0)V܀/#8YZFGCkBUM~T@K` B+(˹v6Аw<uh'lb"6Ӏޘ1fHH J@h,UY .K@a.PxՁ4N54=ߢraȒldF&,v&pt$ %p-]ع fhmY mh(rm̕pf ^׵CfUt6 l̃ !1oZn2mfґmE_dfռߓU do@#(y4?Aݙ5&t-: *j zUʣSxTHlOiagSt 'iN4$uɊ0hu}9m_h҅a9),R{r5/%z0衋؇^ )g⳱M@P1=,BoZ/Q3h#LFˡ: 5l4z;4SC :`J&B]VJQ6*D$g{IrOM^/~?O~Gp -^r>ۅ!HxI(.pG+4TJ1:y%̽2WR̩ie;Y[8ppP076ք0&Q8H @57b`qS(J5.h kCU)Z°4vJG%á#LpF' VWdOL)@B'1PE^OWQb@mݖT3 6V[i=<a*pPht^M $9GȤB >DW:(+Nն (JI 'X,eМ#XT=\V!+kzURݳ(:Il(g0Sht$2 jaF< Ea>rtf TXY=#̯ҋppg}Q!mvL;H-X2z# z݀WQ**%Z4b\[2B7?o̕d0skLjC3` i"tv=BD;Nn(Q@-fc - 8TQW!Yyv+Y%sT! yO 3EgT5KFP+nW)GubPLP(QD%/ ^VazFCȓ wvsNNcF+YxP\ƻ,,,LdOShY +,pIf)"!=/dS!Qـ!a{I4#T#*n\A۞BR9%EOO}W=pb9DDdJ9 &m($R N9ׁ EDl NyNP Db+̃9R.ȏ.w?=2xjsGz3>cĤYVf3'υ,\ID\tqUi!kO Y*dMVWHݙH \T¬H'ixћ 3'"KmJ. ͅTl*U##$1)o ! e7Ul!%b &5D"D=dyՈDʙlSk^ȓ 2[NGZSY;yBk=br%)Rdgdx/HoxHD I $/3Gte ҘvS$?;I:#'ۜ;`1neiJAq(P:Bw|: 6{ 4 -%1=Crb^XPB ]SAsE-hRiLI\lGف2U1Dwj)U͞ ^4^):(2HnN|ykG^'Ϻյ[4[*2XGHޏ l Ƽ`6=IS$B#NzEMt^!&)`HC@6 % j& ,PZs  h 5 o(a:ujCh "Qv'-a:X,=+^(l<,n3)b t/A9f mUT|D @Ԑx8AN&̧~żWOk+.f2H[#iMىXA&4XB3vY$OH1F`TFsn Pa)nkkt\S"3w PpI4qQ'/ITZy3h$Vo+ei_%,jnygo%Xflh =`DՏz+B)h%SLHPlTK1B"J_5,~*?OoXŏ{ !i!GG*`ȻH_`#It\f` p pu'0/A OVٖ i ;dߠ-' Z/I4Ka&EOn"ij̇_Կwx=| 4QrQ0b0(Fvgn)E)HY]Hݏ !Af~ru/DN$?Y4)jL zhb͔%EH0XXL``3lb^ ۖ;ɵW>5kZ5hǶ[hy3~5 i,$ECKtZ2bsegu*H""?db>sם:V70E4!]s{%snKϔ/Y<1MXP LRܶYIOr7ok5JB-ySL9}2#mt$D`S?\,SI? qǻ :sXuUn7֐)Be9^i2?~M/"F'œٖ.9!>@ڌu]Rp)xkkжʁZMsdRMY\;0dZ:$UKO1MN'CeOO{gYvIHd +Ǟ~+X¿Usr0؄^6=ypi~Ңh AC%?vP'LR`+FDD}Euy GQɠ,S8xcWzoKCF]IRd^Cq;f__,NÕd2=~s֬43-u*c"JfV ]rFLHRТŊhXRJ X&,k~p&%IzA!H Eb| 3LF]7a:*Xdm>Г[f1{fGK e8qc:_/T!0+*s~`$-*SyB+ QLۑI%t QHלSpҥ&6"E[Y HIȎH?f{RjjO~au*KӼH@:04aL+ Np?+CK xRp%S<CĒS3BYIlf{uYH/Zy=1į*}t2E,~#1OṗH9" [NG|di>xߒ>qZi%ϽB=ŀ))NK14DH`gO )9 2 IDATG$Ma{!~*X˸M QVv'x*x܈u= ٺp*zM0~e7jH0'_g'o o?VHhSaHBa:-F3rӀ7Ԅ6)d .AdȠ$B":Q;.R;iDRT})t]|_wW4aY$;~CrZz68pT)1#Qc6 :'(URBuD7`oF% ǶkpW0ޮf:3Dx5m!&,ubH f_ h_7IhiդS}?iuQMiԲwuZ_b%^ݫ'=OY͙!$tX&39HCqoQk<'ӫۡx!≿BX@6:9dvbTCֵ0u:`z栩MAf8zgՍ{?,|Wh?=Oo[/lJy 3d>9YM"DRK nKZsM1O3RM1n(@Ds,M0-Aɜ@VDcp,) jROO4譼5x<8Q"@6_E<~Vr "&P1*1Ȣ)`v75N{+,)Y$:0IAQ2y&yrm=]H[a4ɘտ~Z-wړx\d"Iϝ{z]ξ$ZI"#'#CI۬=ܦyR] l}nxDza uPV̤hlR偣MOI(T(qGe Blnl6q8@uWImcQ *w!jsD8$1xP~ACHn!P/Ff["RZ=üFƷn-̱ .~B`l2%h\.2 Dg*>ު\~9Goj˷Z`73xEF)IZ,sJnABXpċ.CpoI}z7W2!g KBV/w7 7Hi\S̚g4,u5(Gs3Z;3gt8戜ib9tr2gNEYFZ hУbJŜ?6ׯ1 rtX;",i۱-!*$[H_ou$=ĞC>zXl0waC^k#5&8(3$xzPc}Z W(pbpLI II8#,Y-nsT'@%(,hj4hhoM#eˁ܀g2e4LТKOc@:TZ,b^`LBN]w,n/|P_P@1&Tdŗnh ^g6>8paC]/0NsףPI]bUHIXa6g & <9KSrMonOf{x}쩅my^A8uO֍n*cs}ΈCQ$$XlҜe4i0e8_caiQlT8<g Lӣ2`OJ}fL9dΌy]bqmu,_{RwI]qQ.m0{Iba9yb )[6CqԗA4 zv;FzN9`i!4Xgc;7 vhm/Oq#|y =>mRɄ3aMN#ttFf 0a\dNFJ :i$''2J6-2K2`Qiu;PQfL2eY,2YÐ!; 9J7t-}覎??|P_6oo!8\![F^ MW:9%)T@GcYM &ZYtǤ"3Mf!Sxr#{Ď(-E>AITԣ]g;}"%3d۪uX x=_R*h hAL $UN\efUj#JI:Ew9''8m?JFA2w+X8l uzfiiV"zaSq K"JAɗI>ki> vDVTu-,l\b١i.dMwy[h+*,Uֽ VO5PH*]K&=:x@E@Dɒh!2%&aFFʌ A;r|{=5J>IU8!:g=Xd*zlnܿ"i41YsbHCnc$II¬2ؤ|_,:66]1,q-Wb} CߡNLcJFQxO)\e-9qU+CLy\;*X(|Xc N ζ79]4,dOS=a"]7"$%&%D!iѤK)3&L 1cLM7cFJ-<-e{2Տt.ӫBW}h.? j{-2y|.^پmsyO8[K8 E\9@ x SXl#q(2_@Θ'9k,qD MD ^_q#y=} pU P#aXmqBH |:,:k:Ol*00%&$6M1!ѱ3J2lE(ЄD䴰!RECd^\lOzF|]QA_]"e:4YIۓߧ).5ayј P᳾e7gWwgC7F!A5"d@Ș ~h?%2GL 0fB 6m,GH 7;cgr%_շQ?=jw(㉐oHgA :2\f6II6j 4rC~ Q-nB>H4>k4mCW\T4pnv5r|z'8=M0逊6.k2p+NȰUӥIN'{bCBD2%gfhp łM1ej0%$$ 'Em|,$) /˷_/^pVNfUTz_\}QUBDKZԥqp3OX)kF 6FіGE.ϐB1  䀔̸Gɐj%Es,\|FvYNbrHF+"~| h {a;cv ߵiO%̿mxX(4%!&0aB@HB.y]\~Cf1R(y+vD{~Jj{kw5ZR܇%@An@A_jy&8RfZ!"/NHK HPnsHP p6Ai2qi$ Q2)m"&-F^f{/f2EUVM|OeÔ=f-a3<f!g&X8+7WFAzw_DcUTSO>f;B~@6zQc( B ʠQƐŌ1obFvHb:45󶦄) #PhrQ4(SDj2` RƣGs,sC49-P،&d G=>ErXn1 -ڜg3|yVdb#jT8Xx8celá0&"6ˤA!3y/Gs)t3H@CP%V#Qb )5\Z8VP0Ty0E03} ל2-69"gLΐĤ&)Bn3x8 !DҤGP6]V鰌%{g$O?=&3Ҍ"]?itir[=}LYQҰcs~2ZoB PǐGdM! :5V 4|Uh]=屟HspJrpNe c+?gBC2h lYz,-,~^Ir@h8>.lkDL,[Wy]%L~KORtv&/R͡+n=gp|<HʗU/??c""jcfLaW mQs&0,}$1)׭.-ppro얕(x k%.=j8cw틽9jq! RUW!ϬKi^GHE%Bvo̢srj'Of|=#➸=zo}!bzgѻY??tY+P,N`M ׼G8 3rnjVv)c=|a&-Vq2:-ə(iaV̑nʰ W_j=$%V.*,c\C\9^Fz q4Iۜ[Ys]Yʅwt   ,R.qlׁupi1E`M2n9X# '!!`,w7x;ƛ#Od+fz73D%խlWwKGz)}pρwZ~up[ lKESXiX48ϷiVQe}|f¡G&q)6M\ZبZj^2YY&z@PDe._nHݮ=G]kQ'QNKOItOI햢!a9bXyse `ĦTq4ԦM,16]w"$wx뛯U5݌݇IDAT@6X36[K XgڷppP$$ (M{zn9h6a5?-*Rsw3q{i+ߣ4+'=k+YXty3v,s|S"#}fuX:` &mz1 xy]U"Ay?o?Uڌ5gՔ4?f9t6,Z]%$*D2WbNxEZlY3k[uezzen qSV4h)W4҈2ωbpV˔%ed.I~U KӒƪaԒt$;7uvڠflg|IrS#G6MwpHfJ{4还 JIENDB`Goo-Canvas-0.06/demo/flower.png0000644000175000017500000000146210417155140014511 0ustar ywbywbPNG  IHDRsO/gAMA1_IDATxmMhTwR3/̛d"KŀDDcJA nJi] +.DPA(]tU$ RFZDO8y8}L湈 =\=Gܻ4gky#oߊLg$/:%tM;u+t @(ڕ N~,o ~\nWj7%Ul ؋HM6 'o C,ӓ~(0zg7Z&P ChγaAJ3 J7CG;0cVGѴv-C!dُԒѵL&KDV@R$'T. i8Dܛ_>C叉1FGGT(*v ujS55+F3,.cjj5Q$S]UXnAmQ7m* Bg&8Fcw|3a4-9Noa6; p r@FɄ#nhs[@c ,Dڂ(|Ym ~)6x%%nIENDB`Goo-Canvas-0.06/demo/mv-simple.pl0000755000175000017500000000261510677127127014773 0ustar ywbywb#!/usr/bin/perl -w # mv-simple.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/26 13:31:45 # Author: Ye Wenbin use strict; use warnings; use FindBin qw/$Bin/; use lib "$Bin/../blib/arch"; use lib "$Bin/../blib/lib"; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use Goo::Canvas; my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); my $swin = Gtk2::ScrolledWindow->new; $swin->set_shadow_type('in'); $window->add($swin); my $canvas = Goo::Canvas->new(); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $swin->add($canvas); my $root = Goo::Canvas::GroupModel->new(); my $rect_model = Goo::Canvas::RectModel->new( $root, 100, 100, 400, 400, 'line-width' => 10, 'radius-x' => 20, 'radius-y' => 10, 'stroke-color' => 'yellow', 'fill-color' => 'red' ); my $text_model = Goo::Canvas::TextModel->new( $root, "Hello World", 300, 300, -1, 'center', 'font' => 'Sans 24', ); $text_model->rotate(45, 300, 300); $canvas->set_root_item_model($root); my $rect_item = $canvas->get_item($rect_model); $rect_item->signal_connect('button-press-event', \&on_rect_button_press); $window->show_all(); Gtk2->main; sub on_rect_button_press { print "Rect item pressed!\n"; return TRUE; } Goo-Canvas-0.06/demo/simple.pl0000755000175000017500000000241510677131666014354 0ustar ywbywb#!/usr/bin/perl -w # simple.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/26 13:31:45 # Author: Ye Wenbin use strict; use warnings; use FindBin qw/$Bin/; use lib "$Bin/../blib/arch"; use lib "$Bin/../blib/lib"; use Goo::Canvas; use Gtk2 '-init'; use Glib qw(TRUE FALSE); my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); my $swin = Gtk2::ScrolledWindow->new; $swin->set_shadow_type('in'); $window->add($swin); my $canvas = Goo::Canvas->new(); $canvas->set_size_request(600, 450); $canvas->set_bounds(0, 0, 1000, 1000); $swin->add($canvas); my $root = $canvas->get_root_item(); my $rect = Goo::Canvas::Rect->new( $root, 100, 100, 400, 400, 'line-width' => 10, 'radius-x' => 20, 'radius-y' => 10, 'stroke-color' => 'yellow', 'fill-color' => 'red' ); $rect->signal_connect('button-press-event', \&on_rect_button_press); my $text = Goo::Canvas::Text->new( $root, "Hello World", 300, 300, -1, 'center', 'font' => 'Sans 24', ); $text->rotate(45, 300, 300); $window->show_all(); Gtk2->main; sub on_rect_button_press { print "Rect item pressed!\n"; return TRUE; } Goo-Canvas-0.06/demo/unit-demo.pl0000755000175000017500000000567110677127125014766 0ustar ywbywb#!/usr/bin/perl -w # unit-demo.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/26 13:31:45 # Author: Ye Wenbin use strict; use warnings; use FindBin qw/$Bin/; use lib "$Bin/../blib/arch"; use lib "$Bin/../blib/lib"; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use Goo::Canvas; my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); my $notebook = Gtk2::Notebook->new; $window->add($notebook); foreach my $unit ( ['pixel', 'pixels'], ['points', 'points'], ['inch', 'inches'], ['mm', 'millimeters'] ) { $notebook->append_page( create_canvas(@$unit), Gtk2::Label->new(ucfirst($unit->[1])), ); } $window->show_all(); Gtk2->main; sub create_canvas { my ($unit, $name) = @_; my ($vbox, $hbox, $w, $swin, $canvas, $adj); $vbox = Gtk2::VBox->new(FALSE, 4); $vbox->set_border_width(4); $hbox= Gtk2::HBox->new(FALSE, 4); $vbox->pack_start($hbox, FALSE, FALSE, 0); $canvas = Goo::Canvas->new; $w = Gtk2::Label->new("Zoom:"); $hbox->pack_start($w, FALSE, FALSE, 0); $adj = Gtk2::Adjustment->new(1, 0.05, 100, 0.05, 0.5, 0.5); $w = Gtk2::SpinButton->new($adj, 0, 2); $adj->signal_connect('value-changed', \&zoom_changed, $canvas); $w->set_size_request(50, -1); $hbox->pack_start($w, FALSE, FALSE, 0); $swin = Gtk2::ScrolledWindow->new; $vbox->pack_start($swin, TRUE, TRUE, 0); $canvas->set_size_request(600, 450); setup_canvas($canvas, $unit, $name); $canvas->set_bounds(0, 0, 1000, 1000); $canvas->set( "units" => $unit, "anchor" => 'center' ); $swin->add($canvas); return $vbox; } sub zoom_changed { my ($adj, $canvas) = @_; $canvas->set_scale($adj->get_value); } sub setup_canvas { my ($canvas, $unit, $name) = @_; my ($root, $item) ; my %data = ( 'pixel' => [100, 100, 200, 20, 10, 200, 310, 24], 'points' => [100, 100, 200, 20, 10, 200, 310, 24], 'inch' => [1, 1, 3, 0.5, 0.16, 3, 4, 0.3 ], 'mm' => [30, 30, 100, 10, 5, 80, 60, 10 ] ); my @d = @{$data{$unit}}; $root = $canvas->get_root_item; $item = Goo::Canvas::Rect->new($root, @d[0..3]); $item->signal_connect( "motion_notify_event", \&on_motion_notify); $item->{id} = "$unit - $name"; $item = Goo::Canvas::Text->new( $root, "This box is $d[2]x$d[3] $name", $d[0]+$d[2]/2, $d[1]+$d[3]/2, -1, 'center', 'font' => "Sans $d[4]" ); $item = Goo::Canvas::Text->new( $root, "This font is $d[7] $name high", $d[5], $d[6], -1, 'center', "font" => "Sans $d[7]" ); } sub on_motion_notify { my $item = shift; print (($item->{id} || "Unknown"), " item received 'motion-notify' signal\n"); return FALSE; } Goo-Canvas-0.06/demo/scalablity.pl0000755000175000017500000001277610677323471015222 0ustar ywbywb#!/usr/bin/perl -w # scalablity.pl --- # Last modify Time-stamp: # Version: v 0.0 2007/09/26 15:32:25 # Author: Ye Wenbin use strict; use warnings; use FindBin qw/$Bin/; use lib "$Bin/../blib/arch"; use lib "$Bin/../blib/lib"; use Goo::Canvas; use Gtk2 '-init'; use Glib qw(TRUE FALSE); use Time::HiRes qw/gettimeofday tv_interval/; use constant { N_GROUP_COLS => 5, N_GROUP_ROWS => 5, # N_GROUP_COLS => 25, # N_GROUP_ROWS => 20, N_COLS => 10, N_ROWS => 10, PADDING => 10, }; use Data::Dumper qw(Dumper); my $use_pixmap = shift; my $max = 1<<29; my ($left_offset, $top_offset, $total_width, $total_height); my @ids; my $window = Gtk2::Window->new('toplevel'); $window->signal_connect('delete_event' => sub { Gtk2->main_quit; }); $window->set_default_size(640, 600); my $swin = Gtk2::ScrolledWindow->new; $window->add($swin); my $canvas = create_canvas(); $swin->add($canvas); $window->show_all(); Gtk2->main(); sub create_canvas { my $canvas = Goo::Canvas->new(); $canvas->set_size_request(600, 450); my $start = [gettimeofday]; setup_canvas ($canvas); print "Create Canvas Time Used: ", tv_interval($start), "\n"; $canvas->set_bounds($left_offset, $top_offset, $left_offset + $total_width, $top_offset + $total_height); return $canvas; } sub setup_canvas { my $canvas = shift; my ($root, $group, $item); my ($pattern, $pixbuf); my ($item_width, $item_height, $group_width, $group_height, $cell_width, $cell_height); my @styles; my ($total_items, $id_item_num) = (0, 0); $root = $canvas->get_root_item(); if ( $use_pixmap ) { # my $surface = Cairo::ImageSurface->create_from_png("$Bin/toroid.png"); # $item_width = $surface->get_width; # $item_height = $surface->get_height; # $pattern = Goo::Cairo::Pattern->new( # Cairo::SurfacePattern->create($surface) # ); $pixbuf = Gtk2::Gdk::Pixbuf->new_from_file("$Bin/toroid.png"); $item_width = $pixbuf->get_width; $item_height = $pixbuf->get_height; $pattern = Goo::Cairo::Pattern->new_from_pixbuf($pixbuf); } else { $item_width = 400; $item_height = 19; } $cell_width = $item_width + PADDING * 2; $cell_height = $item_height + PADDING * 2; $group_width = N_COLS * $cell_width; $group_height = N_ROWS * $cell_height; $total_width = N_GROUP_COLS * $group_width; $total_height = N_GROUP_ROWS * $group_height; $left_offset = - $total_width / 2; $top_offset = - $total_height / 2; for ( 'mediumseagreen', 'steelblue' ) { my $style = Goo::Canvas::Style->new; my $color = Gtk2::Gdk::Color->parse($_); my $pattern = Goo::Cairo::Pattern->new( Cairo::SolidPattern->create_rgb( map { $_/65535 } $color->red, $color->green, $color->blue )); $style->set_property('fill-pattern', $pattern); push @styles, $style; } OUTER: foreach my $i ( 0..N_GROUP_COLS ) { foreach my $j ( 0..N_GROUP_ROWS ) { my $x = $left_offset + ($i * $group_width); my $y = $top_offset + ($j * $group_height); $group = Goo::Canvas::Group->new( $root ); $total_items++; $group->translate($x, $y); for my $i ( 0..N_COLS ) { for my $j ( 0..N_ROWS ) { my $ix = $i * $cell_width + PADDING; my $iy = $j * $cell_height + PADDING; my $rotation = $i % 10 * 2; my $rx = $ix + $item_width / 2; my $ry = $iy + $item_height / 2; $ids[$id_item_num] = ($x+$ix) . " - " . ($y+$iy); if ( $use_pixmap ) { # use Data::Dumper qw(Dumper); # print Dumper($pattern, $item_width), "\n"; $item = Goo::Canvas::Image->new( $group, undef, $ix, $iy, 'pattern' => $pattern, 'width' => $item_width, 'height' => $item_height ); $item->rotate($rotation, $rx, $ry); } else { $item = Goo::Canvas::Rect->new($group, $ix, $iy, $item_width, $item_height); $item->set_style($styles[($j+1)%2]); $item->rotate($rotation, $rx, $ry); } $item->{"id"} = $ids[$id_item_num]; $item->signal_connect('motion-notify-event', \&on_motion_notify); $item = Goo::Canvas::Text->new( $group, $ids[$id_item_num], $ix+$item_width/2, $iy+$item_height/2, -1, 'center', "font" => 'Sans 8' ); $item->rotate($rotation, $rx, $ry); $id_item_num++; $total_items+=2; if ( $max < $total_items ) { last OUTER; } } } } } print("total items: ", $total_items, "\n"); } sub on_motion_notify { my $item = shift; print( ($item->{id} || "Unknown"), " item received 'motion-notify' signal\n"); return FALSE; } Goo-Canvas-0.06/t/0000755000175000017500000000000011200440442012012 5ustar ywbywbGoo-Canvas-0.06/t/Goo-Canvas.t0000644000175000017500000000115011200436563014142 0ustar ywbywb#!/usr/bin/perl -w -I../blib/lib -I../blib/arch # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl Goo-Canvas.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 2; BEGIN { use_ok('Goo::Canvas') }; use lib qw(../blib/lib ../blib/arch); ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. can_ok('Goo::Canvas', qw(get_items_at get_items_in_area)); Goo-Canvas-0.06/README0000644000175000017500000000143511200440175012435 0ustar ywbywbGoo-Canvas version 0.05 ======================= Perl bindings to the goocanvas-0.9+. For goocanvas-0.6, please use Goo-Canvas version 0.03. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: perl >= 5.8.0 Cairo >= 1.00 (perl module and requisite C libraries) Glib >= 1.103 (perl module and requisite C libraries) Gtk2 >= 1.100 (perl module and requisite C libraries) goocanvas-0.9+ COPYRIGHT AND LICENCE Copyright (C) 2007 by Ye Wenbin This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available.