#!/usr/bin/perl
our
@EXPORT
=
qw(increment_value display_value)
;
sub
increment_value {
my
(
$self
,
$key
) =
@_
;
$self
->{
$key
}++
if
exists
$self
->{
$key
};
}
sub
display_value {
my
(
$self
,
$key
) =
@_
;
print
"$key: "
,
$self
->{
$key
} //
'undefined'
,
"\n"
;
}
sub
new {
my
$class
=
shift
;
my
$self
=
bless
{
count
=> 0 },
$class
;
return
$self
;
}
my
$object
= MyObject->new();
Extend(
$object
,
'MyMethods'
);
$object
->increment_value(
'count'
);
$object
->display_value(
'count'
);
$object
->increment_value(
'count'
);
$object
->display_value(
'count'
);
1;
sub
new {
my
$class
=
shift
;
my
$self
=
bless
{
data
=> [] },
$class
;
return
$self
;
}
my
$object
= MyDataStructure->new();
Extends(
$object
,
add_data
=>
sub
{
my
(
$self
,
$item
) =
@_
;
push
@{
$self
->{data}},
$item
; },
get_data
=>
sub
{
my
$self
=
shift
;
return
@{
$self
->{data}}; },
);
$object
->add_data(
'Item 1'
);
$object
->add_data(
'Item 2'
);
my
@data
=
$object
->get_data();
print
"Data: @data\n"
;
1;
our
@EXPORT
=
qw(increment_value display_value)
;
sub
increment_value {
my
(
$self
,
$value
) =
@_
;
$$self
+=
$value
;
}
sub
display_value {
my
(
$self
) =
@_
;
print
"Value: $$self\n"
;
}
sub
new {
my
$class
=
shift
;
my
$self
=
bless
\0,
$class
;
return
$self
;
}
sub
new {
my
$class
=
shift
;
my
$self
=
bless
\0,
$class
;
return
$self
;
}
my
$object1
= MyClass1->new();
my
$object2
= MyClass2->new();
Extends(
$object1
,
increment_value
=> \
&MyMethods::increment_value
,
display_value
=> \
&MyMethods::display_value
,
);
Extends(
$object2
,
increment_value
=> \
&MyMethods::increment_value
,
display_value
=> \
&MyMethods::display_value
,
);
$object1
->increment_value(10);
$object1
->display_value();
$object2
->increment_value(20);
$object2
->display_value();
1;
our
@EXPORT
=
qw(set get)
;
sub
set {
my
(
$self
,
$key
,
$value
) =
@_
;
$self
->{
$key
} =
$value
;
}
sub
get {
my
(
$self
,
$key
) =
@_
;
return
$self
->{
$key
};
}
1;
our
@EXPORT
=
qw(add get)
;
sub
add {
my
(
$self
,
$item
) =
@_
;
push
@$self
,
$item
;
}
sub
get {
my
(
$self
,
$index
) =
@_
;
return
$self
->[
$index
];
}
1;
our
@EXPORT
=
qw(set get substr length)
;
sub
set {
my
(
$self
,
$value
) =
@_
;
$$self
=
$value
;
}
sub
get {
my
(
$self
) =
@_
;
return
$$self
;
}
sub
substr
{
my
$self
=
shift
;
return
substr
(
$$self
,
@_
);
}
sub
length
{
my
(
$self
) =
@_
;
return
length
$$self
;
}
1;
my
$hash_object
= {};
my
$array_object
= [];
my
$scalar_object
= \
""
;
Extend(
$hash_object
,
'HashMethods'
,
'set'
,
'get'
);
Extend(
$array_object
,
'ArrayMethods'
,
'add'
,
'get'
);
Extend(
$scalar_object
,
'ScalarMethods'
,
'set'
,
'get'
,
'substr'
,
'length'
);
$hash_object
->set(
'key'
,
'value'
);
print
$hash_object
->get(
'key'
),
"\n"
;
$array_object
->add(
'item1'
);
$array_object
->add(
'item2'
);
print
$array_object
->get(0),
"\n"
;
$scalar_object
->set(
'John'
);
print
$scalar_object
->get(),
"\n"
;
print
$scalar_object
->
length
(),
"\n"
;
print
$scalar_object
->
substr
(1, 2),
"\n"
;
$scalar_object
->
substr
(1, 2,
"ane"
);
print
$scalar_object
->get(),
"\n"
;
1;
my
$object
= {};
my
$code_ref
=
sub
{
my
(
$self
,
$arg
) =
@_
;
return
"Hello, $arg!"
; };
Extends(
$object
,
'greet'
=> \
$code_ref
);
print
$object
->greet(
'Alice'
),
"\n"
;
1;
sub
set_hash_data {
my
(
$self
,
$key
,
$value
) =
@_
;
lock
(%{
$self
});
$self
->{
$key
} =
$value
;
}
sub
get_hash_data {
my
(
$self
,
$key
) =
@_
;
lock
(%{
$self
});
return
$self
->{
$key
};
}
sub
add_array_item {
my
(
$self
,
$item
) =
@_
;
lock
(@{
$self
});
push
@{
$self
},
$item
;
}
sub
get_array_item {
my
(
$self
,
$index
) =
@_
;
lock
(@{
$self
});
return
$self
->[
$index
];
}
sub
set_scalar_data {
my
(
$self
,
$value
) =
@_
;
lock
(${
$self
});
${
$self
} =
$value
;
}
sub
get_scalar_data {
my
(
$self
) =
@_
;
lock
(${
$self
});
return
${
$self
};
}
my
%shared_hash
:shared;
my
@shared_array
:shared;
my
$shared_scalar
:shared;
my
$shared_hash_object
= \
%shared_hash
;
my
$shared_array_object
= \
@shared_array
;
my
$shared_scalar_object
= \
$shared_scalar
;
Extends(
$shared_hash_object
,
set_hash_data
=> \
&set_hash_data
,
get_hash_data
=> \
&get_hash_data
,
);
Extends(
$shared_array_object
,
add_array_item
=> \
&add_array_item
,
get_array_item
=> \
&get_array_item
,
);
Extends(
$shared_scalar_object
,
set_scalar_data
=> \
&set_scalar_data
,
get_scalar_data
=> \
&get_scalar_data
,
);
my
$hash_thread
= threads->create(
sub
{
$shared_hash_object
->set_hash_data(
'key1'
,
'value1'
);
print
"Hash thread: key1 = "
.
$shared_hash_object
->get_hash_data(
'key1'
) .
"\n"
;
});
my
$array_thread
= threads->create(
sub
{
$shared_array_object
->add_array_item(
'item1'
);
print
"Array thread: item at index 0 = "
.
$shared_array_object
->get_array_item(0) .
"\n"
;
});
my
$scalar_thread
= threads->create(
sub
{
$shared_scalar_object
->set_scalar_data(
'shared_value'
);
print
"Scalar thread: value = "
.
$shared_scalar_object
->get_scalar_data() .
"\n"
;
});
$hash_thread
->
join
();
$array_thread
->
join
();
$scalar_thread
->
join
();
1;
sub
new {
my
$class
=
shift
;
my
$self
=
bless
{},
$class
;
return
$self
;
}
sub
original_method {
return
"Original method"
;
}
my
$object
= MyClass->new();
Alias(
$object
,
'alias_method'
,
'original_method'
);
print
$object
->alias_method(),
"\n"
;
1;
sub
new {
my
$class
=
shift
;
my
$self
=
bless
{},
$class
;
return
$self
;
}
sub
method1 {
return
"Method 1"
;
}
sub
method2 {
return
"Method 2"
;
}
my
$object
= MyClass->new();
print
$object
->method1(),
"\n"
;
print
$object
->method2(),
"\n"
;
Unload(
$object
,
'method1'
);
eval
{
$object
->method1();
};
warn
"Error: $@"
if
$@;
print
$object
->method2(),
"\n"
;
1;
sub
new {
my
$class
=
shift
;
my
$self
=
bless
{},
$class
;
return
$self
;
}
my
$object
= MyClass->new();
AddMethod(
$object
,
'new_method'
,
sub
{
return
"New method"
; });
print
$object
->new_method(),
"\n"
;
1;
sub
new {
my
$class
=
shift
;
my
$self
=
bless
{},
$class
;
return
$self
;
}
sub
original_method {
return
"Original method"
;
}
my
$object
= MyClass->new();
Decorate(
$object
,
'original_method'
,
sub
{
my
(
$self
,
$original
,
@args
) =
@_
;
return
"Before: "
.
$original
->(
$self
,
@args
) .
" After"
;
});
print
$object
->original_method(),
"\n"
;
1;
sub
apply {
my
(
$class
,
$object
) =
@_
;
no
strict
'refs'
;
*{
$object
.
"::new_method"
} =
sub
{
return
"New method"
; };
}
sub
new {
my
$class
=
shift
;
my
$self
=
bless
{},
$class
;
return
$self
;
}
my
$object
= MyClass->new();
ApplyRole(
$object
,
'TestRole'
);
print
$object
->new_method(),
"\n"
;
1;
sub
new {
return
bless
{},
shift
}
sub
DESTROY {
my
$self
=
shift
;
}
InitHook(
'TestObject'
,
'INIT'
,
sub
{
print
"Initializing object\n"
;
});
InitHook(
'TestObject'
,
'DESTRUCT'
,
sub
{
print
"Destructing object\n"
;
});
my
$object
= TestObject->new();
undef
$object
;
1;
my
$object
= Extend({},
'Extender'
);
$object
->Extends(
method
=>
sub
{
return
"method"
; } );
print
$object
->method(),
"\n"
;
my
$array
= Extend([],
'Extender'
);
$array
->Extends(
method
=>
sub
{
return
"method"
; } );
print
$array
->method(),
"\n"
;
my
$scalar
= Extend(\
""
,
'Extender'
);
$scalar
->Extends(
method
=>
sub
{
return
"method"
; } );
print
$scalar
->method(),
"\n"
;
my
$glob
= Extend(\
*GLOB
,
'Extender'
);
$glob
->Extends(
method
=>
sub
{
return
"method"
; } );
print
$glob
->method(),
"\n"
;
1;