File Coverage

myjsonrpc.pm
Criterion Covered Total %
statement 87 89 96.6
total 87 89 96.6


line stmt code
1   # Copyright 2012-2021 SUSE LLC
2   # SPDX-License-Identifier: GPL-2.0-or-later
3    
4    
5   use Mojo::Base -strict, -signatures;
6 63 use Carp qw(cluck confess);
  63  
  63  
7 63 use IO::Select;
  63  
  63  
8 63 use Errno;
  63  
  63  
9 63 use Mojo::JSON; # booleans
  63  
  63  
10 63 use Cpanel::JSON::XS ();
  63  
  63  
11 63 use bmwqemu ();
  63  
  63  
12 63  
  63  
  63  
13   use constant DEBUG_JSON => $ENV{PERL_MYJSONRPC_DEBUG} || 0;
14 63 use constant READ_BUFFER => $ENV{PERL_MYJSONRPC_BYTES} || 8000000;
  63  
  63  
15 63  
  63  
  63  
16   # allow regular expressions to be automatically converted into
17 682 # strings, using the Regex::TO_JSON function as defined at the end
  682  
  682  
  682  
18   # of this file.
19   # The resulting JSON should be in a single line, otherwise
20   # read_json won't work
21   my $cjx = Cpanel::JSON::XS->new->canonical->utf8->convert_blessed();
22    
23 682 # deep copy to add a random string
24   my %cmdcopy = %$cmd;
25   # The hash might already contain a json_cmd_token
26 682 $cmdcopy{json_cmd_token} ||= bmwqemu::random_string(8);
27    
28 682 my $json = $cjx->encode(\%cmdcopy);
29   if (DEBUG_JSON) {
30 682 my $copy = $json;
31 682 # shorten long content
32   $copy =~ s/"([^"]{30})[^"]+"/"$1"/g;
33   my $fd = fileno($to_fd);
34   bmwqemu::diag("($$) send_json($fd) JSON=$copy");
35   }
36   $json .= "\n";
37    
38 682 confess 'myjsonprc: called on undefined file descriptor' unless defined $to_fd;
39   my $wb = syswrite($to_fd, "$json");
40 682 if (!$wb || $wb != length($json)) {
41 682 die('myjsonrpc: remote end terminated connection, stopping') if !DEBUG_JSON && $! =~ qr/Broken pipe/;
42 682 confess "syswrite failed: $!";
43 1 }
44 1 return $cmdcopy{json_cmd_token};
45   }
46 681  
47   # hash for keeping state
48   our $sockets;
49    
50   # utility function
51   my $cjx = Cpanel::JSON::XS->new;
52    
53 717 my $fd = fileno($socket);
  716  
  716  
  717  
  716  
54 716 bmwqemu::diag("($$) read_json($fd)") if DEBUG_JSON;
55   if (exists $sockets->{$fd}) {
56 716 # start with the trailing text from previous call
57 716 my $buffer = delete $sockets->{$fd};
58 716 $cjx->incr_parse($buffer);
59   }
60 687  
61 687 my $s = IO::Select->new();
62   $s->add($socket);
63    
64 716 my @results;
65 716  
66   # the goal here is to find the end of the next valid JSON - and don't
67 716 # add more data to it. As the backend sends things unasked, we might
68   # run into the next message otherwise
69   while (1) {
70   my $hash = $cjx->incr_parse();
71   # remember the trailing text
72 716 if ($hash) {
73 2832 $sockets->{$fd} = $cjx->incr_text();
74   if (DEBUG_JSON) {
75 2832 my $token = $hash->{json_cmd_token} // 'no-token';
76 716 bmwqemu::diag("($$) read_json($fd) json_cmd_token=$token");
77 716 }
78   if ($hash->{QUIT}) {
79   bmwqemu::diag("received magic close");
80   push @results, undef;
81 716 last;
82 7 }
83 7 confess "ERROR: the token does not match - questions and answers not in the right order" if $cmd_token && ($hash->{json_cmd_token} || '') ne $cmd_token; # uncoverable statement
84 6 push @results, $hash;
85   # parse all lines from buffer
86 709 next if $multi;
87 709 last;
88   }
89 710 elsif ($multi and @results) {
90 575 # read at least one item in list context
91   last;
92   }
93    
94 135 # wait for next read
95   my @res = $s->can_read;
96   while (!@res) {
97   # throw an error except can_read has been interrupted
98 1982 my $error = $!;
99 1981 confess "ERROR: unable to wait for JSON reply: $error\n" unless $!{EINTR};
100   # try again if can_read's underlying system call has been interrupted as suggested by the perlipc documentation
101 2 bmwqemu::diag("($$) read_json($fd): can_read's underlying system call has been interrupted, trying again\n") if DEBUG_JSON;
102 2 @res = $s->can_read;
103   }
104 0  
105 0 my $qbuffer;
106   my $bytes = sysread($socket, $qbuffer, READ_BUFFER);
107   if (!$bytes) {
108 1980 bmwqemu::fctwarn("sysread failed: $!") if DEBUG_JSON;
109 1980 return;
110 1981 }
111 1 $cjx->incr_parse($qbuffer);
112 1 }
113    
114 1980 return $multi ? @results : $results[0];
115   }
116    
117 714 ###################################################################
118   # enable send_json to send regular expressions
119   #<<< perltidy off
120   # this has to be on two lines so other tools don't believe this file
121   # exports package Regexp
122   package
123   Regexp;
124   #>>> perltidy on
125   $regex = "$regex";
126   return $regex;
127   }
128 4  
  4  
  3  
129 3 1;