Author Topic: perl lpc  (Read 1754 times)

Offline quixadhal

  • BFF
  • ***
  • Posts: 642
    • View Profile
    • WileyMUD
perl lpc
« on: May 27, 2012, 04:05:11 AM »
You had to look, didn't you?

Nooooo, silly wabbit.  This isn't an LPC interpreter written in perl... or at least, it's only a very tiny bit of one. *smile*

This is, instead, a few useful utilities for those of you (no one) that have been begging for a way to talk to I3 from perl.  It's not YET an actual I3 client, but it is the first few steps needed to start thinking about one.

Code: [Select]
#!/usr/bin/perl -w

use strict;
use English;
use Data::Dumper;
use JSON;

sub json_to_lpc {
    my $thing = shift;

    return undef if !defined $thing;
    #JSON and LPC are very similar, in fact to convert from
    #one to the other, all we REALLY need to do (for purposes
    #of using mudmode sockets and LPC data types) is convert
    #{ pairs to ([ pairs, and [ pairs to ({ pairs, avoiding
    #anything inside double-quoted strings.

    my $result = "";
    my $nested_mappings = 0;
    my $nested_arrays = 0;
    my $inside_quotes = 0;
    my $is_backslash = 0;
    my $is_unicode = 0;
    my $unicode = '';

    foreach my $ch (split //, $thing) {
        if( $inside_quotes ) {
            if( $is_backslash ) {
                if( $is_unicode ) {
                    if( length $unicode < 4 ) {
                        $unicode .= $ch;
                    } else {
                        if( $unicode eq '0000' ) {
                            # This is what the JSON encoder does with NUL bytes, but
                            # LPC wants \0, so we need to catch and convert it.
                            $result .= "\\0";
                        } else {
                            # We could add a few other recognized things here,
                            # or just punt and pretend we saw nothing, or
                            # just leave the escape sequence in here and let
                            # the LPC thing deal with it.
                            #$result .= "\\u$unicode";
                        }
                        $unicode = '';
                        $is_unicode = 0;
                        $is_backslash = 0;

                        # This is, of course, the next character NOT part of the sequence.
                        $result .= $ch;
                    }
                } else {
                    if( $ch eq 'u' ) {
                        $is_unicode = 1;
                        $unicode = '';
                    } else {
                        $is_backslash = 0;
                        $result .= "\\$ch";
                    }
                }
            } else {

                if( $ch eq '\\' ) {
                    $is_backslash = 1;
                } elsif( $ch eq '"' ) {
                    $inside_quotes = 0;
                    $result .= $ch;
                } else {
                    $result .= $ch;
                }
            }
        } else {
            if( $ch eq '{' ) {
                $nested_mappings++;
                $result .= '([';
            } elsif( $ch eq '[' ) {
                $nested_arrays++;
                $result .= '({';
            } elsif( $ch eq '"' ) {
                $inside_quotes = 1;
                $result .= $ch;
            } elsif( $ch eq ']' ) {
                $nested_arrays--;
                $result .= '})';
            } elsif( $ch eq '}' ) {
                $nested_mappings--;
                $result .= '])';
            } else {
                $result .= $ch;
            }
        }
    }
    return $result;
}

sub lpc_to_json {
    my $thing = shift;

    return undef if !defined $thing;
    #JSON and LPC are very similar, in fact to convert from
    #one to the other, all we REALLY need to do (for purposes
    #of using mudmode sockets and LPC data types) is convert
    #{ pairs to ([ pairs, and [ pairs to ({ pairs, avoiding
    #anything inside double-quoted strings.

    my $result = "";
    my $nested_arrays = 0;
    my $nested_mappings = 0;
    my $inside_quotes = 0;
    my $is_backslash = 0;
    my $got_paren = 0;
    my $got_brace = 0;
    my $got_bracket = 0;

    foreach my $ch (split //, $thing) {
        if( $inside_quotes ) {
            if( $is_backslash ) {
                if( $ch eq '0' ) {
                    # JSON wants NUL bytes in unicode esaped form...
                    $is_backslash = 0;
                    $result .= "u0000";
                } else {

                    $is_backslash = 0;
                    $result .= $ch;
                }
            } else {
                if( $ch eq '\\' ) {
                    $is_backslash = 1;
                } elsif( $ch eq '"' ) {
                    $inside_quotes = 0;
                }
                $result .= $ch;
            }
        } elsif( $got_paren ) {
            if( $ch eq '{' ) {
                $nested_arrays++;
                $result .= '[';
            } elsif( $ch eq '[' ) {
                $nested_mappings++;
                $result .= '{';
            } else {
                $result .= $ch;
            }
            $got_paren = 0;
        } elsif( $got_bracket ) {
            if( $ch eq ')' ) {
                $nested_mappings--;
                $result .= '}';
            } else {
                $result .= $ch;
            }
            $got_bracket = 0;
        } elsif( $got_brace ) {
            if( $ch eq ')' ) {
                $nested_arrays--;
                $result .= ']';
            } else {
                $result .= $ch;
            }
            $got_brace = 0;
        } else {
            if( $ch eq '(' ) {
                $got_paren = 1;
            } elsif( $ch eq '"' ) {
                $inside_quotes = 1;
                $result .= $ch;
            } elsif( $ch eq ']' ) {
                $got_bracket = 1;
            } elsif( $ch eq '}' ) {
                $got_brace = 1;
            } else {
                $result .= $ch;
            }
        }
    }
    return $result;
}


# The specs for "mudmode" sockets are not really well documented, or

# rather... the documentation is not easy to find... but the basic idea
# is you take a valid LPC data structure and prepend a 4-byte length field
# (which I will *ASSUME* is in network byte order!), and then append a
# NUL byte.

# One presumes NUL bytes within the data structure have already
# been escaped, although it is unclear if any given LPC driver
# actually allows such things to exist anyways.

sub lpc_to_mudmode {
    my $thing = shift;

    return undef if !defined $thing;
    my $len = length $thing;
    my $result = pack('N', $len) . $thing . "\0";
    return $result;
}

sub mudmode_to_lpc {
    my $thing = shift;

    return undef if !defined $thing;
    my $expected_len = unpack('N', $thing);
    my $result = substr($thing, 4, -1);
    return $result;
}

# These are just wrappers to make going between socket data and
# perl hashes a one step conversion.

sub to_mudmode {
    my $thing = shift;

    return undef if !defined $thing;
    return lpc_to_mudmode(json_to_lpc(encode_json($thing)));
}

sub mudmode_to {
    my $thing = shift;

    return undef if !defined $thing;
    return decode_json(lpc_to_json(mudmode_to_lpc($thing)));
}

# Could probably use better test data...

my $test_obj = { "hello" => [ 23, -7, "b{\0oo\nfoo", { "blah" => 17.3 } ] };
my $json_serial = encode_json $test_obj;
my $json_obj = decode_json $json_serial;
my $lpc_convert = json_to_lpc($json_serial);
my $json_convert = lpc_to_json($lpc_convert);
my $stage_two = decode_json $json_convert;

my $mudmode = lpc_to_mudmode($lpc_convert);
my $mm_lpc = mudmode_to_lpc($mudmode);
my $stage_three = decode_json(lpc_to_json($mm_lpc));

my $round_trip = mudmode_to(to_mudmode($test_obj));

print "JSON Serialization:         $json_serial\n";
print "JSON Deserialization:       " . Dumper($json_obj) . "\n";
print "json_to_lpc:                $lpc_convert\n";
print "lpc_to_json:                $json_convert\n";
print "Stage 2 Deserialization:    " . Dumper($stage_two) . "\n";
print "Stage 3 Deserialization:    " . Dumper($stage_three) . "\n";
print "Round Trip Deserialization: " . Dumper($round_trip) . "\n";