File Coverage

blib/lib/Data/ToruCa.pm

Criterion	Covered	Total	%
statement	90	121	74.3
branch	46	62	74.1
condition	22	24	91.6
subroutine	20	25	80.0
pod	17	18	94.4
total	195	250	78.0

package Data::ToruCa;

use strict;
use MIME::Base64;

use vars qw(@ISA @EXPORT_OK);

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(cat2pict);

our $VERSION = '0.06';
our $VERBOSE = 0;

sub new {
    my $class = shift;
    my $opt = shift;

    my $self = bless {}, $class;
    if (ref($opt) eq 'HASH') {
        foreach (keys %$opt) {
            $self->{$_} = $opt->{$_};
        }
    } elsif (ref($opt) eq '' && $opt) {
        $self->parse($opt);
    }

    return $self;
}

sub _warn {
    warn shift
	if ($VERBOSE);
}

sub ext {'trc'}
sub content_type {'application/x-toruca'}

sub _accessor {
    my $self  = shift;
    my $field = shift;
    my $size  = shift;
    my $data  = shift;
    return $self->{$field} unless $data;
    _warn "length of $field is too large($size bytes)."
        if length($data) > $size;
    $self->{$field} = $data;
}
sub version {shift->_accessor('version', 4, @_)}
sub type    {shift->_accessor('type', 8, @_)}
sub url     {shift->_accessor('url', 127, @_)}
sub data1   {shift->_accessor('data1', 40, @_)}
sub data2   {shift->_accessor('data2', 100, @_)}
sub data3   {shift->_accessor('data3', 20, @_)}
sub cat     {shift->_accessor('cat', 4, @_)}
sub mime    {my $self = shift;return $self->{mime} = @_ ? shift : $self->{mime}}
sub pict    {my $self = shift;$self->cat2pict($self->cat);}

sub parse {
    my $self = shift;
    my $trc = shift;

    unless ($trc =~ /^ToruCa\r\n/) {
        _warn 'toruca format error.';
        return 0;
    }

    my $mime;
    my $c = 0;
    foreach (split(/\r\n/, $trc)) {
	if ($c < 2) {
	    if (/^([^:]+): (.+)$/) {
		my ($field, $data) = (lc($1), $2);
		$data = decode_base64($data)
		    if ($field =~ /^data/);
		$self->_accessor($field, 200, $data);
	    } elsif ($_ eq '') {
		$c++;
	    }
	} else {
	    $mime .= "$_\r\n";
	}
    }
    if ($mime) {
        $mime =~ s/^\r\n//;
        $mime =~ s/\r\n$//;
        $self->mime($mime);
    }
    return 1;
}

sub _build {
    my $self = shift;

    _warn 'length of (url & data1 & data2 & data3) is too large(173 bytes).'
        if length($self->url.$self->data1.$self->data2.$self->data3) > 173;

    _warn 'url schme error (http only).'
        unless $self->url =~ m|^http://|i;

    $self->version('1.0') unless $self->version;
    $self->type('SNIP') unless $self->type;
    $self->cat('0000') unless $self->cat =~ m|^[0-9a-fA-F]{4,4}$|;
    $self->cat('0000') unless $self->cat;
    $self->cat(uc($self->cat));
}

sub build {
    my $self = shift;

    $self->_build;

    return "ToruCa\r\n" .
    'Version: ' . $self->version. "\r\n" .
    'Type: ' . $self->type . "\r\n" .
    "\r\n" .
    'URL: '. $self->url . "\r\n" .
    'Data1: ' . $self->_base64($self->data1) . "\r\n" .
    'Data2: ' . $self->_base64($self->data2) . "\r\n" .
    'Data3: ' . $self->_base64($self->data3) . "\r\n" .
    'Cat: ' . $self->cat. "\r\n" .
    "\r\n";
}

sub detail_build {
    my $self = shift;

    my $type = $self->type;
    $self->type('CARD');
    my $toruca = $self->build;
    $self->type($type);

    return $toruca . $self->mime;
}

sub html_build {
    my $self = shift;
    my $html = shift;

    my $boundary;
    my $i = 0;
    while (1) {
	$i++;
	return if $i > 100;
        $boundary = sprintf("%010d", rand(1000000000));
        last unless $html =~ /$boundary/;
    }

    my $mime = $self->mime;
    $self->mime("MIME-Version: 1.0\r\n" .
		"Content-Type: multipart/mixed;boundary=\"$boundary\"\r\n" .
		"\r\n" .
		"--$boundary\r\n" .
		"Content-Type: text/html; charset=Shift_JIS\r\n" .
		"Content-Transfer-Encoding: 8bit\r\n" .
		"\r\n" .
		"$html\r\n" .
		"--$boundary--\r\n");
    my $toruca = $self->detail_build;
    $self->mime($mime);

    return $toruca;
}

sub rw_build {
    my $self = shift;

    $self->_build;

    my $subprm = "\x01\x31\x30" .
        pack("v", length($self->url)) . $self->url .
        pack("v", length($self->data1)) . $self->data1 .
        pack("v", length($self->data2)) . $self->data2 .
        pack("v", length($self->data3)) . $self->data3;
    $self->cat =~ /^(..)(..)$/;
    my ($catb, $catl) = ($1, $2);
    eval "\$subprm .= \"\\x$catb\\x$catl\";";

    my $data = "\x01\x20" . pack("v", length($subprm)) . $subprm;

    my $sum = 0;
    foreach (split(//, $data)) {
        $sum += unpack("C", $_);
    }
    $data .= pack("n", 65536 - ($sum % 65536));

    return $data;
}

sub _base64 {
    my $self = shift;
    my $data = encode_base64(shift);
    $data =~ s/\s//g;
    return $data;
}

sub cat2pict {
    my $cat = ref($_[0]) eq __PACKAGE__ ? $_[1] : $_[0];
    return '' unless $cat =~ /^[0-9A-F]{1,4}$/io;
    $cat =~ s/^0+//o;

    my $base = hex($cat);
    my $pad = 63646;
    if ($base > 94 && $base < 105) {
        $pad = 63808 - 95;
    } elsif ($base > 104 && $base < 118) {
        $pad = 63858 - 105;
    } elsif ($base > 117 && $base < 135) {
        $pad = 63872 - 118;
    } elsif ($base eq 135) {
        $pad = 63920 - 135;
    } elsif ($base > 135 && $base < 167) {
        $pad = 63889 - 136;
    } elsif ($base > 166 && $base < 170) {
        $pad = 63824 - 167;
    } elsif ($base > 169 && $base < 173) {
        $pad = 63829 - 170;
    } elsif ($base > 172 && $base < 177) {
        $pad = 63835 - 173;
    } elsif ($base > 176) {
        $pad = 63921 - 177;
    }
    return pack('n', $pad + $base);
}

1;
__END__