/usr/lib/perl5/Xacobeo/GObject.pm is in xacobeo 0.13-2build1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | package Xacobeo::GObject;
=head1 NAME
Xacobeo::GObject - Build GObjects easily.
=head1 SYNOPSIS
package My::Widget;
use Xacobeo::GObject;
Xacobeo::GObject->register_package('Gtk2::Entry' =>
properties => [
Glib::ParamSpec->object(
'ui-manager',
'UI Manager',
"The UI Manager that provides the UI",
'Gtk2::UIManager',
['readable', 'writable'],
),
],
);
# Builtin constructor
my $widget = My::Widget->new();
# Set the property and fires the signal 'notify::ui-manager'
$widget->set_ui_manager(Gtk2::UIManager->new);
# Get the property
$widget->get_ui_manager;
# Direct accessor/setter (the setter doesn't fire any signal)
$widget->ui_manager;
=head1 DESCRIPTION
Simple framework for building GObjects. This package is very similar to
C<Glib::Object::Subclass> except this one create accessors and setters for the
object properties.
=cut
use strict;
use warnings;
use Glib;
use Carp;
use Data::Dumper;
sub register_package {
my $self = shift;
my $class = caller;
$self->register_object($class, @_);
}
sub register_object {
croak "Missing a class and parent class" unless @_ > 2;
my (undef, $class, $parent, %args) = @_;
Glib::Type->register_object($parent, $class, %args);
# Make the class an instance of Glib::Object
do {
no strict 'refs';
unshift @{ "${class}::ISA" }, 'Glib::Object';
};
# For each property define a get_/set_ method
if (my $properties = $args{properties}) {
foreach my $property (@{ $properties }) {
my $name = $property->{name};
my $key = $property->get_name;
# The accessor: $value = $self->get_property
define_method($class, "get_$key", sub {
return $_[0]->{$key};
});
# The setter: $self->set_property($value)
define_method($class, "set_$key", sub {
$_[0]->set($name, $_[1]);
});
# Generic getter/setter which doesn't fire the 'notify' signal:
# $value = $self->property;
# $self->property($value);
define_method($class, $key, sub {
return @_ > 1 ? $_[0]{$key} = $_[1] : $_[0]{$key};
});
}
}
}
sub define_method {
my ($class, $method, $code) = @_;
return if $class->can($method);
# Error handling that reports the error as hapenning on the caller
my $sub = sub {
my ($return, @return);
my $wantarray = wantarray;
eval {
if ($wantarray) {
@return = $code->(@_);
}
else {
$return = $code->(@_);
}
1;
} or do {
# Tell the caller that this is their fault and not ours
my $error = $@;
$error =~ s/ at .*? line \d+\.\n$//;
croak $error;
};
return $wantarray ? @return : $return;
};
no strict 'refs';
*{"${class}::${method}"} = $sub;
}
# A true value
1;
=head1 AUTHORS
Emmanuel Rodriguez E<lt>potyl@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2008,2009 by Emmanuel Rodriguez.
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
|