[gitmo/Mouse.git] / lib / Mouse / Util.pm

#!/usr/bin/env perl
package Mouse::Util;
use strict;
use warnings;
use base qw/Exporter/;
use Carp;

our @EXPORT_OK = qw(
    blessed
    get_linear_isa
    looks_like_number
    openhandle
    reftype
    weaken
);
our %EXPORT_TAGS = (
    all  => \@EXPORT_OK,
);

# We only have to do this nastiness if we haven't loaded XS version of
# Mouse.pm, so check if we're running under PurePerl or not
BEGIN {
    # Checking for undefinedness will ensure that our functions are
    # properly loaded without loading Mouse, but this is kind of ugly
    if ($Mouse::PurePerl || ! defined $Mouse::PurePerl) {
        my %dependencies = (
            'Scalar::Util' => {
    #       VVVVV   CODE TAKEN FROM SCALAR::UTIL   VVVVV
                'blessed' => do {
                    *UNIVERSAL::a_sub_not_likely_to_be_here = sub {
                        my $ref = ref($_[0]);
    
                        # deviation from Scalar::Util
                        # XS returns undef, PP returns GLOB.
                        # let's make that more consistent by having PP return
                        # undef if it's a GLOB. :/
    
                        # \*STDOUT would be allowed as an object in PP blessed
                        # but not XS
                        return $ref eq 'GLOB' ? undef : $ref;
                    };
    
                    sub {
                        local($@, $SIG{__DIE__}, $SIG{__WARN__});
                        length(ref($_[0]))
                            ? eval { $_[0]->a_sub_not_likely_to_be_here }
                            : undef;
                    },
                },
                'looks_like_number' => sub {
                    local $_ = shift;
    
                    # checks from perlfaq4
                    return 0 if !defined($_) or ref($_);
                    return 1 if (/^[+-]?\d+$/); # is a +/- integer
                    return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
                    return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
    
                    0;
                },
                'reftype' => sub {
                    local($@, $SIG{__DIE__}, $SIG{__WARN__});
                    my $r = shift;
                    my $t;
    
                    length($t = ref($r)) or return undef;
    
                    # This eval will fail if the reference is not blessed
                    eval { $r->a_sub_not_likely_to_be_here; 1 }
                    ? do {
                        $t = eval {
                            # we have a GLOB or an IO. Stringify a GLOB gives it's name
                            my $q = *$r;
                            $q =~ /^\*/ ? "GLOB" : "IO";
                        }
                        or do {
                            # OK, if we don't have a GLOB what parts of
                            # a glob will it populate.
                            # NOTE: A glob always has a SCALAR
                            local *glob = $r;
                            defined *glob{ARRAY} && "ARRAY"
                                or defined *glob{HASH} && "HASH"
                                or defined *glob{CODE} && "CODE"
                                or length(ref(${$r})) ? "REF" : "SCALAR";
                        }
                    }
                    : $t
                },
                'openhandle' => sub {
                    my $fh = shift;
                    my $rt = reftype($fh) || '';
    
                    return defined(fileno($fh)) ? $fh : undef
                        if $rt eq 'IO';
    
                    if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
                        $fh = \(my $tmp=$fh);
                    }
                    elsif ($rt ne 'GLOB') {
                        return undef;
                    }
    
                    (tied(*$fh) or defined(fileno($fh)))
                        ? $fh : undef;
                },
                weaken => {
                    loaded => \&Scalar::Util::weaken,
                    not_loaded => sub { die "Scalar::Util required for weak reference support" },
                },
    #       ^^^^^   CODE TAKEN FROM SCALAR::UTIL   ^^^^^
            },
            'MRO::Compat' => {
    #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
                'get_linear_isa' => {
                    loaded     => \&mro::get_linear_isa,
                    not_loaded => do {
                        # this recurses so it isn't pretty
                        my $code;
                        $code = sub {
                            no strict 'refs';
    
                            my $classname = shift;
    
                            my @lin = ($classname);
                            my %stored;
                            foreach my $parent (@{"$classname\::ISA"}) {
                                my $plin = $code->($parent);
                                foreach (@$plin) {
                                    next if exists $stored{$_};
                                    push(@lin, $_);
                                    $stored{$_} = 1;
                                }
                            }
                            return \@lin;
                        }
                    },
                },
    #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
            },
        );
    
        my %loaded;
        for my $module_name (keys %dependencies) {
            my $loaded = do {
                local $SIG{__DIE__} = 'DEFAULT';
                eval "require $module_name; 1";
            };
    
            $loaded{$module_name} = $loaded;
    
            for my $method_name (keys %{ $dependencies{ $module_name } }) {
                my $producer = $dependencies{$module_name}{$method_name};
                my $implementation;
    
                if (ref($producer) eq 'HASH') {
                    $implementation = $loaded
                                    ? $producer->{loaded}
                                    : $producer->{not_loaded};
                }
                else {
                    $implementation = $loaded
                                    ? $module_name->can($method_name)
                                    : $producer;
                }
    
                no strict 'refs';
                *{ __PACKAGE__ . '::' . $method_name } = $implementation;
            }
        }
    } else {
        # If we're running under XS, we can provide
        #   blessed
        #   looks_like_number
        #   reftype
        #   weaken
        # other functions need to be loaded from our respective sources

        if (defined &Scalar::Util::openhandle) {
            *openhandle = \&Scalar::Util::openhandle;
        } else {
            # XXX - room for improvement
            *openhandle = sub {
                my $fh = shift;
                my $rt = reftype($fh) || '';

                return defined(fileno($fh)) ? $fh : undef
                    if $rt eq 'IO';

                if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
                    $fh = \(my $tmp=$fh);
                }
                elsif ($rt ne 'GLOB') {
                    return undef;
                }

                (tied(*$fh) or defined(fileno($fh)))
                    ? $fh : undef;
            };
        }

        if (defined &mro::get_linear_isa || eval { require MRO::Compat; 1; }) {
            *get_linear_isa = \&mro::get_linear_isa;
        } else {
            # this recurses so it isn't pretty
            my $code;
            *get_linear_isa = $code = sub {
                no strict 'refs';

                my $classname = shift;

                my @lin = ($classname);
                my %stored;
                foreach my $parent (@{"$classname\::ISA"}) {
                    my $plin = $code->($parent);
                    foreach (@$plin) {
                        next if exists $stored{$_};
                        push(@lin, $_);
                        $stored{$_} = 1;
                    }
                }
                return \@lin;
            };
        }
    }
}

sub apply_all_roles {
    my $meta = Mouse::Meta::Class->initialize(shift);

    my @roles;
    my $max = scalar(@_);
    for (my $i = 0; $i < $max ; $i++) {
        if ($i + 1 < $max && ref($_[$i + 1])) {
            push @roles, [ $_[$i++] => $_[$i] ];
        } else {
            push @roles, [ $_[$i] => {} ];
        }
    }

    foreach my $role_spec (@roles) {
        Mouse::load_class( $role_spec->[0] );
    }

    ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
        || croak("You can only consume roles, "
        . $_->[0]
        . " is not a Moose role")
        foreach @roles;

    if ( scalar @roles == 1 ) {
        my ( $role, $params ) = @{ $roles[0] };
        $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
    }
    else {
        Mouse::Meta::Role->combine_apply($meta, @roles);
    }

}

1;

__END__

=head1 NAME

Mouse::Util - features, with or without their dependencies

=head1 IMPLEMENTATIONS FOR

=head2 L<MRO::Compat>

=head3 get_linear_isa

=head2 L<Scalar::Util>

=head3 blessed

=head3 looks_like_number

=head3 reftype

=head3 openhandle

=head3 weaken

C<weaken> I<must> be implemented in XS. If the user tries to use C<weaken>
without L<Scalar::Util>, an error is thrown.

=head2 Test::Exception

=head3 throws_ok

=head3 lives_ok

=cut
Commit	Line	Data
4093c859	1	#!/usr/bin/env perl
	2	package Mouse::Util;
	3	use strict;
	4	use warnings;
5c12655d	5	use base qw/Exporter/;
d72006ca	6	use Carp;
4093c859	7
eae80759	8	our @EXPORT_OK = qw(
	9	blessed
	10	get_linear_isa
	11	looks_like_number
	12	openhandle
	13	reftype
	14	weaken
	15	);
	16	our %EXPORT_TAGS = (
	17	all => \@EXPORT_OK,
	18	);
	19
	20	# We only have to do this nastiness if we haven't loaded XS version of
	21	# Mouse.pm, so check if we're running under PurePerl or not
42d7df00	22	BEGIN {
3f8f481d	23	# Checking for undefinedness will ensure that our functions are
	24	# properly loaded without loading Mouse, but this is kind of ugly
	25	if ($Mouse::PurePerl \|\| ! defined $Mouse::PurePerl) {
64959bc9	26	my %dependencies = (
	27	'Scalar::Util' => {
	28	# VVVVV CODE TAKEN FROM SCALAR::UTIL VVVVV
	29	'blessed' => do {
	30	*UNIVERSAL::a_sub_not_likely_to_be_here = sub {
	31	my $ref = ref($_[0]);
	32
	33	# deviation from Scalar::Util
	34	# XS returns undef, PP returns GLOB.
	35	# let's make that more consistent by having PP return
	36	# undef if it's a GLOB. :/
	37
	38	# \*STDOUT would be allowed as an object in PP blessed
	39	# but not XS
	40	return $ref eq 'GLOB' ? undef : $ref;
	41	};
	42
	43	sub {
	44	local($@, $SIG{__DIE__}, $SIG{__WARN__});
	45	length(ref($_[0]))
	46	? eval { $_[0]->a_sub_not_likely_to_be_here }
	47	: undef;
	48	},
	49	},
	50	'looks_like_number' => sub {
	51	local $_ = shift;
	52
	53	# checks from perlfaq4
	54	return 0 if !defined($_) or ref($_);
	55	return 1 if (/^[+-]?\d+$/); # is a +/- integer
	56	return 1 if (/^([+-]?)(?=\d\|\.\d)\d(\.\d)?([Ee]([+-]?\d+))?$/); # a C float
	57	return 1 if ($] >= 5.008 and /^(Inf(inity)?\|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
	58
	59	0;
	60	},
	61	'reftype' => sub {
	62	local($@, $SIG{__DIE__}, $SIG{__WARN__});
	63	my $r = shift;
	64	my $t;
	65
	66	length($t = ref($r)) or return undef;
	67
	68	# This eval will fail if the reference is not blessed
	69	eval { $r->a_sub_not_likely_to_be_here; 1 }
	70	? do {
	71	$t = eval {
	72	# we have a GLOB or an IO. Stringify a GLOB gives it's name
	73	my $q = *$r;
	74	$q =~ /^\*/ ? "GLOB" : "IO";
	75	}
	76	or do {
	77	# OK, if we don't have a GLOB what parts of
	78	# a glob will it populate.
	79	# NOTE: A glob always has a SCALAR
	80	local *glob = $r;
	81	defined *glob{ARRAY} && "ARRAY"
	82	or defined *glob{HASH} && "HASH"
	83	or defined *glob{CODE} && "CODE"
	84	or length(ref(${$r})) ? "REF" : "SCALAR";
	85	}
	86	}
	87	: $t
	88	},
	89	'openhandle' => sub {
90	my $fh = shift;
91	my $rt = reftype($fh) \|\| '';
92
93	return defined(fileno($fh)) ? $fh : undef
94	if $rt eq 'IO';
95
96	if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA)
97	$fh = \(my $tmp=$fh);
98	}
99	elsif ($rt ne 'GLOB') {
100	return undef;
101	}
102
103	(tied(*$fh) or defined(fileno($fh)))
104	? $fh : undef;
105	},
106	weaken => {
107	loaded => \&Scalar::Util::weaken,
108	not_loaded => sub { die "Scalar::Util required for weak reference support" },
109	},
110	# ^^^^^ CODE TAKEN FROM SCALAR::UTIL ^^^^^
111	},
112	'MRO::Compat' => {
113	# VVVVV CODE TAKEN FROM MRO::COMPAT VVVVV
114	'get_linear_isa' => {
115	loaded => \&mro::get_linear_isa,
116	not_loaded => do {
117	# this recurses so it isn't pretty
118	my $code;
119	$code = sub {
120	no strict 'refs';
121
122	my $classname = shift;
123
124	my @lin = ($classname);
125	my %stored;
126	foreach my $parent (@{"$classname\::ISA"}) {
127	my $plin = $code->($parent);
128	foreach (@$plin) {
129	next if exists $stored{$_};
130	push(@lin, $_);
131	$stored{$_} = 1;
132	}
133	}
134	return \@lin;
135	}
136	},
137	},
138	# ^^^^^ CODE TAKEN FROM MRO::COMPAT ^^^^^
139	},
140	);
141
142	my %loaded;
143	for my $module_name (keys %dependencies) {
144	my $loaded = do {
145	local $SIG{__DIE__} = 'DEFAULT';
146	eval "require $module_name; 1";
147	};
148
149	$loaded{$module_name} = $loaded;
150
151	for my $method_name (keys %{ $dependencies{ $module_name } }) {
152	my $producer = $dependencies{$module_name}{$method_name};
153	my $implementation;
154
155	if (ref($producer) eq 'HASH') {
156	$implementation = $loaded
157	? $producer->{loaded}
158	: $producer->{not_loaded};
159	}
160	else {
161	$implementation = $loaded
162	? $module_name->can($method_name)
163	: $producer;
164	}
165
166	no strict 'refs';
167	*{ __PACKAGE__ . '::' . $method_name } = $implementation;
168	}
169	}
eae80759	170	} else {
	171	# If we're running under XS, we can provide
	172	# blessed
	173	# looks_like_number
	174	# reftype
	175	# weaken
	176	# other functions need to be loaded from our respective sources
	177
9524350b	178	if (defined &Scalar::Util::openhandle) {
eae80759	179	*openhandle = \&Scalar::Util::openhandle;
	180	} else {
	181	# XXX - room for improvement
	182	*openhandle = sub {
21313741	183	my $fh = shift;
21313741	184	my $rt = reftype($fh) \|\| '';
577be390	185
21313741	186	return defined(fileno($fh)) ? $fh : undef
21313741	187	if $rt eq 'IO';
eae80759	188
21313741	189	if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA)
21313741	190	$fh = \(my $tmp=$fh);
eae80759	191	}
21313741	192	elsif ($rt ne 'GLOB') {
	193	return undef;
	194	}
	195
	196	(tied(*$fh) or defined(fileno($fh)))
	197	? $fh : undef;
eae80759	198	};
	199	}
	200
214c3ab9	201	if (defined &mro::get_linear_isa \|\| eval { require MRO::Compat; 1; }) {
eae80759	202	*get_linear_isa = \&mro::get_linear_isa;
	203	} else {
	204	# this recurses so it isn't pretty
	205	my $code;
	206	*get_linear_isa = $code = sub {
	207	no strict 'refs';
	208
	209	my $classname = shift;
	210
	211	my @lin = ($classname);
	212	my %stored;
	213	foreach my $parent (@{"$classname\::ISA"}) {
	214	my $plin = $code->($parent);
	215	foreach (@$plin) {
	216	next if exists $stored{$_};
	217	push(@lin, $_);
	218	$stored{$_} = 1;
	219	}
	220	}
	221	return \@lin;
	222	};
	223	}
	224	}
	225	}
	226
2e92bb89	227	sub apply_all_roles {
2e92bb89	228	my $meta = Mouse::Meta::Class->initialize(shift);
2e92bb89	229
21498b08	230	my @roles;
	231	my $max = scalar(@_);
	232	for (my $i = 0; $i < $max ; $i++) {
	233	if ($i + 1 < $max && ref($_[$i + 1])) {
	234	push @roles, [ $_[$i++] => $_[$i] ];
	235	} else {
	236	push @roles, [ $_[$i] => {} ];
	237	}
	238	}
	239
	240	foreach my $role_spec (@roles) {
	241	Mouse::load_class( $role_spec->[0] );
	242	}
	243
	244	( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
	245	\|\| croak("You can only consume roles, "
	246	. $_->[0]
	247	. " is not a Moose role")
	248	foreach @roles;
	249
	250	if ( scalar @roles == 1 ) {
	251	my ( $role, $params ) = @{ $roles[0] };
	252	$role->meta->apply( $meta, ( defined $params ? %$params : () ) );
	253	}
	254	else {
	255	Mouse::Meta::Role->combine_apply($meta, @roles);
	256	}
	257
2e92bb89	258	}
2e92bb89	259
4093c859	260	1;
4093c859	261
f38ce2d0	262	__END__
	263
	264	=head1 NAME
	265
	266	Mouse::Util - features, with or without their dependencies
	267
	268	=head1 IMPLEMENTATIONS FOR
	269
	270	=head2 L<MRO::Compat>
	271
	272	=head3 get_linear_isa
	273
	274	=head2 L<Scalar::Util>
	275
	276	=head3 blessed
	277
	278	=head3 looks_like_number
	279
	280	=head3 reftype
	281
	282	=head3 openhandle
	283
	284	=head3 weaken
	285
	286	C<weaken> I<must> be implemented in XS. If the user tries to use C<weaken>
	287	without L<Scalar::Util>, an error is thrown.
	288
ea0b9e39	289	=head2 Test::Exception
	290
	291	=head3 throws_ok
	292
	293	=head3 lives_ok
	294
f38ce2d0	295	=cut
f38ce2d0	296