File: myjsonrpc.pm

package info (click to toggle)
os-autoinst 4.5.1527308405.8b586d5-4.1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 22,688 kB
  • sloc: perl: 10,424; cpp: 1,527; python: 217; makefile: 211; sh: 71; xml: 11
file content (119 lines) | stat: -rw-r--r-- 3,515 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
# Copyright © 2012-2016 SUSE LLC
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, see <http://www.gnu.org/licenses/>.

package myjsonrpc;

use strict;
use warnings;
use Carp qw(cluck confess);
use bmwqemu ();
use Errno;

sub send_json {
    my ($to_fd, $cmd) = @_;

    # allow regular expressions to be automatically converted into
    # strings, using the Regex::TO_JSON function as defined at the end
    # of this file.
    my $JSON = JSON->new()->convert_blessed();
    # deep copy to add a random string
    my %cmdcopy = %$cmd;
    $cmdcopy{json_cmd_token} = bmwqemu::random_string(8);
    my $json = $JSON->encode(\%cmdcopy);

    #bmwqemu::diag("send_json $json");
    my $wb = syswrite($to_fd, "$json");
    confess "syswrite failed $!" unless ($wb && $wb == length($json));
    return $cmdcopy{json_cmd_token};
}

# hash for keeping state
our $sockets;

# utility function
sub read_json {
    my ($socket, $cmd_token) = @_;

    my $JSON = JSON->new();

    my $fd = fileno($socket);
    if (exists $sockets->{$fd}) {
        # start with the trailing text from previous call
        $JSON->incr_parse($sockets->{$fd});
        delete $sockets->{$fd};
    }

    my $s = IO::Select->new();
    $s->add($socket);

    my $hash;

    # the goal here is to find the end of the next valid JSON - and don't
    # add more data to it. As the backend sends things unasked, we might
    # run into the next message otherwise
    while (1) {
        $hash = $JSON->incr_parse();
        if ($hash) {
            # remember the trailing text
            $sockets->{$fd} = $JSON->incr_text();
            if ($hash->{QUIT}) {
                bmwqemu::diag("received magic close");
                return;
            }
            if ($cmd_token && ($hash->{json_cmd_token} || '') ne $cmd_token) {
                confess "ERROR: the token does not match - questions and answers not in the right order";
            }
            return $hash;
        }

        # wait for next read
        my @res = $s->can_read;
        unless (@res) {
            my $E = $!;    # save the error
            unless ($!{EINTR}) {    # EINTR if killed
                confess "ERROR: timeout reading JSON reply: $E\n";
            }
            else {
                die("can_read received kill signal");
            }
            close($socket);
            return;
        }

        my $qbuffer;
        my $bytes = sysread($socket, $qbuffer, 8000);
        #bmwqemu::diag("sysread $qbuffer");
        if (!$bytes) { bmwqemu::diag("sysread failed: $!"); return; }
        $JSON->incr_parse($qbuffer);
    }

    return $hash;
}

###################################################################
# enable send_json to send regular expressions
#<<< perltidy off
# this has to be on two lines so other tools don't believe this file
# exports package Regexp
package
Regexp;
#>>> perltidy on
sub TO_JSON {
    my $regex = shift;
    $regex = "$regex";
    return $regex;
}

1;