Difference between revisions of "Perl API examples"

testscan.pl

#!/usr/bin/perl -w
use strict;
use scan_database;


#Example of GetDBheader

print "\nGetDBheader\n";
my %header;
my $resp= GetDBheader(\%header, '192.168.1.67','VideoSourceList');
print "$resp entries returned\n";
for (sort keys %header){
    print "$_  $header{$_}\n";
}


#Example of GetDBinfo -  Note use of # to return a counter.
# If the extra param (StartIndex=2 &Count=10 in this case) is 
# null then all will be returned

print "\nGetDBinfo\n";
my %data;
$resp= GetDBinfo(\%data, '192.168.1.67', 'GetRecordedList', 
      'Startindex=2&Count=10',  'FileName','Title','FileSize','#');

#params are:  reference to hash, host, function, extra info to url call (if any),
#             primary key for hash data, secondary keys.

print "$resp entries returned\n";
print "FileName                  #  FileSize     Title\n";
for (sort keys %data){
    print "$_   $data{$_}{'#'}  $data{$_}{FileSize}   $data{$_}{Title}\n";
}

exit 0;

scan_database.pm

package scan_database;

use strict;
use Exporter;
use LWP::UserAgent;  # needs 'sudo apt-get install libwww-perl'

our $VERSION     = 1.00;
our @ISA         = qw(Exporter);
our @EXPORT      = qw(GetDBinfo GetDBheader);
our @EXPORT_OK   = qw($url_buffer);

my $url_buffer;
my $counter;
my $hostopened='';
my $browser;

#Extract data from database
#  Routine GetDBinfo
# params are:
#   reference to hash to fill
#   IP of host
#   Catagory required eg GetRecordedList
#   extra infor to go in call (if any).
#   required hash key
#   list of things to extract
#   eg :-
#   GetDBinfo(\%mydata, '192.168.1.67', 'GetRecordedList', '',
#    'FileName','Title', 'LastModified');
#  If key or extracted name is # then this is replaced by a counter.

#routine GetDBheader
# params are:
#   reference to hash to fill
#   IP of host
#   Catagory required eg GetRecordedList
#   extra info to go in call (if any).
#  eg GetDBheader(\%mydata, '192.168.1.67','getrecordedlist','');



my %steer = (
    getchannelinfolist  => ['Channel/GetChannelInfoList', 'ChannelInfo','ChannelInfos'],
    getrecordedlist     => ['Dvr/GetRecordedList?Descending=true', 'Program','Programs'],
    videosourcelist     => ['Channel/VideoSourceList', 'VideoSource','VideoSources'],
    #add more like this => [url, separator for getDBinfo, separator for getDBheader],  
);
#------------
sub GetDBheader{
    my ($hashref, $ip_addr, $class,$extra)=@_;
    $class=lc $class; 
    unless (defined ($steer{$class})) {die "Sorry - $class not supported"};
    $counter=0;
    #read from backend 
    &ReadBackend($ip_addr, $class, '');

    ($url_buffer)= split /<$steer{$class}[2]>/, $url_buffer;
    my @bits = split /></, $url_buffer.'<';
    foreach (@bits){
        if (m!</!){
            (my $key,$_)=split />/, $_;
            (my $value)=split /</,$_;
            #print "$key = $value\n";
            $$hashref{$key}=$value;
            $counter++;
        }
    }
    return $counter;
}
#-----------------------------
sub ReadBackend{
    my ($ip_addr, $class, $extra)=@_;
    unless ($hostopened eq $ip_addr){
        $browser = LWP::UserAgent->new;
        $browser->timeout(10);
        $hostopened = $ip_addr;
    }
    
    my $command="http://$ip_addr:6544/$steer{$class}[0]";
    if ($extra){
        if ($command =~ /\?/){
            $command .= '&' . $extra;
        }else{
            $command .= '?' . $extra;
        }
    }

    my $response = $browser->get($command);
    unless($response->is_success){ 
        die 'Cannot connect to backend. Bad address?  Not running?'};
    $url_buffer = $response -> content;
}

#---------------------------
sub GetDBinfo{

my ($hashref, $ip_addr, $class, $extra, $key_name, @params)=@_;

    $class=lc $class; 
    unless (defined ($steer{$class})) {die "Sorry - $class not supported"};
 
    #read from backend 
    &ReadBackend($ip_addr, $class, $extra);
    
    $counter=0;
    my $base=index($url_buffer, "<$steer{$class}[1]>");
    while ($base>-1){
        &ProcessRecording($hashref, $base, $key_name, @params);
        $base=index($url_buffer, "<$steer{$class}[1]>", $base+10);
        $counter++;
    }
    return $counter;
}
#---------------
sub ProcessRecording{
    #strip interesting data from record
    my ($hashref, $start_at, $key_name, @params) = @_;

    my $index=$counter;
    if ($key_name ne '#'){ $index=&getparameter($key_name,$start_at)};

    foreach (@params){
        if (/^#$/){
            $$hashref{$index}{$_}=$counter;
        }else{
            $$hashref{$index}{$_}=&getparameter($_, $start_at);
        }
    }
}
#-------------------------
sub getparameter{

my ($param, $base) = @_;

        my $start= index($url_buffer, "<$param>",$base);
        if ($start<0){die "cannot find $param in record"};

        $start=$start + length($param) +2;
        
        my $end=index($url_buffer, "</$param>", $start);
        
        my $data=substr $url_buffer, $start, $end-$start;
        $data =~ s/&/&/g; 
        $data;
}
1;

expire.pl

#!/usr/bin/perl -w 
use strict; 
use warnings FATAL => 'uninitialized'; 
use LWP::UserAgent; 

my $StartTS = '2012-01-18T21:26:00Z';	#extracted from GetRecordedList parameter <StartTS> 
my $ChanId = '1002';				# ditto but <ChanId> 

#open the browser 
my $browser = LWP::UserAgent->new; 
$browser->timeout(10); 

#issue post 
my $response = $browser -> post( 
	'http://192.168.1.67:6544/Dvr/RemoveRecorded', 
	[ 
	'StartTime' => $StartTS,          #NB StartTS not StartTime 
	'ChanId'	=> $ChanId, 
	], 
     ); 

unless($response->is_success){die "Error expiring recording"}; 
my $url_buffer = $response -> content; 
unless ($url_buffer =~ /<bool>true/) {print "Bad response expiring\n"}; 
exit 0;