File Coverage

blib/lib/Mojo/OBS/Client.pm
Criterion Covered Total %
statement 32 115 27.8
branch 0 18 0.0
condition n/a
subroutine 11 23 47.8
pod 1 6 16.6
total 44 162 27.1


line stmt bran cond sub pod time code
1             package Mojo::OBS::Client;
2 1     1   560 use 5.012;
  1         3  
3 1     1   396 use Moo;
  1         9408  
  1         4  
4 1     1   1699 use Mojo::UserAgent;
  1         352748  
  1         9  
5 1     1   43 use Encode qw( encode decode );
  1         2  
  1         47  
6 1     1   6 use Mojo::JSON 'decode_json', 'encode_json';
  1         2  
  1         36  
7 1     1   498 use Net::Protocol::OBSRemote;
  1         33043  
  1         31  
8 1     1   394 use Future::Mojo;
  1         12577  
  1         39  
9              
10             our $VERSION = '0.03';
11              
12 1     1   8 use Filter::signatures;
  1         2  
  1         7  
13 1     1   24 use feature 'signatures';
  1         2  
  1         92  
14 1     1   7 no warnings 'experimental::signatures';
  1         13  
  1         49  
15             with 'Moo::Role::RequestReplyHandler';
16              
17 1     1   5 use Carp 'croak';
  1         2  
  1         992  
18              
19             =head1 NAME
20              
21             Mojo::OBS::Client - Mojolicious client for the OBS WebSocket remote plugin
22              
23             =head1 SYNOPSIS
24              
25             use feature 'signatures';
26              
27             my $obs = Mojo::OBS::Client->new;
28             $obs->login('ws://localhost:4444', 'secret')->then(sub {
29             $obs->SetTextFreetype2Properties( source => 'Text.NextTalk',text => 'Hello World')
30             })->then(sub {
31             $obs->GetSourceSettings( sourceName => 'VLC.Vortrag', sourceType => 'vlc_source')
32             });
33              
34             =cut
35              
36             =head1 ACCESSORS
37              
38             =head2 C<< ->ioloop >>
39              
40             Access the underlying L
41              
42             =cut
43              
44             has ioloop => (
45             is => 'ro',
46             default => sub {
47             return Mojo::IOLoop->new();
48             },
49             );
50              
51             =head2 C<< ->ua >>
52              
53             Access the L object used to talk to OBS.
54              
55             =cut
56              
57             has ua => (
58             is => 'ro',
59             default => sub {
60             return Mojo::UserAgent->new();
61             },
62             );
63              
64             =head2 C<< ->tx >>
65              
66             The websocket connection to OBS.
67              
68             =cut
69              
70             has tx => (
71             is => 'rw',
72             );
73              
74             =head2 C<< ->protocol >>
75              
76             The L instance used to generate the OBS messages.
77              
78             =cut
79              
80             has protocol => (
81             is => 'ro',
82             default => sub {
83             return Net::Protocol::OBSRemote->new();
84             },
85             );
86              
87             =head2 C<< ->debug >>
88              
89             Switch on debug messages to STDERR. Also enabled if
90             C<< $ENV{PERL_MOJO_OBS_CLIENT_DEBUG} >> is set to a true value.
91              
92             =cut
93              
94             has debug => (
95             is => 'ro',
96             default => sub {
97             return !!$ENV{PERL_MOJO_OBS_CLIENT_DEBUG};
98             },
99             );
100              
101             =head1 METHODS
102              
103             =cut
104              
105 0     0 0   sub future($self, $loop=$self->ioloop) {
  0            
  0            
  0            
106 0           Future::Mojo->new( $loop )
107             }
108              
109 0     0 0   sub get_reply_key($self,$msg) {
  0            
  0            
  0            
110 0           $msg->{'message-id'}
111             };
112              
113 0     0 0   sub connect($self,$ws_url) {
  0            
  0            
  0            
114 0           my $res = $self->future();
115              
116 0           $self->ua->websocket(
117             $ws_url,
118             => { 'Sec-WebSocket-Extensions' => 'permessage-deflate' }
119             => []
120 0     0     => sub($dummy, $_tx) {
  0            
  0            
121 0           my $tx = $_tx;
122 0           $self->tx( $tx );
123 0 0         if( ! $tx->is_websocket ) {
124 0           say 'WebSocket handshake failed!';
125 0           $res->fail('WebSocket handshake failed!');
126 0           return;
127             };
128              
129             $tx->on(finish => sub {
130 0           my ($tx, $code, $reason) = @_;
131             #if( $s->_status ne 'shutdown' ) {
132             # say "WebSocket closed with status $code.";
133             #};
134 0           });
135              
136 0           $tx->on(message => sub($tx,$msg) {
137             # At least from Windows, OBS sends Latin-1 in JSON
138 0           my $payload = decode_json(encode('UTF-8',decode('Latin-1', $msg)));
139              
140 0 0         if( my $type = $payload->{"update-type"}) {
    0          
141 0 0         if( $self->debug ) {
142 0           require Data::Dumper;
143 0           say "*** " . Data::Dumper::Dumper( $msg );
144             };
145 0           $self->event_received( $type, $payload );
146             } elsif( my $id = $self->get_reply_key( $payload )) {
147 0 0         if( $self->debug ) {
148 0           require Data::Dumper;
149 0           say "<== " . Data::Dumper::Dumper( $msg );
150             };
151 0           $self->message_received($payload);
152             };
153 0           });
154              
155 0           $res->done();
156             },
157 0           );
158 0           return $res;
159             }
160              
161 0     0 0   sub shutdown( $self ) {
  0            
  0            
162 0           $self->tx->finish;
163             }
164              
165 0     0 0   sub send_message($self, $msg) {
  0            
  0            
  0            
166 0           my $res = $self->future();
167              
168 0 0         if( $self->debug ) {
169 0           require Data::Dumper;
170 0           say "==> " . Data::Dumper::Dumper( $msg );
171             };
172 0           my $id = $msg->{'message-id'};
173 0     0     $self->on_message( $id, sub($response) {
  0            
  0            
174 0           $res->done($response);
175 0           });
176 0           $self->tx->send( encode_json( $msg ));
177 0           return $res
178             };
179              
180             =head1 METHODS
181              
182             For the OBS methods, see L.
183              
184             =cut
185              
186             # We delegate all unknown methods to $self->protocol
187 0     0     sub AUTOLOAD( $self, @args ) {
  0            
  0            
  0            
188 0 0         our $AUTOLOAD =~ /::(\w+)$/
189             or croak "Weird AUTOLOAD method '$AUTOLOAD'";
190 0 0         return if $1 eq 'DESTROY';
191 0 0         my $method = $self->protocol->can("$1")
192             or croak "Unknown OBS method '$1'";
193              
194 0           my $payload = $method->($self->protocol, @args);
195 0           return $self->send_message( $payload );
196             }
197              
198             =head2 C<< ->login $url, $password >>
199              
200             $obs->login('ws://localhost:4444', 'secret')
201             ->then(sub( $res ){
202             if( $res->{error} ) {
203             warn $res->{error};
204             return
205             };
206             })
207              
208             Performs the login authentication with the OBS websocket
209              
210             =cut
211              
212 0     0 1   sub login( $h, $url, $password ) {
  0            
  0            
  0            
  0            
213             return $h->connect($url)->then(sub {
214 0     0     $h->GetVersion();
215             })->then(sub {
216 0     0     $h->GetAuthRequired();
217 0     0     })->then(sub( $challenge ) {
  0            
  0            
218 0           $h->Authenticate($password,$challenge);
219 0           });
220             };
221              
222             1;
223              
224             =head1 REPOSITORY
225              
226             The public repository of this module is
227             L.
228              
229             =head1 SUPPORT
230              
231             The public support forum of this module is L.
232              
233             =head1 BUG TRACKER
234              
235             Please report bugs in this module via the Github bug queue at
236             L
237              
238             =head1 AUTHOR
239              
240             Max Maischein C
241              
242             =head1 COPYRIGHT (c)
243              
244             Copyright 2021-2023 by Max Maischein C.
245              
246             =head1 LICENSE
247              
248             This module is released under the same terms as Perl itself.
249              
250             =cut