File Coverage

blib/lib/Linux/DVB.pm
Criterion Covered Total %
statement 17 67 25.3
branch 0 14 0.0
condition n/a
subroutine 3 24 12.5
pod 0 4 0.0
total 20 109 18.3


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Linux::DVB - interface to (some parts of) the Linux DVB API
4              
5             =head1 SYNOPSIS
6              
7             use Linux::DVB;
8              
9             =head1 DESCRIPTION
10              
11             This module provides an interface to the Linux DVB API. It is a straightforward
12             translation of the C API. You should read the Linux DVB API description to make
13             any sense of this module. It can be found here:
14              
15             http://www.linuxtv.org/docs/dvbapi/dvbapi.html
16              
17             All constants from F and F are exported by their C
18             name and by default.
19              
20             Noteworthy differences to the C API: unions and sub-structs are usually
21             translated into flat perl hashes, i.e C
22             becomes C<< $struct->{symbol_rate} >>.
23              
24             Noteworthy limitations of this module include: No interface to the video,
25             audio and net devices. If you need this functionality bug the author.
26              
27             =cut
28              
29             package Linux::DVB;
30              
31 1     1   8954 use Fcntl ();
  1         3  
  1         156  
32              
33             BEGIN {
34 1     1   3 $VERSION = '1.01';
35 1         18 @ISA = qw(Exporter);
36              
37 1         6 require XSLoader;
38 1         698 XSLoader::load __PACKAGE__, $VERSION;
39              
40 1         20 require Exporter;
41              
42 1         223 my %consts = &_consts;
43 1         17 my $consts;
44 1         10 while (my ($k, $v) = each %consts) {
45 157         168 push @EXPORT, $k;
46 157         487 $consts .= "sub $k(){$v}\n";
47             }
48 1         2929 eval $consts;
49             }
50              
51             sub new {
52 0     0 0   my ($class, $path, $mode) = @_;
53              
54 0           my $self = bless { path => $path, mode => $mode }, $class;
55 0 0         sysopen $self->{fh}, $path, $mode | &Fcntl::O_NONBLOCK
56             or die "$path: $!";
57 0           $self->{fd} = fileno $self->{fh};
58              
59 0           $self;
60             }
61              
62 0     0 0   sub fh { $_[0]{fh} }
63 0     0 0   sub fd { $_[0]{fd} }
64              
65             sub blocking {
66 0 0   0 0   fcntl $_[0]{fh}, &Fcntl::F_SETFL, $_[1] ? 0 : &Fcntl::O_NONBLOCK;
67             }
68              
69             package Linux::DVB::Frontend;
70              
71             @ISA = qw(Linux::DVB);
72              
73             =head1 Linux::DVB::Frontend CLASS
74              
75             =head2 SYNOPSIS
76              
77             my $fe = new Linux::DVB::Frontend $path, $writable;
78              
79             my $fe = new Linux::DVB::Frontend
80             "/dev/dvb/adapter0/frontend0", 1;
81              
82             $fe->fh; # filehandle
83             $fe->fd; # fileno
84             $fe->blocking (0); # or 1
85              
86             $fe->{name}
87             $fe->{type}
88             $fe->frontend_info->{name}
89              
90             $fe->status & FE_HAS_LOCK
91             print $fe->ber, $fe->snr, $fe->signal_strength, $fe->uncorrected;
92              
93             my $tune = $fe->parameters;
94             $tune->{frequency};
95             $tune->{symbol_rate};
96              
97             =over 4
98              
99             =cut
100              
101             sub new {
102 0     0     my ($class, $path, $mode) = @_;
103 0 0         my $self = $class->SUPER::new ($path, $mode ? &Fcntl::O_RDWR : &Fcntl::O_RDONLY);
104              
105 0           %$self = ( %$self, %{ $self->frontend_info } );
  0            
106            
107 0           $self;
108             }
109              
110             =item $fe->set (parameter => value, ...)
111              
112             Sets frontend parameters. All values are stuffed into the
113             C structure without conversion and passed to
114             FE_SET_FRONTEND.
115              
116             Returns true on success.
117              
118             All modes:
119              
120             frequency =>
121             inversion =>
122              
123             QPSK frontends:
124              
125             symbol_rate =>
126             fec_inner =>
127              
128             QAM frontends:
129              
130             symbol_rate =>
131             modulation =>
132              
133             QFDM frontends:
134              
135             bandwidth =>
136             code_rate_HP =>
137             code_rate_LP =>
138             constellation =>
139             transmission_mode =>
140              
141             =cut
142              
143             sub set {
144 0     0     my ($self) = shift;
145 0           _set $self->{fd}, { @_ }, $self->{type}
146             }
147              
148             =item $fe->parameters
149              
150             Calls FE_GET_FRONTEND and returns a hash reference that contains the same keys
151             as given to the C method.
152              
153             Example:
154              
155             Data::Dumper::Dumper $fe->get
156            
157             {
158             frequency => 426000000, # 426 Mhz
159             inversion => 0, # INVERSION_OFF
160             symbol_rate => 6900000, # 6.9 MB/s
161             modulation => 3, # QAM_64
162             }
163              
164             =cut
165              
166 0     0     sub parameters { _get ($_[0]{fd}, $_[0]{type}) }
167 0     0     sub get { _get ($_[0]{fd}, $_[0]{type}) } # unannounced alias
168 0     0     sub event { _event ($_[0]{fd}, $_[0]{type}) }
169              
170             =item $ok = $fe->diseqc_reset_overload
171              
172             If the bus has been automatically powered off due to power overload, this
173             call restores the power to the bus. The call requires read/write access
174             to the device. This call has no effect if the device is manually powered
175             off. Not all DVB adapters support this call.
176              
177             =item $ok = $fe->diseqc_voltage (13|18)
178              
179             Set the DiSEqC voltage to either 13 or 18 volts.
180              
181             =item $ok = $fe->diseqc_tone (1|0)
182              
183             Enables (1) or disables (0) the DiSEqC continuous 22khz tone generation.
184              
185             =item $ok = $fe->diseqc_send_burst (0|1)
186              
187             Sends a 22KHz tone burst of type SEC_MINI_A (0) or SEC_MINI_B (1).
188              
189             =item $ok = $fe->diseqc_cmd ($command)
190              
191             Sends a DiSEqC command ($command is 3 to 6 bytes of binary data).
192              
193             =item $reply = $fe->diseqc_reply ($timeout)
194              
195             Receives a reply to a DiSEqC 2.0 command and returns it as a binary octet
196             string 0..4 bytes in length (or C in the error case).
197              
198             =cut
199              
200             package Linux::DVB::Demux;
201              
202             @ISA = qw(Linux::DVB);
203              
204             =back
205              
206             =head1 Linux::DVB::Demux CLASS
207              
208             =head2 SYNOPSIS
209              
210             my $dmx = new Linux::DVB::Demux
211             "/dev/dvb/adapter0/demux0";
212              
213             $fe->fh; # filehandle
214             $fe->fd; # fileno
215             $fe->blocking (1); # non-blocking is default
216              
217             $dmx->buffer (16384);
218             $dmx->sct_filter ($pid, "filter", "mask", $timeout=0, $flags=DMX_CHECK_CRC);
219             $dmx->pes_filter ($pid, $input, $output, $type, $flags=0);
220             $dmx->start;
221             $dmx->stop;
222              
223             =over 4
224              
225             =cut
226              
227             sub new {
228 0     0     my ($class, $path) = @_;
229 0           my $self = $class->SUPER::new ($path, &Fcntl::O_RDWR);
230            
231 0           $self;
232             }
233              
234 0     0     sub start { _start ($_[0]{fd}) }
235 0     0     sub stop { _stop ($_[0]{fd}) }
236              
237 0     0     sub sct_filter { _filter ($_[0]{fd}, @_[1, 2, 3, 4, 5]) }
238 0     0     sub pes_filter { _pes_filter ($_[0]{fd}, @_[1, 2, 3, 4, 5]) }
239 0     0     sub buffer { _buffer ($_[0]{fd}, $_[1]) }
240              
241             package Linux::DVB::Decode;
242              
243             =back
244              
245             =head1 Linux::DVB::Decode CLASS
246              
247             =head2 SYNOPSIS
248              
249             $si_decoded_hashref = Linux::DVB::Decode::si $section_data;
250              
251             =over 4
252              
253             =cut
254              
255             =item $hashref = Linux::DVB::Decode::si $section_data
256              
257             Tries to parse the string inside C<$section_data> as an SI table and
258             return it as a hash reference. Only the first SI table will be returned
259             as hash reference, and the C<$section_data> will be modified in-place by
260             removing the table data.
261              
262             The way to use this function is to append new data to your
263             C<$section_data> and then call C in a loop until
264             it returns C. Please ntoe, however, that the Linux DVB API will
265             return only one table at a time from sysread, so you can safely assume
266             that every sysread will return exactly one (or zero in case of errors) SI
267             table.
268              
269             Here is an example of what to expect:
270              
271             {
272             'segment_last_section_number' => 112,
273             'table_id' => 81,
274             'service_id' => 28129,
275             'original_network_id' => 1,
276             'section_syntax_indicator' => 1,
277             'current_next_indicator' => 1,
278             'events' => [
279             {
280             'running_status' => 0,
281             'start_time_hms' => 2097152,
282             'event_id' => 39505,
283             'free_CA_mode' => 0,
284             'start_time_mjd' => 53470,
285             'descriptors' => [
286             {
287             'event_name' => 'Nachrichten',
288             'text' => '',
289             'ISO_639_language_code' => 'deu',
290             'type' => 77
291             },
292             {
293             'programme_identification_label' => 337280,
294             'type' => 105
295             },
296             {
297             'raw_data' => '22:0010.04#00',
298             'type' => 130
299             }
300             ],
301             'duration' => 1280
302             },
303             {
304             'running_status' => 0,
305             'start_time_hms' => 2098432,
306             'event_id' => 39506,
307             'free_CA_mode' => 0,
308             'start_time_mjd' => 53470,
309             'descriptors' => [
310             {
311             'event_name' => 'SR 1 - Nachtwerk',
312             'text' => '',
313             'ISO_639_language_code' => 'deu',
314             'type' => 77
315             },
316             {
317             'programme_identification_label' => 337285,
318             'type' => 105
319             },
320             {
321             'raw_data' => '22:0510.04#00',
322             'type' => 130
323             }
324             ],
325             'duration' => 87296
326             }
327             ],
328             'last_table_id' => 81,
329             'section_number' => 112,
330             'last_section_number' => 176,
331             'version_number' => 31,
332             'transport_stream_id' => 1101
333             }
334              
335              
336             =item $text = Linux::DVB::Decode::text $data
337              
338             Converts text found in DVB si tables into perl text. Only iso-8859-1..-11
339             and UTF-16 is supported, other encodings (big5 etc. is not. Bug me if you
340             need this).
341              
342             =cut
343              
344             sub text($) {
345 1     1   1114 use Encode;
  1         13901  
  1         874  
346              
347 0     0     for ($_[0]) {
348 0 0         s/^([\x01-\x0b])// and $_ = decode sprintf ("iso-8859-%d", 4 + ord $1), $_;
349             # 10 - pardon you???
350 0 0         s/^\x11// and $_ = decode "utf16-be", $_;
351             # 12 ksc5601, DB
352             # 13 db2312, DB
353             # 14 big5(?), DB
354 0           s/\x8a/\n/g;
355             #s/([\x00-\x09\x0b-\x1f\x80-\x9f])/sprintf "{%02x}", ord $1/ge;
356 0           s/([\x00-\x09\x0b-\x1f\x80-\x9f])//ge;
357             }
358             }
359              
360             =item %Linux::DVB::Decode::nibble_to_genre
361              
362             A two-level hash mapping genre nibbles to genres, e.g.
363              
364             $Linux::DVB::Decode::nibble_to_genre{7}{6}
365             => 'film/cinema'
366              
367             =cut
368              
369             our %nibble_to_genre = (
370             0x1 => {
371             0x0 => 'Movie/Drama (general)',
372             0x1 => 'Movie - detective/thriller',
373             0x2 => 'Movie - adventure/western/war',
374             0x3 => 'Movie - science fiction/fantasy/horror',
375             0x4 => 'Movie - comedy',
376             0x5 => 'Movie - soap/melodrama/folkloric',
377             0x6 => 'Movie - romance',
378             0x7 => 'Movie - serious/classical/religious/historical movie/drama',
379             0x8 => 'Movie - adult movie/drama',
380             },
381             0x2 => {
382             0x0 => 'News/Current Affairs (general)',
383             0x1 => 'news/weather report',
384             0x2 => 'news magazine',
385             0x3 => 'documentary',
386             0x4 => 'discussion/interview/debate',
387             },
388             0x3 => {
389             0x0 => 'Show/Game Show (general)',
390             0x1 => 'game show/quiz/contest',
391             0x2 => 'variety show',
392             0x3 => 'talk show',
393             },
394             0x4 => {
395             0x0 => 'Sports (general)',
396             0x1 => 'special events (Olympic Games, World Cup etc.)',
397             0x2 => 'sports magazines',
398             0x3 => 'football/soccer',
399             0x4 => 'tennis/squash',
400             0x5 => 'team sports (excluding football)',
401             0x6 => 'athletics',
402             0x7 => 'motor sport',
403             0x8 => 'water sport',
404             0x9 => 'winter sports',
405             0xA => 'equestrian',
406             0xB => 'martial sports',
407             },
408             0x5 => {
409             0x0 => 'Childrens/Youth (general)',
410             0x1 => "pre-school children's programmes",
411             0x2 => 'entertainment programmes for 6 to 14',
412             0x3 => 'entertainment programmes for 10 to 16',
413             0x4 => 'informational/educational/school programmes',
414             0x5 => 'cartoons/puppets',
415             },
416             0x6 => {
417             0x0 => 'Music/Ballet/Dance (general)',
418             0x1 => 'rock/pop',
419             0x2 => 'serious music or classical music',
420             0x3 => 'folk/traditional music',
421             0x4 => 'jazz',
422             0x5 => 'musical/opera',
423             0x6 => 'ballet',
424             },
425             0x7 => {
426             0x0 => 'Arts/Culture (without music, general)',
427             0x1 => 'performing arts',
428             0x2 => 'fine arts',
429             0x3 => 'religion',
430             0x4 => 'popular culture/traditional arts',
431             0x5 => 'literature',
432             0x6 => 'film/cinema',
433             0x7 => 'experimental film/video',
434             0x8 => 'broadcasting/press',
435             0x9 => 'new media',
436             0xA => 'arts/culture magazines',
437             0xB => 'fashion',
438             },
439             0x8 => {
440             0x0 => 'Social/Policical/Economics (general)',
441             0x1 => 'magazines/reports/documentary',
442             0x2 => 'economics/social advisory',
443             0x3 => 'remarkable people',
444             },
445             0x9 => {
446             0x0 => 'Education/Science/Factual (general)',
447             0x1 => 'nature/animals/environment',
448             0x2 => 'technology/natural sciences',
449             0x3 => 'medicine/physiology/psychology',
450             0x4 => 'foreign countries/expeditions',
451             0x5 => 'social/spiritual sciences',
452             0x6 => 'further education',
453             0x7 => 'languages',
454             },
455             0xA => {
456             0x0 => 'Leisure/Hobbies (general)',
457             0x1 => 'tourism/travel',
458             0x2 => 'handicraft',
459             0x3 => 'motoring',
460             0x4 => 'fitness & health',
461             0x5 => 'cooking',
462             0x6 => 'advertizement/shopping',
463             0x7 => 'gardening',
464             },
465             0xB => {
466             0x0 => '(original language)',
467             0x1 => '(black & white)',
468             0x2 => '(unpublished)',
469             0x3 => '(live broadcast)',
470             },
471             );
472              
473             =item ($sec,$min,$hour) = Linux::DVB::Decode::time $hms
474              
475             =item ($mday,$mon,$year) = Linux::DVB::Decode::date $mjd
476              
477             =item ($sec,$min,$hour,$mday,$mon,$year) = Linux::DVB::Decode::datetime $mjd, $hms
478              
479             =item $sec = Linux::DVB::Decode::time_linear $hms
480              
481             =item $sec = Linux::DVB::Decode::datetime_linear $mjd, $hms
482              
483             Break down a "DVB time" (modified julian date + bcd encoded seconds) into
484             it's components (non-C<_linear>) or into a seconds count (C<_linear>
485             variants) since the epoch (C) or the start of the day
486             (C).
487              
488             The format of the returns value of the date and datetime functions is
489             I compatible with C. Use the C<_linear> functions
490             instead.
491              
492             Example:
493              
494             my $time = Linux::DVB::Decode::datetime_linear $mjd, $hms
495             printf "Starts at %s\n",
496             POSIX::strftime "%Y-%m-%d %H:%M:%S",
497             localtime $time;
498              
499             =cut
500              
501             sub time($) {
502 0     0     my ($time) = @_;
503              
504             # Time is in UTC, 24 bit, every nibble one digit in BCD from right to left
505 0           my $hour = sprintf "%02x", ($time >> 16) & 0xFF;
506 0           my $minute = sprintf "%02x", ($time >> 8) & 0xFF;
507 0           my $second = sprintf "%02x", ($time ) & 0xFF;
508              
509 0           ($second, $minute, $hour)
510             }
511              
512             sub date($) {
513 0     0     my ($mjd) = @_;
514              
515             # Date is given in Modified Julian Date
516             # Decoding routines taken from ANNEX C, ETSI EN 300 468 (DVB SI)
517 0           my $y_ = int (($mjd - 15078.2) / 365.25);
518 0           my $m_ = int (($mjd - 14956.1 - int ($y_ * 365.25)) / 30.6001);
519 0           my $day = $mjd - 14956 - int ($y_ * 365.25) - int ($m_ * 30.6001);
520 0 0         my $k = $m_ == 14 or $m_ == 15 ? 1 : 0;
    0          
521 0           my $year = $y_ + $k + 1900;
522 0           my $month = $m_ - 1 - $k * 12;
523              
524 0           ($day, $month, $year)
525             }
526              
527             sub datetime($$) {
528 0     0     (Linux::DVB::Decode::time $_[1], date $_[0])
529             }
530              
531             sub time_linear($) {
532 0     0     my ($s, $m, $h) = Linux::DVB::Decode::time $_[0];
533              
534 0           (($h * 60) + $m * 60) + $s
535             }
536              
537             sub datetime_linear($$) {
538 0     0     my ($sec, $min, $hour, $mday, $mon, $year) =
539             Linux::DVB::Decode::datetime $_[0], $_[1];
540              
541 0           require Time::Local;
542 0           Time::Local::timegm ($sec, $min, $hour, $mday, $mon - 1, $year)
543             }
544              
545             =back
546              
547             =head1 AUTHORS
548              
549             Marc Lehmann , http://home.schmorp.de/
550             Magnus Schmidt, eMail at http://www.27b-6.de/email.php
551              
552             =cut
553              
554             1