Skip to content

Commit bccc8e0

Browse files
author
George Vaintrub
committed
My Homeworks from perl course
0 parents  commit bccc8e0

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

97 files changed

+5567
-0
lines changed

‎.gitignore

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
.DS_Store

‎Meowse/Example.pm

+49
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,49 @@
1+
package Person;
2+
use Meowse;
3+
has name => (is => 'ro', required => 1);
4+
has surname => (is => 'ro');
5+
has is_adult => (is => 'ro', lazy_build => 1);
6+
has age => (is => 'rw', required => 1);
7+
no Meowse;
8+
9+
sub greet {
10+
my $self = shift;
11+
return ('Hello! ' .'My name is '. $self->name . ($self->surname ? " ".$self->surname : '') . ". I am ".$self->age." years old.\n");
12+
}
13+
sub _build_is_adult {
14+
my $self = shift;
15+
return ($self->age >= 18) ? 'More than 18' : 'Less than 18';
16+
}
17+
18+
############################
19+
package Student;
20+
use Meowse;
21+
use feature 'say';
22+
use Data::Dumper;
23+
24+
extends 'Person';
25+
has university => (is => 'rw', required => 1);
26+
has city_univ => (is => 'rw', lazy_build => 1);
27+
around 'greet' => sub {
28+
my $orig = shift;
29+
my $self = shift;
30+
my $greeting = $self->$orig();
31+
$greeting .= "My university is ".$self->university;
32+
say $greeting;
33+
};
34+
no Meowse;
35+
sub _build_city_univ {
36+
my $self = shift;
37+
return $self->university eq 'mephi' ? 'Moscow' : ':(';
38+
}
39+
my $student = Student->new(university => 'mephi', name => 'George', age => 19, surname => 'Vayntrub');
40+
$student->greet;
41+
say;
42+
say 'has_is_adult - '. $student->has_is_adult;
43+
say 'is_adult - '. $student->is_adult;
44+
say 'has_is_adult - '. $student->has_is_adult;
45+
say 'clear_is_adult - '. $student->clear_is_adult;
46+
say 'has_is_adult - '. $student->has_is_adult;
47+
48+
49+
1;

‎Meowse/Meowse.pm

+61
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,61 @@
1+
package Meowse;
2+
use Meowse::Object;
3+
use Meowse::Meta::Class;
4+
5+
use Carp;
6+
use strict;
7+
use warnings;
8+
9+
use Exporter qw(import);
10+
our @EXPORT = qw(has extends around before after);
11+
12+
use feature 'say';
13+
use Data::Dumper;
14+
15+
sub unimport {
16+
my ($package, @args) = @_;
17+
my $from = caller;
18+
@args = @EXPORT unless @args;
19+
for (@args) {
20+
do {
21+
no strict 'refs';
22+
delete ${$from.'::'}{$_} || carp "Can't find a method $_";
23+
}
24+
}
25+
}
26+
27+
28+
sub has {
29+
my $meta = Meowse::Meta::Class->initialize(scalar caller);
30+
my $name_attr = shift; # Name(s) of attributes
31+
confess "Invalid number of param. Usage: has [name|names] => (is => 'rw|ro|bare', ...)"
32+
unless @_;
33+
for my $name (ref($name_attr) ? @{$name_attr} : $name_attr) {
34+
$meta->add_attribute($name => @_);
35+
}
36+
return;
37+
}
38+
39+
sub extends {
40+
Meowse::Meta::Class->initialize(scalar caller)->superclasses(@_);
41+
}
42+
43+
sub around {
44+
confess "Incorrect arguments. Usage: around 'method_name' => sub {....};" if (@_ != 2 || ref $_[1] ne 'CODE');
45+
Meowse::Meta::Class->initialize(scalar caller)->set_decorator('around', shift, shift);
46+
return;
47+
}
48+
49+
sub before {
50+
confess "Incorrect arguments. Usage: before 'method_name' => sub {....};" if (@_ != 2 || ref $_[1] ne 'CODE');
51+
Meowse::Meta::Class->initialize(scalar caller)->set_decorator('before', shift, shift);
52+
return;
53+
}
54+
55+
sub after {
56+
confess "Incorrect arguments. Usage: after 'method_name' => sub {....};" if (@_ != 2 || ref $_[1] ne 'CODE');
57+
Meowse::Meta::Class->initialize(scalar caller)->set_decorator('after', shift, shift);
58+
return;
59+
}
60+
61+
1;

‎Meowse/Meowse/Meta/Attribute.pm

+52
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,52 @@
1+
package Meowse::Meta::Attribute;
2+
use Carp;
3+
4+
use feature 'say';
5+
use Data::Dumper;
6+
7+
my %valid_params = (
8+
is => 1,
9+
lazy_build => 1,
10+
required => 1,
11+
name => 1,
12+
);
13+
14+
sub new {
15+
my ($class, $meta, %attr) = @_;
16+
#TODO validation
17+
for my $p (keys %attr) {
18+
unless ($valid_params{$p}) {
19+
croak "$p is unknown parameter!";
20+
}
21+
}
22+
my $self = bless \%attr, $class;
23+
$self->_install_accessor($meta);
24+
$self->_install_lazy($meta) if ($self->{lazy_build});
25+
return $self;
26+
}
27+
28+
sub _install_accessor {
29+
my ($self, $meta) = @_;
30+
my $generator = '_generate_';
31+
if ($self->{is} eq 'rw') {
32+
$generator .= 'accessor';
33+
} elsif ($self->{is} eq 'ro') {
34+
$generator .= 'reader';
35+
} else {
36+
confess "$self->{is} incorrect parameter. Possible: is => (rw|ro)";
37+
}
38+
39+
$generator = '_generate_lazy_accessor' if ($self->{lazy_build});
40+
$meta->add_method($self->{name}, $self->{name}, $generator);
41+
}
42+
sub _install_lazy {
43+
my ($self, $meta) = @_;
44+
$meta->add_method('clear_'.$self->{name}, $self->{name}, '_generate_clear');
45+
$meta->add_method('has_'.$self->{name}, $self->{name}, '_generate_has');
46+
}
47+
sub is_required {
48+
my $self = shift;
49+
return $self->{required} ? 1 : 0;
50+
}
51+
52+
1;

‎Meowse/Meowse/Meta/Class.pm

+120
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,120 @@
1+
package Meowse::Meta::Class;
2+
use Meowse::Meta::Attribute;
3+
use Meowse::Meta::Method;
4+
5+
use Exporter qw(import);
6+
our @EXPORT = ('_get_meta_by_class');
7+
8+
use Carp;
9+
use Data::Dumper;
10+
use Scalar::Util qw(blessed);
11+
use feature 'say';
12+
13+
my %METAS;
14+
15+
16+
sub initialize {
17+
my ($class, $pkg) = @_;
18+
return $METAS{$pkg} ||= $class->_create_meta(package => $pkg);
19+
}
20+
sub add_attribute {
21+
my $self = shift;
22+
my $name = shift;
23+
$name or croak "Name of attribute must be defined";
24+
$self->{attributes}->{$name} = Meowse::Meta::Attribute->new($self, 'name' => $name, @_);
25+
}
26+
sub superclasses {
27+
my $self = shift;
28+
my $super_class = shift;
29+
my $super_meta = _get_meta_by_class($super_class);
30+
@{ $self->{superclasses} } = ($super_class) if ($super_meta);
31+
}
32+
33+
sub _get_meta_by_class {
34+
my $super = shift;
35+
my $meta = $METAS{$super};
36+
#carp "$super is not Meowse's class!" unless $meta;
37+
return $meta;
38+
}
39+
sub _create_meta {
40+
my ($class, %args) = @_;
41+
$args{attributes} = {};
42+
$args{methods} = {};
43+
$args{superclasses} = do {
44+
no strict 'refs';
45+
\@{$args{package}.'::ISA'};
46+
};
47+
push @{$args{superclasses}}, 'Meowse::Object';
48+
my $self = bless \%args, $class;
49+
return $self;
50+
}
51+
52+
sub set_decorator {
53+
my ($self, $type, $name, $code) = @_;
54+
my $class = $self->{package};
55+
#TODO CHECK
56+
my $orig = $class->can($name) or carp "$name was not found!";
57+
if (!$self->{decorators}->{$name}) {
58+
my (@before, @after, @around);
59+
my $next = $orig;
60+
my $decorator = sub {
61+
if (@before) {
62+
$_->(@_) for(@before);
63+
}
64+
unless (@after) {
65+
return $next->(@_);
66+
}
67+
if (wantarray) { # list context
68+
my @val = $next->(@_);
69+
$_->(@_) for(@after);
70+
return @val;
71+
} elsif (defined wantarray) { # Scalar
72+
my $val = $next->(@_);
73+
$_->(@_) for(@after);
74+
return $val;
75+
} else { # void
76+
$next->(@_);
77+
$_->(@_) for(@after);
78+
return;
79+
}
80+
};
81+
$self->{decorators}->{$name} = {
82+
before => \@before,
83+
after => \@after,
84+
around => \@around,
85+
next => \$next,
86+
};
87+
$self->add_method($name, $name, $decorator);
88+
}
89+
if ($type eq 'before') {
90+
push @{ $self->{decorators}->{$name}->{before} }, $code;
91+
} elsif ($type eq 'after') {
92+
push @{ $self->{decorators}->{$name}->{after} }, $code;
93+
} else { # around
94+
push @{ $self->{decorators}->{$name}->{around} }, $code;
95+
my $next = ${ $self->{decorators}->{$name}->{next} };
96+
${ $self->{decorators}->{$name}->{next} } = sub { $code->($next, @_) };
97+
}
98+
return;
99+
}
100+
101+
sub add_method {
102+
my ($self, $name_method, $name_attr, $method) = @_;
103+
# $method either generator or code ref
104+
$self->{methods}->{$name_method} = Meowse::Meta::Method->new($name_attr, $method);
105+
*{$self->{package}.'::'.$name_method} = $self->{methods}->{$name_method}->code;
106+
}
107+
108+
sub validate_attr {
109+
my ($self, %data) = @_;
110+
my $super_meta = _get_meta_by_class(@{ $self->{superclasses} });
111+
my %attributes = (%{ $self->{attributes} }, %{ $super_meta->{attributes} }); # All attributes
112+
my @bad;
113+
for my $attr (keys %attributes) {
114+
if ($attributes{$attr}->is_required && !$data{$attr}) {
115+
push @bad, $attr;
116+
}
117+
}
118+
croak "Attributes [@bad] are required!" if (@bad);
119+
}
120+
1;

‎Meowse/Meowse/Meta/Method.pm

+83
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,83 @@
1+
package Meowse::Meta::Method;
2+
use Carp;
3+
4+
sub new {
5+
my ($class, $name, $generator) = @_;
6+
my $code;
7+
if (ref $generator eq 'CODE') {
8+
$code = $generator # Already generated
9+
} else {
10+
my $generated = $generator->($name);
11+
my $e = do{
12+
local $@;
13+
$code = eval $generated;
14+
$@;
15+
};
16+
die $e if $e;
17+
}
18+
return bless {code => $code}, $class;
19+
}
20+
21+
sub _generate_accessor {
22+
my ($name) = @_;
23+
my $accessor = "sub {
24+
my \$self = shift;
25+
my \$value = shift;
26+
if (\$value) {
27+
\$self->{$name} = \$value;
28+
}
29+
return \$self->{$name}
30+
}";
31+
return $accessor;
32+
}
33+
sub _generate_reader {
34+
my ($name) = @_;
35+
my $reader = "sub {
36+
my \$self = shift;
37+
carp 'This attribute is read-only' if (shift);
38+
return \$self->{$name};
39+
}";
40+
return $reader;
41+
}
42+
sub _generate_lazy_accessor {
43+
my ($name) = @_;
44+
my $accessor .= "sub {
45+
my \$self = shift;
46+
if (\$self->{$name}) {
47+
return \$self->{$name};
48+
} else {
49+
my \$builder = \$self->can('_build_'.$name) or croak 'Cannot find builder _build_$name';
50+
\$self->{$name} = \$builder->(\$self);
51+
return \$self->{$name};
52+
}
53+
}";
54+
return $accessor;
55+
}
56+
sub _generate_clear {
57+
my ($name) = @_;
58+
my $clearer .= "sub {
59+
my \$self = shift;
60+
if (\$self->{$name}) {
61+
delete \$self->{$name};
62+
}
63+
}";
64+
return $clearer;
65+
}
66+
sub _generate_has {
67+
my ($name) = @_;
68+
my $has .= "sub {
69+
my \$self = shift;
70+
if (\$self->{$name}) {
71+
return 1;
72+
}
73+
return 0;
74+
}";
75+
return $has;
76+
}
77+
78+
sub code {
79+
my $self = shift;
80+
return $self->{code};
81+
}
82+
83+
1;

‎Meowse/Meowse/Object.pm

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
package Meowse::Object; # Base class for all Meowse's classes
2+
use Meowse::Meta::Class;
3+
4+
sub new {
5+
my ($class, %data) = @_;
6+
my $meta = _get_meta_by_class($class);
7+
$meta->validate_attr(%data);
8+
my $self = bless \%data, $class;
9+
return $self;
10+
}
11+
12+
1;

‎README.md

+1
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
# Домашние задания (Technoatom Master Perl 2020)

0 commit comments

Comments
 (0)