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

#!/usr/bin/env perl
package Mouse::Util;
use strict;
use warnings;
use Exporter 'import';
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 {
    if ($Mouse::PurePerl) {
        _install_pp_func();
    } 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 {
                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
            };
        }

        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 _install_pp_func {
    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;
        }
    }
}

sub apply_all_roles {
    my $meta = Mouse::Meta::Class->initialize(shift);
    my $role  = shift;
    confess "Mouse::Util only supports 'apply_all_roles' on individual roles at a time" if @_;

    Mouse::load_class($role);
    $role->meta->apply($meta);
}

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