view release on metacpan or  search on metacpan

lib/Convert/GeekCode.pm  view on Meta::CPAN

            $secref->{_},
            map {
                my $sym  = $secref->{$_};
                my $code = $_;
                $code =~ s/[\x27\/]//g;
                (
                    (
                        ( index( $code, $sec ) > -1 )
                        ? $code
                        : ( $code eq '!' ? "$code$sec" : "$sec$code" )
                    ),
                    $sym
                );
              } grep { $_ ne '_' }
              sort { calcv($a) cmp calcv($b); } keys( %{$secref} )
        );

        $out[-1] =~ s|\s+|/|g;
        $out[-1] =~ s|/+$||;
        $out[-1] =~ s|(?<=.)$sec||g;
    }

    return join( "\n",
        $self->{Head},
        $self->{Ver} . $self->{Version},
        join( ' ', @out ),
        $self->{Tail}, '', );
}

sub calcv {
    my $sym = shift or return '';

    return chr(0) x ( 10 - length($sym) ) if substr( $sym, 0, 1 ) eq '+';
    return chr(2) x length($sym) if substr( $sym, 0, 1 ) eq '-';
    return chr(1) if $sym eq '';
    return $sym;
}

sub tokenize {
    my ( $self, $sec, $chunk, $out ) = @_;

    foreach my $key ( sort { length($b) <=> length($a) } keys( %{$sec} ) ) {
        next if $key eq '_' or !$key;

        if ( $key =~ m|/(.+)/| ) {
            if ( $$chunk =~ s|^$1|| ) {
                $$out .= $sec->{$key} . $DELIMITER;
                return 1;
            }
        }
        elsif ( $$chunk =~ s/^\Q$key\E// ) {
            $$out .= $sec->{$key} . $DELIMITER;
            return 1;
        }
    }

    return;
}

sub locate {
    my $path = (caller)[0];
    my $file = $_[0];

    $path =~ s|::|/|g;
    $path =~ s|\w+\$||;

    unless ( -e $file ) {
        foreach my $inc (@INC) {
            last if -e ( $file = join( '/', $inc, $_[0] ) );
            last if -e ( $file = join( '/', $inc, $path, $_[0] ) );
        }
    }

    return -e $file ? $file : undef;
}

sub geek_decode {
    my $code = shift;
    my $obj  = __PACKAGE__->new(@_);    # XXX should auto-detect version

    return $obj->decode($code);
}

sub geek_encode {
    my $code = shift;
    my $obj  = __PACKAGE__->new(@_);    # XXX should auto-detect version

    return $obj->encode($code);
}

1;

__END__

=head1 SEE ALSO

L<geekgen>, L<geekdec>, L<YAML>

=head1 AUTHORS

唐鳳 E<lt>cpan@audreyt.orgE<gt>

=head1 CC0 1.0 Universal

To the extent possible under law, 唐鳳 has waived all copyright and related
or neighboring rights to Convert-GeekCode.

This work is published from Taiwan.

L<http://creativecommons.org/publicdomain/zero/1.0>

=cut