view release on metacpan or  search on metacpan

lib/winja.pm  view on Meta::CPAN

                next if !exists $$h{ __PACKAGE__ . '' };
                $H = $$h{ __PACKAGE__ . '' };
                last;
            }
            goto &{ $override{$key} } if $H && $H & $bitmask{$key};
            goto &{ $MGR->{$key}->{saved} };
        };
    }
    $MGR->{$key}->{name}       = $name;
    $MGR->{$key}->{class}      = [@class];
    $MGR->{$key}->{saved}      = ( $org_methods{$key} || undef );
    $MGR->{$key}->{overridden} = 0;
    $init_done{$key}++;
};

my $make_classref = sub {
    return if !@_;
    no strict 'refs';
    my $self  = *main::;
    my @class = @_;
    for my $key (@class) {
        $self = ${$self}{ $key . '::' };
    }
    $self;
};

my $delete_sub_from = sub {
    return unless @_;
    my $sym = shift;
    no strict 'refs';
    return if !*{$sym}{CODE};
    my $self     = *{$sym}{CODE};
    my $classref = $make_classref->( @{ $MGR->{$sym}->{class} } );
    my $name     = $MGR->{$sym}->{name};
    my @refs     = grep {$_} map { *{$sym}{$_} } qw/SCALAR ARRAY HASH IO/;
    delete ${$classref}{$name};
    *{$sym} = $_ for @refs;
    return $self;
};

my $tags2keys = sub {
    my @invalid = grep { !exists $tag{$_} } @_;
    if (@invalid) {
        require Carp;
        Carp::croak( "Invalid tag '", join( "', '", @invalid ), "'" );
    }
    my (@tags) = @_;
    @tags = keys %tag if !@tags;
    my %seen;
    my @keys = grep { !$seen{$_}++ } map { @{ $tag{$_} } } @tags;
    no strict 'refs';
    no warnings 'once';
    @keys = grep { /\A CORE::GLOBAL::/x || *{$_}{CODE} } @keys;
    return @keys;
};

my $load = sub {
    my ($key) = @_;
    $init->($key) if !$MGR->{$key};
    die "Undefined flag of '$key'" if !exists $bitmask{$key};
    return if ( $^H{ __PACKAGE__ . '' } ||= 0 ) & $bitmask{$key};
    $^H{ __PACKAGE__ . '' } |= $bitmask{$key};
    no strict 'refs';
    no warnings 'redefine';
    no warnings 'prototype';
    my $coderef = *{$key}{CODE};

    if ( !$coderef || $MGR->{$key}->{self} ne $coderef ) {
        $MGR->{$key}->{saved} = $coderef
            if !$MGR->{$key}->{saved}
            || $coderef && $$MGR{$key}{saved} ne $coderef;
        $delete_sub_from->($key);
        *{$key} = $MGR->{$key}->{self};
    }
};

sub import {
    shift;
    my @keys = $tags2keys->(@_);
    return if !@keys;
    $load->($_) for (@keys);
}

sub debugs {
    return unless $ENV{'DEBUG_VERBOSE'};
    my ( $_pkg, $_file, $_line ) = caller(0);
    my ( $pkg,  $file,  $line )  = caller(1);
    print STDERR @_, ' <= ', qq{$_file line $_line}, ' <= ',
        qq{$file line $line}, $/;
}

no warnings 'void';
'End of winja
this module works for WIN32-JApanese only';
__END__

=head1 NAME

winja - dirty patch for handling pathname on MSWin32::Ja_JP.cp932


=head1 DESCRIPTION

winja is a module which works only on Win32-Japanese-Edition
( a.k.a. Win32-CP932-Edition. But not Cygwin ).
This module works to deal with file path which contains
multibytes letter including 0x5C byte correctly.

See L<winja::JP>(described in Japanese) for details.

This module is unnecessary for users besides Win32-Japanese-Edition.

You can not install this module to Perl on non-MSWin32-Japanese-Edition.

Even if you forcibly install this module on non-MSWin32 OS or MSWin32 which is not Japanese-Edition, you can not load this module (OS and Windows default language are checked).


=head1 AUTHOR

KPEE E<lt>kpee.cpanx@gmail.comE<gt>