diff options
| author | Andreas Brachold <vdr07@deltab.de> | 2007-08-13 18:41:27 +0000 |
|---|---|---|
| committer | Andreas Brachold <vdr07@deltab.de> | 2007-08-13 18:41:27 +0000 |
| commit | bcbf441e09fb502cf64924ff2530fa144bdf52c5 (patch) | |
| tree | f377707a2dac078db8cd0c7d7abfe69ac1006d71 /lib/XXV | |
| download | xxv-bcbf441e09fb502cf64924ff2530fa144bdf52c5.tar.gz xxv-bcbf441e09fb502cf64924ff2530fa144bdf52c5.tar.bz2 | |
* Move files to trunk
Diffstat (limited to 'lib/XXV')
36 files changed, 20944 insertions, 0 deletions
diff --git a/lib/XXV/MODULES/AUTOTIMER.pm b/lib/XXV/MODULES/AUTOTIMER.pm new file mode 100644 index 0000000..812da07 --- /dev/null +++ b/lib/XXV/MODULES/AUTOTIMER.pm @@ -0,0 +1,1359 @@ +package XXV::MODULES::AUTOTIMER;
+
+use strict;
+
+use Tools;
+use Locale::gettext;
+
+
+# ------------------
+# Name: module
+# Descr: The standard routine to describe the Plugin
+# Usage: my $modhash = $obj->module();
+# ------------------
+sub module {
+ my $obj = shift || return error ('No Object!' );
+ my $args = {
+ Name => 'AUTOTIMER',
+ Prereq => {
+ # 'Perl::Module' => 'Description',
+ },
+ Description => gettext('This module search for epg entries with an user defined text and create new timer.'),
+ Version => '0.91',
+ Date => '2007-01-11',
+ Author => 'xpix',
+ Status => sub{ $obj->status(@_) },
+ Preferences => {
+ active => {
+ description => gettext('Activate this service'),
+ default => 'y',
+ type => 'confirm',
+ required => gettext('This is required!'),
+ },
+ exclude => {
+ description => gettext('Exclude channel list for autotimer.'),
+ type => 'string',
+ default => 'POS > 50',
+ check => sub{
+ my $value = shift;
+ if(index($value, ',') != -1) {
+ return 'POS > 50'; # Nur um sicher zu sein, das die alten Werte nicht übernommen werden.
+ } else {
+ return $value;
+ }
+ },
+ },
+ },
+ Commands => {
+ astatus => {
+ description => gettext('Status from autotimers'),
+ short => 'as',
+ callback => sub{ $obj->status(@_) },
+ DenyClass => 'alist',
+ },
+ anew => {
+ description => gettext("Create a new autotimer"),
+ short => 'an',
+ callback => sub{ $obj->autotimerCreate(@_) },
+ Level => 'user',
+ DenyClass => 'aedit',
+ },
+ adelete => {
+ description => gettext("Delete a autotimer 'aid'"),
+ short => 'ad',
+ callback => sub{ $obj->autotimerDelete(@_) },
+ Level => 'user',
+ DenyClass => 'aedit',
+ },
+ aedit => {
+ description => gettext("Edit a autotimer 'aid'"),
+ short => 'ae',
+ callback => sub{ $obj->autotimerEdit(@_) },
+ Level => 'user',
+ DenyClass => 'aedit',
+ },
+ asearch => {
+ description => gettext("Search for autotimer with text 'aid'"),
+ short => 'ase',
+ callback => sub{ $obj->list(@_) },
+ DenyClass => 'alist',
+ },
+ alist => {
+ description => gettext("List the autotimer 'aid'"),
+ short => 'al',
+ callback => sub{ $obj->list(@_) },
+ DenyClass => 'alist',
+ },
+ aupdate => {
+ description => gettext("Start the autotimer process"),
+ short => 'au',
+ callback => sub{ $obj->autotimer(@_) },
+ Level => 'user',
+ DenyClass => 'aedit',
+ },
+ atoggle => {
+ description => gettext("Toggle autotimer on or off 'aid'"),
+ short => 'at',
+ callback => sub{ $obj->autotimerToggle(@_) },
+ Level => 'user',
+ DenyClass => 'aedit',
+ }, + asuggest => { + hidden => 'yes',
+ callback => sub{ $obj->suggest(@_) }, + DenyClass => 'alist', + },
+ },
+ RegEvent => {
+ 'newTimerfromAutotimer' => {
+ Descr => gettext('Create event entries, if a new timer from autotimer created.'),
+
+ # You have this choices (harmless is default):
+ # 'harmless', 'interesting', 'veryinteresting', 'important', 'veryimportant'
+ Level => 'veryinteresting',
+
+ # Search for a spezial Event.
+ # I.e.: Search for an LogEvent with match
+ # "Sub=>text" = subroutine =~ /text/
+ # "Msg=>text" = logmessage =~ /text/
+ # "Mod=>text" = modname =~ /text/
+ SearchForEvent => {
+ Sub => 'AUTOTIMER',
+ Msg => 'Save timer',
+ },
+ # Search for a Match and extract the information
+ # of the TimerId
+ # ...
+ Match => {
+ TimerId => qr/TimerId\:\s+\"(\d+)\"/s,
+ },
+ Actions => [
+ q|sub{ my $args = shift;
+ my $event = shift;
+ my $timer = getDataById($args->{TimerId}, 'TIMERS', 'Id'); + my $desc = getDataById($timer->{eventid}, 'EPG', 'eventid') if($timer->{eventid});
+ my $autotimer = getDataById($timer->{AutotimerId}, 'AUTOTIMER', 'Id');
+ my $title = sprintf(gettext("Autotimer('%s') found: %s"),
+ $autotimer->{Search}, $timer->{File});
+ my $description = sprintf(gettext("At: %s to %s\nDescription: %s"), + $timer->{NextStartTime}, + fmttime($timer->{Stop}), + $desc && $desc->{description} ? $desc->{description} : '' + ); +
+ main::getModule('REPORT')->news($title, $description, "display", $timer->{eventid}, "interesting");
+ }
+ |,
+ ],
+
+ },
+ },
+ };
+ return $args;
+}
+
+# ------------------
+# Name: status
+# Descr: Standardsubroutine to report statistical data for Report Plugin.
+# Usage: my $report = $obj->status([$watcher, $console]);
+# ------------------
+sub status {
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift;
+ my $console = shift;
+ my $lastReportTime = shift || 0;
+
+ my $sql = qq|
+SELECT
+ t.Id as __Id,
+ t.File,
+ t.Status as __Status,
+ c.Name as Channel,
+ c.Pos as __Pos,
+ DATE_FORMAT(t.Day, '%e.%c.%Y') as Day,
+ t.Start,
+ t.Stop,
+ t.Priority,
+ UNIX_TIMESTAMP(t.NextStartTime) as __Day,
+ t.Collision as __Collision,
+ t.eventid as __NextEpgId,
+ t.AutotimerId as __AutotimerId
+FROM
+ TIMERS as t,
+ CHANNELS as c
+WHERE
+ t.ChannelID = c.Id
+ and UNIX_TIMESTAMP(t.addtime) > ?
+ and t.AutotimerId > 0
+ORDER BY
+ t.NextStartTime|;
+
+ my $fields = fields($obj->{dbh}, $sql); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($lastReportTime) + or return error "Can't execute query: $sth->errstr."; + my $erg = $sth->fetchall_arrayref();
+ for(@$erg) {
+ $_->[6] = fmttime($_->[6]);
+ $_->[7] = fmttime($_->[7]);
+ }
+
+ unshift(@$erg, $fields);
+ return {
+ message => sprintf(gettext('Autotimer has %d new timer programmed, since last report at %s'),
+ (scalar @$erg - 1), scalar localtime($lastReportTime)),
+ table => $erg,
+ };
+}
+
+
+# ------------------
+sub new {
+# ------------------
+ my($class, %attr) = @_;
+ my $self = {};
+ bless($self, $class);
+
+ # paths
+ $self->{paths} = delete $attr{'-paths'};
+
+ # who am I
+ $self->{MOD} = $self->module;
+
+ # all configvalues to $self without parents (important for ConfigModule)
+ map {
+ $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_};
+ $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}};
+
+ # Try to use the Requirments
+ map {
+ eval "use $_";
+ return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@);
+ } keys %{$self->{MOD}->{Prereq}};
+
+ # read the DB Handle
+ $self->{dbh} = delete $attr{'-dbh'};
+
+ # file
+ $self->{file} = $self->{config}->{file};
+
+ # The Initprocess
+ my $erg = $self->_init or return error('Problem to initialize module');
+ + return $self;
+}
+
+# ------------------
+sub _init {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ + return 0, panic("Session to database is'nt connected") + unless($obj->{dbh}); + + # don't remove old table, if updated rows => warn only + tableUpdated($obj->{dbh},'AUTOTIMER',19,0); +
+ # Look for table or create this table
+ my $version = main::getVersion;
+ $obj->{dbh}->do(qq|
+ CREATE TABLE IF NOT EXISTS AUTOTIMER (
+ Id int(11) unsigned auto_increment NOT NULL,
+ Activ enum('y', 'n') default 'y',
+ Done set('timer', 'recording', 'chronicle' ) NOT NULL default 'timer',
+ Search text NOT NULL default '',
+ InFields set('title', 'subtitle', 'description' ) NOT NULL,
+ Channels text default '',
+ Start char(4) default '0000',
+ Stop char(4) default '0000',
+ MinLength tinyint default NULL,
+ Priority tinyint(2) default NULL,
+ Lifetime tinyint(2) default NULL,
+ Dir text,
+ VPS enum('y', 'n') default 'n',
+ prevminutes tinyint default NULL,
+ afterminutes tinyint default NULL,
+ Weekdays set('Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat', 'Sun'), + startdate datetime default NULL, + stopdate datetime default NULL,
+ count int(11) default NULL,
+ PRIMARY KEY (Id)
+ ) COMMENT = '$version'
+ |); + + main::after(sub{ + my $m = main::getModule('EPG'); + $m->updated(sub{ + return 0 if($obj->{active} ne 'y'); + + lg 'Start autotimer callback to find new events!';
+ return $obj->autotimer(); + + }); + return 1; + }, "AUTOTIMER: Install callback at update epg data ...", 30); + + return 1;
+}
+ +# ------------------
+# Name: autotimer
+# Descr: Routine to parse the EPG Data for users Autotimer.
+# If Autotimerid given, then will this search only
+# for this Autotimer else for all.
+# Usage: $obj->autotimer([$autotimerid]);
+# ------------------
+sub autotimer {
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift;
+ my $console = shift;
+ my $autotimerid = shift;
+
+ # Get Autotimer + my $sth; + if($autotimerid) { + $sth = $obj->{dbh}->prepare('select * from AUTOTIMER where Activ = "y" AND Id = ? order by Id'); + $sth->execute($autotimerid) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } else { + $sth = $obj->{dbh}->prepare('select * from AUTOTIMER where Activ = "y" order by Id'); + $sth->execute() + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } + my $att = $sth->fetchall_hashref('Id'); +
+ my $waiter;
+ if(ref $console && !$autotimerid && $console->typ eq 'HTML') {
+ my $zaehler = scalar keys %$att;
+ $waiter = $console->wait(gettext("Look for autotimer ..."), 0, ++$zaehler, 'no');
+ }
+
+ my $l = 0; # Lines for Waiter
+ my $C = 0; # Total of created and modifed timers
+ my $M = 0;
+ my $log;
+
+ my $vdrVersion = main::getVdrVersion();
+ + # Get Timersmodule
+ my $timermod = main::getModule('TIMERS');
+ foreach my $id (sort keys %$att) {
+ my $a = $att->{$id};
+
+ $waiter->next(++$l, undef, sprintf(gettext("Look for autotimer with ID(%d) with search '%s'"), $id, $a->{Search}))
+ if(ref $waiter);
+
+ if(ref $console && $autotimerid) {
+ $console->message(' ') if($console->{TYP} eq 'HTML');
+ $console->message(sprintf(gettext("Look for autotimer with ID(%d) with search '%s'"), $id, $a->{Search}));
+ }
+
+ # Build SQL Command and run it ....
+ my $events = $obj->_eventsearch($a, $timermod) || next;
+
+ # Only search for one at?
+ if(ref $console && $autotimerid) {
+ $console->message(sprintf(gettext("Found %d entries for '%s' in EPG database."), scalar keys %$events, $a->{Search}));
+ foreach my $Id (sort keys %$events) {
+ my $output = { + gettext("Channel") => $events->{$Id}->{Channel}, + gettext("Title") => $events->{$Id}->{Title}, + gettext("Subtitle") => $events->{$Id}->{Subtitle}, + gettext("Day") => $events->{$Id}->{Day}, + gettext("Start") => fmttime($events->{$Id}->{Start}), + gettext("Stop") => fmttime($events->{$Id}->{Stop}), + gettext("Description") => $events->{$Id}->{Summary}, + }; + $console->table($output); + };
+ }
+
+ # Every found and save this as timer
+ my $c = 0;
+ my $m = 0;
+ foreach my $Id (sort keys %$events) {
+ $events->{$Id}->{Activ} = 'y';
+ $events->{$Id}->{VPS} = ($events->{$Id}->{VpsStart} && $a->{VPS} eq 'y') ? 'y' : '';
+ $events->{$Id}->{Priority} = $a->{Priority};
+ $events->{$Id}->{Lifetime} = $a->{Lifetime};
+
+ $events->{$Id}->{File} = $obj->_placeholder($events->{$Id}, $a);
+
+ if($events->{$Id}->{VPS} eq 'y') {
+ $events->{$Id}->{Start} = $events->{$Id}->{VpsStart};
+ $events->{$Id}->{Stop} = $events->{$Id}->{VpsStop};
+ } + + my $nexttime = $timermod->getNextTime( $events->{$Id}->{Day} , $events->{$Id}->{Start},$events->{$Id}->{Stop} )
+ or error(sprintf("Can't get the nexttime for this autotimer: %d", $events->{$Id}->{eventid}));
+
+ # Add anchor for reidentify timer
+ my $aidcomment = sprintf('#~AT[%d]', $id);
+
+ if($vdrVersion >= 10344){
+ $events->{$Id}->{Summary} = $aidcomment;
+ } else {
+ $events->{$Id}->{Summary} .= $aidcomment;
+ }
+
+ my @parameters = ($events->{$Id}, $nexttime, $aidcomment);
+
+ # Wished timer already exist with same data from autotimer ?
+ next if($obj->_timerexists(@parameters)); + + # Adjust timers set by the autotimer
+ my $timerID = $obj->_timerexistsfuzzy(@parameters);
+
+ if(!$timerID && $a->{Done}) {
+ + my @done = split(',', $a->{Done}); + + # Ignore timer if it already with same title recorded
+ if(grep(/^chronicle$/, @done) && $obj->_chronicleexists(@parameters)) { + lg sprintf("Don't create timer from AT(%d) '%s', because found same data on chronicle", $id, $events->{$Id}->{File}); + next; + }
+ + # Ignore timer if it already with same title recorded
+ if(grep(/^recording$/, @done) && $obj->_recordexists(@parameters)){ + lg sprintf("Don't create timer from AT(%d) '%s', because found same data on recordings", $id, $events->{$Id}->{File}); + next; + }
+ # Ignore timer if it already a timer with same title programmed, on other place
+ if(grep(/^timer$/, @done) && $obj->_timerexiststitle(@parameters)){ + lg sprintf("Don't create timer from AT(%d) '%s', because found same data on other timers", $id, $events->{$Id}->{File}); + next; + }
+ }
+
+ my $error = 0;
+ my $erg = $timermod->saveTimer($events->{$Id}, $timerID ? $timerID : undef);
+ foreach my $zeile (@$erg) {
+ if($zeile =~ /^(\d{3})\s+(.+)/) {
+ $error = $2 if(int($1) >= 500);
+ }
+ }
+ if($error) {
+ $console->err(sprintf(gettext("Can't save timer for '%s' : %s"), $events->{$Id}->{File}, $error))
+ if(ref $console && $autotimerid);
+ } else {
+ if($timerID) {
+ ++$m;
+ $console->message(sprintf(gettext("Modify timer for '%s'."), $events->{$Id}->{File}))
+ if(ref $console && $autotimerid);
+ } else {
+ ++$c;
+ $console->message(sprintf(gettext("Create timer for '%s'."), $events->{$Id}->{File}))
+ if(ref $console && $autotimerid);
+ }
+ }
+ }
+ $C += $c;
+ $M += $m;
+ if($c) {
+ my $msg = sprintf(gettext("Create %d timer for '%s'."), $c, $a->{Search});
+ if(ref $console && $autotimerid) {
+ $console->message($msg);
+ }
+ else {
+ push(@{$log},$msg);
+ }
+ }
+ if($m) {
+ my $msg = sprintf(gettext("Modify %d timer for '%s'."), $m, $a->{Search});
+ if(ref $console && $autotimerid) {
+ $console->message($msg);
+ }
+ else {
+ push(@{$log},$msg);
+ }
+ }
+ }
+
+ $waiter->next(undef,undef,gettext('Read new timer in data base.'))
+ if(ref $waiter);
+
+ sleep 1;
+
+ $timermod->readData();
+
+ # last call of waiter
+ $waiter->end() if(ref $waiter);
+
+ if(ref $console) {
+ $console->start() if(ref $waiter);
+ unshift(@{$log},sprintf(gettext("Autotimer process has %d timers created and %d timers modified."), $C, $M));
+ lg join("\n", @$log);
+ $console->message($log);
+ $console->link({
+ text => gettext("Back to autotimer list"),
+ url => "?cmd=alist",
+ }) if($console->typ eq 'HTML');
+ } + + return 1;
+}
+
+# ------------------
+# Name: autotimerCreate
+# Descr: Routine to display the create form for Autotimer.
+# Usage: $obj->autotimerCreate($watcher, $console, [$userdata]);
+# ------------------
+sub autotimerCreate {
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $timerid = shift || 0;
+ my $data = shift || 0;
+
+ $obj->autotimerEdit($watcher, $console, $timerid, $data);
+}
+
+# ------------------
+# Name: autotimerEdit
+# Descr: Routine to display the edit form for Autotimer.
+# Usage: $obj->autotimerEdit($watcher, $console, [$atid], [$userdata]);
+# ------------------
+sub autotimerEdit {
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $timerid = shift || 0;
+ my $data = shift || 0;
+
+ my $mod = main::getModule('CHANNELS');
+ my $modT = main::getModule('TIMERS');
+
+ my $epg;
+ if($timerid and not ref $data) { + my $sth = $obj->{dbh}->prepare("select * from AUTOTIMER where Id = ?"); + $sth->execute($timerid) + or return $console->err(sprintf(gettext("Autotimer with ID '%s' does not exist in the database!"),$timerid));
+ $epg = $sth->fetchrow_hashref(); +
+ # Channels Ids in Namen umwandeln
+ my @channels = map { $_ = $mod->ChannelToPos($_) } split(/[\s|,]+/, $epg->{Channels});
+ $epg->{Channels} = \@channels;
+
+ # question erwartet ein Array
+ my @done = split(/\s*,\s*/, $epg->{Done});
+ $epg->{Done} = \@done;
+ my @infields = split(/\s*,\s*/, $epg->{InFields});
+ $epg->{InFields} = \@infields;
+ my @weekdays = split(/\s*,\s*/, $epg->{Weekdays});
+ $epg->{Weekdays} = \@weekdays;
+ + } elsif (ref $data eq 'HASH') {
+ $epg = $data;
+ }
+
+ my %wd = (
+ 'Mon' => gettext('Mon'),
+ 'Tue' => gettext('Tue'),
+ 'Wed' => gettext('Wed'),
+ 'Thu' => gettext('Thu'),
+ 'Fri' => gettext('Fri'),
+ 'Sat' => gettext('Sat'),
+ 'Sun' => gettext('Sun')
+ );
+
+ my %in = (
+ 'title' => gettext('Title'),
+ 'subtitle' => gettext('Subtitle'),
+ 'description' => gettext('Description')
+ );
+ + my %do = (
+ 'timer' => gettext('Timer'),
+ 'recording' => gettext('Exist recording'),
+ 'chronicle' => gettext('Recording chronicle')
+ ); + my $DoneChoices = [$do{'timer'}, $do{'recording'}]; + + # Enable option "chronicle" only if activated. + my $cm = main::getModule('CHRONICLE');
+ push(@$DoneChoices, $do{'chronicle'}) + if($cm and $cm->{active} eq 'y'); + + my $questions = [
+ 'Id' => {
+ typ => 'hidden',
+ def => $epg->{Id} || 0,
+ },
+ 'Activ' => {
+ typ => 'confirm',
+ def => $epg->{Activ} || 'y',
+ msg => gettext('Switch this autotimer on?'),
+ },
+ 'Search' => {
+ req => gettext('This is required!'),
+ msg => gettext( +"Search terms to look for EPG entries.\nYou can also improve your searches :\n* by adding 'operators' to your search terms like 'AND', 'OR', 'AND NOT' e.g. 'today AND NOT tomorrow'\n* by comma seperated multiply search terms e.g. 'today,tomorrow'\n* by minus sign to exclude search terms e.g. 'today,-tomorrow'" +),
+ def => $epg->{Search} || '',
+ },
+ 'InFields' => {
+ msg => gettext('Search in this EPG fields'),
+ typ => 'checkbox',
+ choices => [$in{'title'}, $in{'subtitle'}, $in{'description'}],
+ req => gettext('This is required!'),
+ def => sub {
+ my $value = $epg->{InFields} || ['title','subtitle'];
+ my @vals = (ref $value eq 'ARRAY') ? @$value : split(/\s*,\s*/, $value);
+ my @ret;
+ foreach my $v (@vals) {
+ push(@ret,$in{$v});
+ }
+ return @ret;
+ },
+ check => sub{
+ my $value = shift || return;
+ my $data = shift || return error('No Data in CB');
+ my @vals = (ref $value eq 'ARRAY') ? @$value : split(/\s*,\s*/, $value);
+ my @ret;
+ foreach my $v (@vals) {
+ unless(grep($_ eq $v, @{$data->{choices}})) {
+ my $ch = join(' ', @{$data->{choices}});
+ return undef, sprintf(gettext("You can choose: %s!"),$ch);
+ }
+ foreach my $k (keys %in) {
+ push(@ret,$k)
+ if($v eq $in{$k});
+ }
+ }
+ return join(',', @ret);
+ },
+ },
+ 'Channels' => {
+ typ => 'list',
+ def => $epg->{Channels},
+ choices => $mod->ChannelArray('Name', sprintf(' NOT (%s)', $obj->{exclude})),
+ options => 'multi',
+ msg => gettext('Restrict search to this channels'),
+ check => sub{
+ my $value = shift || return;
+ my @vals;
+ foreach my $chname ((ref $value eq 'ARRAY' ? @$value : split(/\s*,\s*/, $value))) {
+ if( my $chid = $mod->PosToChannel($chname) || $mod->NameToChannel($chname)) {
+ push(@vals, $chid);
+ } else {
+ return undef, sprintf(gettext("The channel '%s' does not exist!"),$chname);
+ }
+ }
+ return join(',', @vals);
+ },
+ },
+ 'Done' => {
+ msg => gettext('Ignore retries with same title?'),
+ typ => 'checkbox',
+ choices => $DoneChoices,
+ def => sub {
+ my $value = $epg->{Done};
+ my @vals = (ref $value eq 'ARRAY') ? @$value : split(/\s*,\s*/, $value);
+ my @ret;
+ foreach my $v (@vals) {
+ push(@ret,$do{$v});
+ }
+ return @ret;
+ },
+ check => sub{
+ my $value = shift || '';
+ my $data = shift || return error('No Data in CB');
+ my @vals = (ref $value eq 'ARRAY') ? @$value : split(/\s*,\s*/, $value);
+ my @ret;
+ foreach my $v (@vals) {
+ unless(grep($_ eq $v, @{$data->{choices}})) {
+ my $ch = join(' ', @{$data->{choices}});
+ return undef, sprintf(gettext("You can choose: %s!"),$ch);
+ }
+ foreach my $k (keys %do) {
+ push(@ret,$k)
+ if($v eq $do{$k});
+ }
+ }
+ return join(',', @ret);
+ },
+ },
+ 'Start' => {
+ typ => 'string',
+ def => sub{
+ my $value = $epg->{Start} || return "";
+ return fmttime($value);
+ },
+ msg => gettext("Starttime in format 'HH:MM'"),
+ check => sub{
+ my $value = shift || 0;
+ return undef, gettext('You set a start-time without a stop-time!')
+ if(not $data->{Stop} and $value);
+ return "" if(not $value);
+ $value = fmttime($value) if($value =~ /^\d+$/sig);
+ return undef, gettext('No right time!') if($value !~ /^\d+:\d+$/sig);
+ my @v = split(':', $value);
+ $value = sprintf('%02d%02d',$v[0],$v[1]);
+ if(int($value) < 2400 and int($value) >= 0) {
+ return sprintf('%04d',$value);
+ } else {
+ return undef, gettext('No right time!');
+ }
+ },
+ },
+ 'Stop' => {
+ typ => 'string',
+ def => sub{
+ my $value = $epg->{Stop} || return "";
+ return fmttime($value);
+ },
+ msg => gettext("Endtime in format 'HH:MM'"),
+ check => sub{
+ my $value = shift || 0;
+ return undef, gettext('You set a stop-time without a start-time!')
+ if(not $data->{Start} and $value);
+ return "" if(not $value);
+ $value = fmttime($value) if($value =~ /^\d+$/sig);
+ return undef, gettext('No right time!') if($value !~ /^\d+:\d+$/sig);
+ my @v = split(':', $value);
+ $value = sprintf('%02d%02d',$v[0],$v[1]);
+ if(int($value) < 2400 and int($value) >= 0) {
+ return sprintf('%04d',$value);
+ } else {
+ return undef, gettext('No right time!');
+ }
+ },
+ },
+ 'Weekdays' => {
+ msg => gettext('Search only on this weekdays'),
+ typ => 'checkbox',
+ choices => [$wd{'Mon'}, $wd{'Tue'}, $wd{'Wed'}, $wd{'Thu'}, $wd{'Fri'}, $wd{'Sat'}, $wd{'Sun'}],
+ def => sub {
+ my $value = $epg->{Weekdays} || ['Mon','Tue','Wed','Thu','Fri','Sat','Sun'];
+ my @vals = (ref $value eq 'ARRAY') ? @$value : split(/\s*,\s*/, $value);
+ my @ret;
+ foreach my $v (@vals) {
+ push(@ret,$wd{$v});
+ }
+ return @ret;
+ },
+ check => sub{
+ my $value = shift || [$wd{'Mon'}, $wd{'Tue'}, $wd{'Wed'}, $wd{'Thu'}, $wd{'Fri'}, $wd{'Sat'}, $wd{'Sun'}];
+ my $data = shift || return error('No Data in CB');
+ my @vals = (ref $value eq 'ARRAY') ? @$value : split(/\s*,\s*/, $value);
+ my @ret;
+ foreach my $v (@vals) {
+ unless(grep($_ eq $v, @{$data->{choices}})) {
+ my $ch = join(' ', @{$data->{choices}});
+ return undef, sprintf(gettext("You can choose: %s!"),$ch);
+ }
+ foreach my $k (keys %wd) {
+ push(@ret,$k)
+ if($v eq $wd{$k});
+ }
+ }
+ return join(',', @ret);
+ },
+ },
+ 'VPS' => {
+ typ => 'confirm',
+ def => $epg->{VPS} || 'n',
+ msg => gettext('Activate VPS for new timer?'),
+ },
+ 'prevminutes' => {
+ typ => 'integer',
+ msg => gettext('Buffer time in minutes before the scheduled end of the recorded program.'),
+ def => $epg->{prevminutes},
+ check => sub{
+ my $value = shift; + return if($value eq "");
+ if($value =~ /^\d+$/sig and $value >= 0) {
+ return int($value);
+ } else {
+ return undef, gettext('No right Value!');
+ }
+ },
+ },
+ 'afterminutes' => {
+ typ => 'integer',
+ msg => gettext('Buffer time in minutes after the scheduled end of the recorded program.'),
+ def => $epg->{afterminutes},
+ check => sub{
+ my $value = shift; + return if($value eq "");
+ if($value =~ /^\d+$/sig and $value >= 0) {
+ return int($value);
+ } else {
+ return undef, gettext('No right Value!');
+ }
+ },
+ },
+ 'MinLength' => {
+ typ => 'integer',
+ msg => gettext('Minimum length in minutes'),
+ def => $epg->{MinLength} || 0,
+ check => sub{
+ my $value = shift || return;
+ if($value =~ /^\d+$/sig and $value > 0) {
+ return int($value);
+ } else {
+ return undef, gettext('No right Value!');
+ }
+ },
+ },
+ 'Priority' => {
+ typ => 'integer',
+ msg => sprintf(gettext('Priority (0 .. %d)'),$console->{USER}->{MaxPriority} ? $console->{USER}->{MaxPriority} : 99 ),
+ def => (defined $epg->{Priority} ? $epg->{Priority} : $modT->{Priority}),
+ check => sub{
+ my $value = shift || 0;
+ if($value =~ /^\d+$/sig and $value >= 0 and $value < 100) {
+ if($console->{USER}->{MaxPriority} and $value > $console->{USER}->{MaxPriority}) {
+ return undef, sprintf(gettext('Sorry, but maximum priority is limited on %d!'), $console->{USER}->{MaxPriority});
+ }
+ return int($value);
+ } else {
+ return undef, gettext('No right Value!');
+ }
+ },
+ },
+ 'Lifetime' => {
+ typ => 'integer',
+ msg => sprintf(gettext('Lifetime (0 .. %d)'),$console->{USER}->{MaxLifeTime} ? $console->{USER}->{MaxLifeTime} : 99 ),
+ def => (defined $epg->{Lifetime} ? $epg->{Lifetime} : $modT->{Lifetime}),
+ check => sub{
+ my $value = shift || 0;
+ if($value =~ /^\d+$/sig and $value >= 0 and $value < 100) {
+ if($console->{USER}->{MaxLifeTime} and $value > $console->{USER}->{MaxLifeTime}) {
+ return undef, sprintf(gettext('Sorry, but maximum lifetime is limited on %d!'), $console->{USER}->{MaxLifeTime});
+ }
+ return int($value);
+ } else {
+ return undef, gettext('No right Value!');
+ }
+ },
+ },
+ 'Dir' => {
+ typ => 'string',
+ msg => gettext('Group all recordings on a directory'),
+ def => $epg->{Dir},
+ # choices => main::getModule('TIMERS')->getRootDirs,
+ },
+ ];
+
+ # Ask Questions
+ $data = $console->question(($timerid ? gettext('Edit autotimer')
+ : gettext('Create a new autotimer')), $questions, $data);
+
+ if(ref $data eq 'HASH') {
+ delete $data->{Channel};
+
+ # Last chance ;)
+ return $console->err(gettext('Nothing to search defined!'))
+ unless($data->{Search});
+
+ $obj->_insert($data);
+
+ $data->{Id} = $obj->{dbh}->selectrow_arrayref('SELECT max(ID) FROM AUTOTIMER')->[0]
+ if(not $data->{Id});
+
+ $console->message(gettext('Autotimer saved!'));
+ debug sprintf('%s autotimer with search "%s" is saved%s',
+ ($timerid ? 'New' : 'Changed'),
+ $data->{Search},
+ ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ );
+ $obj->autotimer($watcher, $console, $data->{Id});
+
+ $console->link({
+ text => gettext("Back to referred side"),
+ url => $console->{browser}->{Referer},
+ }) if($console->typ eq 'HTML');
+
+ }
+ return 1;
+}
+
+# ------------------
+# Name: autotimerDelete
+# Descr: Routine to display the delete form for Autotimer.
+# Usage: $obj->autotimerDelete($watcher, $console, $atid);
+# ------------------
+sub autotimerDelete {
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $timerid = shift || return $console->err(gettext("No ID for autotimer to delete! Please use adelete 'aid'")); # If timerid the edittimer
+ + my @timers = reverse sort{ $a <=> $b } split(/[^0-9]/, $timerid); + + my $sql = sprintf('DELETE FROM AUTOTIMER where Id in (%s)', join(',' => ('?') x @timers)); + my $sth = $obj->{dbh}->prepare($sql); + if(!$sth->execute(@timers)) { + error sprintf("Can't execute query: %s.",$sth->errstr); + $console->err(sprintf gettext("Autotimer with ID '%s' does not exist in the database!"), join(',', @timers)); + return 0; + } + + $console->message(sprintf gettext("Autotimer %s is deleted."), join(',', @timers));
+ debug sprintf('autotimer with id "%s" is deleted%s',
+ join(',', @timers),
+ ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ );
+ $console->redirect({url => $console->{browser}->{Referer}, wait => 1})
+ if($console->typ eq 'HTML');
+}
+
+# ------------------
+# Name: autotimerToogle
+# Descr: Switch the Autotimer on or off.
+# Usage: $obj->autotimerToogle($watcher, $console, $atid);
+# ------------------
+sub autotimerToggle {
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $timerid = shift || return $console->err(gettext("No ID for autotimer to toggle! Please use atoggle 'aid'"));
+ + my @timers = reverse sort{ $a <=> $b } split(/[^0-9]/, $timerid); + + my $sql = sprintf('SELECT Id,Activ FROM AUTOTIMER where Id in (%s)', join(',' => ('?') x @timers)); + my $sth = $obj->{dbh}->prepare($sql); + if(!$sth->execute(@timers)) { + error sprintf("Can't execute query: %s.",$sth->errstr); + $console->err(sprintf(gettext("Autotimer with ID '%s' does not exist in the database!"),$timerid)); + return 0; + } + my $data = $sth->fetchall_hashref('Id'); + + my $erg; + for my $timer (@timers) { + + unless(exists $data->{$timer}) { + $console->err(sprintf(gettext("Autotimer with ID '%s' does not exist in the database!"), $timer)); + next; + } + + my $status = (($data->{$timer}->{Activ} eq 'n' ) ? 'y' : 'n'); + + my $sql = "UPDATE AUTOTIMER set Activ = ? where Id = ?"; + my $sth = $obj->{dbh}->prepare($sql); + if(!$sth->execute($status,$timer)) { + error sprintf("Can't execute query: %s.",$sth->errstr); + $console->err(sprintf(gettext("Can't toggle autotimer with ID '%s'!"),$timer)); + next; + } + + debug sprintf('autotimer with id "%s" is %s%s',
+ $timer,
+ ($status eq 'n' ? 'disabled' : 'activated'),
+ ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ );
+
+ if($console->typ ne 'AJAX') { + my $text = ($status eq 'n') ? gettext('disabled')
+ : gettext('activated');
+ $console->message(sprintf gettext("Autotimer %s is %s."), $timer, $text); + }
+ + # AJAX + push(@$erg,[$timer,($status eq 'n' ? 0 : 1),0,0]); + } + + $console->redirect({url => $console->{browser}->{Referer}, wait => 2})
+ if($console->typ eq 'HTML'); + + if($console->typ eq 'AJAX') { + # { "data" : [ [ ID, ON, RUN, CONFLICT ], .... ] } + # { "data" : [ [ 5, 1, 0, 0 ], .... ] } + $console->table($erg); + } +
+}
+
+# ------------------
+# Name: list
+# Descr: List Autotimers in a table display.
+# Usage: $obj->list($watcher, $console, [$atid], [$params]);
+# ------------------
+sub list {
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $text = shift || ''; + my $params = shift; + + my $where = ''; + if($text =~ /^.*?/) { + if($text =~ /^[0-9]+?/) { + $where = "WHERE Id = '$text'"; + } elsif($text) { + $where = 'WHERE '.buildsearch("Search,Dir",$text); + } + }
+
+ my %f = (
+ 'Id' => umlaute(gettext('Service')),
+ 'Act' => umlaute(gettext('Act')),
+ 'Search' => umlaute(gettext('Search')),
+ 'Channels' => umlaute(gettext('Channels')),
+ 'Start' => umlaute(gettext('Start')),
+ 'Stop' => umlaute(gettext('Stop')),
+ 'Dir' => umlaute(gettext('Dir')),
+ 'Min' => umlaute(gettext('Min')),
+ );
+
+ my $sql = qq|
+ select
+ Id as $f{'Id'},
+ Activ as $f{'Act'},
+ Search as $f{'Search'},
+ Channels as $f{'Channels'},
+ Dir as $f{'Dir'},
+ Start as $f{'Start'},
+ Stop as $f{'Stop'},
+ MinLength as $f{'Min'}
+ FROM
+ AUTOTIMER
+ $where
+ |; + + my $fields = fields($obj->{dbh}, $sql);
+
+ my $sortby = gettext("Search");
+ $sortby = $params->{sortby}
+ if(exists $params->{sortby} && grep(/^$params->{sortby}$/i,@{$fields}));
+ $sql .= " order by $sortby";
+ if(exists $params->{desc} && $params->{desc} == 1) {
+ $sql .= " desc"; }
+ else {
+ $sql .= " asc"; }
+
+ my $erg = $obj->{dbh}->selectall_arrayref($sql);
+ unshift(@$erg, $fields);
+
+ my $channels = main::getModule('CHANNELS')->ChannelHash('Id');
+ my $timers = main::getModule('TIMERS')->getTimersByAutotimer();
+
+ $console->table($erg,
+ {
+ sortable => 1,
+ channels => $channels,
+ timers => $timers,
+ }
+ );
+}
+
+
+# ------------------
+sub _eventsearch {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $a = shift || return error ('No Data from Autotimer!' );
+ my $timermod = shift || main::getModule('TIMERS') || return error ("Can't access modul TIMERS!");
+
+ # Searchstrings to Paragraphs Changed
+ $a->{Search} =~ s/\:/\:\.\*/
+ if($a->{InFields} =~ /description/);
+
+ my $search = buildsearch($a->{InFields}, $a->{Search});
+
+ # Start and Stop
+ if($a->{Start} and $a->{Stop}) {
+ if($a->{Start} > $a->{Stop}) {
+ $search .= "\n AND ((DATE_FORMAT(e.starttime, '%H%i') > $a->{Start} AND DATE_FORMAT(e.starttime, '%H%i') < 2359) OR (DATE_FORMAT(e.starttime, '%H%i') >= 0 and DATE_FORMAT(e.starttime, '%H%i') < $a->{Stop}))";
+ } else {
+ $search .= "\n AND (DATE_FORMAT(e.starttime, '%H%i') > $a->{Start} AND DATE_FORMAT(e.starttime, '%H%i') < $a->{Stop})";
+ }
+ }
+
+ # Min Length
+ if(exists $a->{MinLength} and $a->{MinLength}) {
+ $search .= sprintf(" AND e.duration >= %d ", $a->{MinLength} * 60);
+ }
+
+ # Channels
+ if($a->{Channels} and my @channelids = split(',', $a->{Channels})) {
+ @channelids = map {$_ = "'$_'"} @channelids;
+ $search = sprintf(' %s AND channel_id in (%s)', $search, join(',', @channelids));
+ }
+
+ # Weekdays
+ if($a->{Weekdays} and my @weekdays = split(',', $a->{Weekdays})) { + if(scalar @weekdays != 7 and scalar @weekdays != 0) {
+ @weekdays = map {$_ = "'$_'"} @weekdays;
+ $search = sprintf(' %s AND DATE_FORMAT(e.starttime, \'%%a\') in (%s)', $search, join(',', @weekdays)); + }
+ }
+
+ # Exclude channels, ifn't already lookup for channels
+ if($obj->{exclude} && not $a->{Channels}) {
+ $search = sprintf(' %s AND NOT (c.%s)', $search, $obj->{exclude});
+ }
+
+ # Custom time range
+ my $after = 0;
+ my $prev = 0;
+# if($a->{VPS} ne 'y') {
+ if(defined $a->{prevminutes}) {
+ $prev = $a->{prevminutes} * 60;
+ } else {
+ $prev = $timermod->{prevminutes} * 60;
+ }
+ if(defined $a->{afterminutes}) {
+ $after = $a->{afterminutes} * 60;
+ } else {
+ $after = $timermod->{afterminutes} * 60;
+ }
+# }
+
+ # Search for events
+ my $sql = qq|
+SELECT
+ e.eventid as eventid,
+ e.channel_id as ChannelID,
+ c.Name as Channel,
+ c.POS as POS,
+ e.title as Title,
+ e.subtitle as Subtitle,
+ e.description as Summary,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(e.starttime) - $prev ), '%d') as Day,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(e.starttime) - $prev ), '%H%i') as Start,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(e.starttime) + e.duration + $after ), '%H%i') as Stop,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(e.vpstime)), '%H%i') as VpsStart,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(e.vpstime) + e.duration), '%H%i') as VpsStop
+FROM
+ EPG as e,
+ CHANNELS as c
+WHERE
+ ( $search )
+ AND ( e.channel_id = c.Id )|;
+
+#dumper $sql;
+ my $data = $obj->{dbh}->selectall_hashref($sql, 'eventid');
+
+ return $data;
+}
+
+# ------------------
+sub _timerexists {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $eventdata = shift || return error ('No Data from Autotimer!' );
+ my ($nexttime, $aidcomment) = @_;
+
+ # Avoid Timer already defined (the timer with the same data again do not put on)
+ my $sql = "select count(*) as cc from TIMERS where
+ ChannelID = ?
+ and UNIX_TIMESTAMP(NextStartTime) = ?
+ and UNIX_TIMESTAMP(NextStopTime) = ?
+ and Priority = ?
+ and Lifetime = ?
+ and ( + ( Status & 1 = '0' )
+ or ( File = ? and Summary = ? ) + or ( Summary not like ? ) + )"; + + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($eventdata->{ChannelID},$nexttime->{start},$nexttime->{stop}, + $eventdata->{Priority},$eventdata->{Lifetime}, + $eventdata->{File},$eventdata->{Summary},"%".$aidcomment) + or return error sprintf("Can't execute query: %s.",$sth->errstr);
+ my $erg = $sth->fetchrow_hashref(); + return $erg->{cc} + if($erg); + return 0; + +}
+
+# ------------------
+sub _timerexistsfuzzy {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $eventdata = shift || return error ('No Data from Autotimer!' );
+ my ($nexttime, $aidcomment) = @_;
+
+ # Adjust timers set by the autotimer
+ my $timerID = 0;
+ my $sql = "select ID from TIMERS where
+ ChannelID = ?
+ and UNIX_TIMESTAMP(NextStartTime) = ?
+ and UNIX_TIMESTAMP(NextStopTime) = ?
+ and Summary like ?
+ order by length(Summary) desc;"; + + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($eventdata->{ChannelID},$nexttime->{start},$nexttime->{stop}, + "%".$aidcomment) + or return error sprintf("Can't execute query: %s.",$sth->errstr);
+ my $erg = $sth->fetchrow_hashref(); + return $erg->{ID} + if($erg); + return 0; +}
+
+# ------------------
+sub _recordexists {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $eventdata = shift || return error ('No Data from Autotimer!' );
+ my ($nexttime, $aidcomment) = @_;
+
+ # Ignore timer if it already with same title recorded
+ my $sql = "SELECT count(*) as cc
+ FROM RECORDS as r, OLDEPG as e
+ WHERE e.eventid = r.EventId
+ AND CONCAT_WS('~',e.title,IF(e.subtitle<>'',e.subtitle,NULL)) = ?";
+ + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($eventdata->{File}) + or return error sprintf("Can't execute query: %s.",$sth->errstr);
+ my $erg = $sth->fetchrow_hashref(); + return $erg->{cc} + if($erg); + return 0; +}
+ +# ------------------
+sub _chronicleexists {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $eventdata = shift || return error ('No Data from Autotimer!' );
+ my ($nexttime, $aidcomment) = @_;
+ + my $chroniclemod = main::getModule('CHRONICLE') || return error ("Can't access modul CHRONICLE!");
+ return 0 + if(not $chroniclemod or $chroniclemod->{active} ne 'y'); +
+ my $sql = "select count(*) as cc from CHRONICLE where title = ?";
+ my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($eventdata->{File}) + or return error sprintf("Can't execute query: %s.",$sth->errstr);
+ my $erg = $sth->fetchrow_hashref(); + return $erg->{cc} + if($erg); + return 0; +} +
+# ------------------
+sub _timerexiststitle {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $eventdata = shift || return error ('No Data from Autotimer!' );
+ my ($nexttime, $aidcomment) = @_;
+
+ my $sql = "select count(*) as cc from TIMERS where File = ?";
+ + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($eventdata->{File}) + or return error sprintf("Can't execute query: %s.",$sth->errstr);
+ my $erg = $sth->fetchrow_hashref(); + return $erg->{cc} + if($erg); + return 0; +}
+
+
+# ------------------
+sub _insert {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $data = shift || return;
+
+ if(ref $data eq 'HASH') {
+ my ($names, $vals, $kenn);
+ map {
+ push(@$names, $_);
+ push(@$vals, $data->{$_}),
+ push(@$kenn, '?'),
+ } sort keys %$data;
+
+ my $sql = sprintf("REPLACE INTO AUTOTIMER (%s) VALUES (%s)",
+ join(', ', @$names),
+ join(', ', @$kenn),
+ );
+ my $sth = $obj->{dbh}->prepare( $sql );
+ $sth->execute( @$vals );
+ } else {
+ my $sth = $obj->{dbh}->prepare('REPLACE INTO AUTOTIMER VALUES (?,?,?,?,?,?,?,?,?)');
+ $sth->execute( @$data );
+ }
+}
+
+# ------------------
+# Name: _placeholder
+# Descr: Replace the placeholder with extendet EPG
+# Usage: my $text = $obj->_placeholder($epgdata, $autotimerdata);
+# ------------------
+sub _placeholder {
+ my $obj = shift || return error ('No Object!' );
+ my $data = shift || return error ('No Data!' );
+ my $at = shift || return error ('No AtData!' );
+
+ my $file;
+
+ if ($at->{Dir}) {
+ my $title = $at->{Dir};
+ if($title =~ /.*%.*%.*/sig) {
+ my %at_details;
+ $at_details{'title'} = $data->{Title};
+ $at_details{'subtitle'} = $data->{Subtitle} ? $data->{Subtitle} : $data->{Start};
+ $at_details{'date'} = $data->{Day};
+ $at_details{'regie'} = $1 if $data->{Summary} =~ m/\|Director: (.*?)\|/;
+ $at_details{'category'} = $1 if $data->{Summary} =~ m/\|Category: (.*?)\|/;
+ $at_details{'genre'} = $1 if $data->{Summary} =~ m/\|Genre: (.*?)\|/;
+ $at_details{'year'} = $1 if $data->{Summary} =~ m/\|Year: (.*?)\|/;
+ $at_details{'country'} = $1 if $data->{Summary} =~ m/\|Country: (.*?)\|/;
+ $at_details{'originaltitle'} = $1 if $data->{Summary} =~ m/\|Originaltitle: (.*?)\|/;
+ $at_details{'fsk'} = $1 if $data->{Summary} =~ m/\|FSK: (.*?)\|/;
+ $at_details{'episode'} = $1 if $data->{Summary} =~ m/\|Episode: (.*?)\|/;
+ $at_details{'rating'} = $1 if $data->{Summary} =~ m/\|Rating: (.*?)\|/;
+ $title =~ s/%([\w_-]+)%/$at_details{lc($1)}/sieg;
+ $file = $title;
+ } else { # Classic mode DIR~TITLE~SUBTILE
+ $file = sprintf('%s~%s~%s', $at->{Dir}, $data->{Title},$data->{Subtitle});
+ }
+ } elsif($data->{Subtitle}) {
+ $file = sprintf('%s~%s', $data->{Title},$data->{Subtitle}); + } else {
+ $file = $data->{Title};
+ }
+
+ # sind irgendweche Tags verwendet worden, die leer waren und die doppelte Verzeichnisse erzeugten?
+ $file =~s#~+#~#g;
+ $file =~s#^~##g;
+ $file =~s#~$##g;
+
+ return $file;
+}
+ +# ------------------
+sub suggest {
# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $search = shift; + my $params = shift; + + if($search) { + my $sql = qq| + SELECT
+ Search
+ FROM + AUTOTIMER + WHERE + ( Search LIKE ? )
+ GROUP BY + Search + ORDER BY + Search + LIMIT 25 + |;
+ my $sth = $obj->{dbh}->prepare($sql); + $sth->execute('%'.$search.'%') + or return error "Can't execute query: $sth->errstr."; + my $result = $sth->fetchall_arrayref();
+ $console->table($result)
+ if(ref $console && $result); + } +} +
+1;
diff --git a/lib/XXV/MODULES/CHANNELS.pm b/lib/XXV/MODULES/CHANNELS.pm new file mode 100644 index 0000000..28d7620 --- /dev/null +++ b/lib/XXV/MODULES/CHANNELS.pm @@ -0,0 +1,1018 @@ +package XXV::MODULES::CHANNELS; + +use strict; + +use Tools; +use Locale::gettext; +use File::stat; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'CHANNELS', + Prereq => { + }, + Description => gettext('This module reads new channels and stores them in the database.'), + Version => '0.91', + Date => '2007-01-11', + Author => 'xpix', + Status => sub{ $obj->status(@_) }, + Preferences => { + file => { + description => gettext('Location of channels.conf on your system.'), + default => '/var/lib/vdr/channels.conf', + type => 'file', + required => gettext('This is required!'), + }, + interval => { + description => gettext('How often channels are to be updated (in seconds)'), + default => 3 * 60 * 60, + type => 'integer', + required => gettext('This is required!'), + }, + empty => { + description => gettext('Include channels with empty PID'), + default => 'n', + type => 'confirm', + }, + filterCA => { + description => gettext('Filter channels, set all wanted CA(Common Access)'), + # 0 for FTA, 1-4 for DVB Device, 32001 for AnalogPlugin + type => 'list', + options => 'multi', + default => '', + choices => sub{ + my @knownCA; + foreach my $CA (@{$obj->{knownCA}}) { + my $desc; + if($CA eq '0') { $desc = gettext("Free to air"); } + elsif($CA eq '1' + or $CA eq '2' + or $CA eq '3' + or $CA eq '4') { $desc = sprintf(gettext("DVB card %s"),$CA);} + else { $desc = sprintf("CA '%s'",$CA); } + push(@knownCA,[$desc,$CA]); + } + return @knownCA; + }, + check => sub{ + my $value = shift; + if(ref $value eq 'ARRAY') { + return join(',', @$value); + } else { + return $value; + } + }, + }, + stripCH => { + description => gettext("Clean channel names, only the 'long' part is visible."), + # Format in vdr 1.2.6 (Format "" or "long"). it show also all parts + # Format in vdr 1.3.10 (Format "short,long") + # Format in vdr 1.3.12 (Format "short,long;provider") + # Format in vdr 1.3.?? (Format "provider;short,long") + # Format in vdr 1.3.18 (Format "short,long;provider") + default => 'short,long;provider', + type => 'string', + }, + }, + Commands => { + cupdate => { + description => gettext('Read channels and write them into database'), + short => 'cu', + callback => sub{ $obj->readData(@_) }, + DenyClass => 'cedit', + Level => 'user', + }, + clist => { + description => gettext("List Channels from database 'cname'"), + short => 'cl', + callback => sub{ $obj->list(@_) }, + Level => 'user', + }, + cnew => { + description => gettext("Create a new channel"), + short => 'cne', + callback => sub{ $obj->newChannel(@_) }, + Level => 'user', + DenyClass => 'cedit', + }, + cedit => { + description => gettext("Edit a channel 'cid'"), + short => 'ced', + callback => sub{ $obj->editChannel(@_) }, + Level => 'user', + DenyClass => 'cedit', + }, + cdelete => { + description => gettext("Delete one or more channels 'pos'"), + short => 'cdl', + callback => sub{ $obj->deleteChannel(@_) }, + Level => 'user', + DenyClass => 'cedit', + }, + }, + }; + return $args; +} + +# ------------------ +sub status { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $lastReportTime = shift || 0; + + my $sql = "select count(*) from CHANNELS"; + my $gesamt = $obj->{dbh}->selectrow_arrayref($sql)->[0]; + + $sql = "select count(*) from CHANNELGROUPS"; + my $groups = $obj->{dbh}->selectrow_arrayref($sql)->[0]; + + return { + message => sprintf(gettext('The system has %d saved Channels in %d Groups'), $gesamt, $groups), + }; + +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + $self->{knownCA} = [0,1,2,3,4]; + + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + # Interval to read channels and put to DB + Event->timer( + interval => $self->{interval}, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ + lg 'Start the interval reading channels to DB!'; + $self->readData(); + }, + ); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return 0, panic("Session to database is'nt connected") + unless($obj->{dbh}); + + # remove old table, if updated rows + tableUpdated($obj->{dbh},'CHANNELS',16,1); + tableUpdated($obj->{dbh},'CHANNELGROUPS',3,1); + + # Look for table or create this table + my $version = main::getVersion; + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS CHANNELS ( + Id varchar(100) NOT NULL, + Name varchar(100) NOT NULL default '', + Frequency int(11) NOT NULL default '0', + Parameters varchar(100) default '', + Source varchar(100), + Srate int(11) default 0, + VPID varchar(100) default '', + APID varchar(100) default '', + TPID varchar(100) default '', + CA varchar(100) default '', + SID int(11) default 0, + NID int(11) default 0, + TID int(11) default 0, + RID int(11) default 0, + GRP int(11) default 0, + POS int(11) NOT NULL, + PRIMARY KEY (Id) + ) COMMENT = '$version' + |); + + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS CHANNELGROUPS ( + Id int(11) auto_increment not NULL, + Name varchar(100) default 'unknown', + Counter int(11) default '0', + PRIMARY KEY (Id) + ) COMMENT = '$version' + |); + + main::after(sub{ + $obj->{svdrp} = main::getModule('SVDRP'); + unless($obj->{svdrp}) { + panic ("Can't get modul SVDRP"); + return 0; + } + + my $erg = $obj->readData(); + return 1; + }, "CHANNELS: Read and register Channels ...", 5); + return 1; +} + +# ------------------ +sub insert { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return; + my $pos = shift || return; + my $grp = shift || 0; + + foreach my $CA (split(',', $data->[8])) { + push(@{$obj->{knownCA}},$CA); + } + + return if($obj->{empty} eq 'n' and not (($data->[6] ne "0" || $data->[7] ne "0"))); # Ignore Channels with APID = 0/TPID = 0 from PID Scan + if($obj->{filterCA} ne "") { + my $filter = $obj->{filterCA}; + $filter =~ s/\,/|/g; # Transform 0,2,400 => 0|2|400 + return 0 if(not ($data->[8] =~ /(^|\,)($filter)(\,|$)/s)); # check (^|,)(0|2|400)(,|$) + } + + # Strip short and providername from channelname e.g ch + if($obj->{stripCH}) { + my $ch = $data->[0]; + my $filter = $obj->{stripCH}; + my @p = split(';',$filter); + if(scalar @p == 2) { + if(($p[0] =~ /provider/i)) { # format "provider;name" + $ch = (split(';', $ch))[-1] if($ch =~ /;/); + $filter = $p[1]; + } + elsif(($p[1] =~ /provider/i)) { # format "name;provider" + $ch = (split(';', $ch))[0] if($ch =~ /;/); + $filter = $p[0]; + } + } + my @c = split(',',$filter); + if(scalar @c == 2) { + if(($c[0] =~ /long/i)) { # format "long,short" + $ch = (split(',', $ch))[0] if($ch =~ /,/); + } + elsif(($c[1] =~ /long/i)) { # format "short,long" + $ch = (split(',', $ch))[-1] if($ch =~ /,/); + } + } + $data->[0] = $ch if($ch); + } + + # ID + if ( $data->[3] eq 'C' or $data->[3] eq 'T') { + while(length($data->[1]) > 3) { + $data->[1] = substr($data->[1], 0, length($data->[1])-3); + } + } + + my $id; + $data->[12] = (split(':', $data->[12]))[0]; +# if($data->[12] && $data->[12] > 0 && $data->[12] < 100) { + # By DVB-C gabs Probleme weil die Zahl grösser 100 war + # Siehe auch http://www.vdr-portal.de/board/thread.php?sid=&postid=364373 + if($data->[12] && $data->[12] > 0) { + $id = sprintf('%s-%u-%u-%u-%u', $data->[3], $data->[10], ($data->[10] || $data->[11]) ? $data->[11] : $data->[1], $data->[9],$data->[12]); + } else { + $id = sprintf('%s-%u-%u-%u', $data->[3], $data->[10], ($data->[10] || $data->[11]) ? $data->[11] : $data->[1], $data->[9]); + } + unshift(@$data, $id); + + # ChannelGroup + push(@$data, $grp); + + # POS + push(@$data, $pos); + + my $sth = $obj->{dbh}->prepare('REPLACE INTO CHANNELS VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)'); + $sth->execute( @$data ); + lg sprintf('Add new Channel "%s" with Id "%s" in ChannelsDB!', $data->[1], $id); + return 1; +} + +# ------------------ +sub insertGrp { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $pos = shift || return; + my $name = shift || 0; + + lg sprintf('Add new ChannelGroup "%s" in ChannelsGroup!', $name); + my $sth = $obj->{dbh}->prepare('INSERT INTO CHANNELGROUPS SET Name=?, Counter=?'); + $sth->execute($name, $pos) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + return $sth->{mysql_insertid}; +} + +# ------------------ +sub readData { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $file = $obj->{file} || return 1, error ('No Channels File'); + + return 1, panic ('No Channels File found') if( ! -e $file); + + # only if file modification from last read time + my $mtime = (stat($file)->mtime); + return + if(! ref $console and defined $obj->{LastRefreshTime} and ($mtime > $obj->{LastRefreshTime})); + + $obj->{dbh}->do('DELETE FROM CHANNELS'); + $obj->{dbh}->do('DELETE FROM CHANNELGROUPS'); + + my $fh = IO::File->new("< $file") or return error("Can't open File $file $! "); + my $c = 0; + my $nPos = 1; + my $grp = 0; + while ( defined (my $line = <$fh>) ) { + $line =~ s/[\r|\n]//sig; + next if($line eq ""); + my @data = split(':', $line, 13); + $data[-1] = (split(':', $data[-1]))[0]; + + if( $line =~ /^\:\@(\d*)\s*(.*)/ and $nPos <= $1) { + $nPos = $1; + my $grpText = $2; + $grp = $obj->insertGrp($nPos, $grpText); + } elsif( $line =~ /^\:(.+)/) { + my $grpText = $1; + $grp = $obj->insertGrp($nPos, $grpText); + } else { + $grp = $obj->insertGrp(1, gettext("Channels")) + if(!$grp); + $c++ + if(scalar @data > 4 && $obj->insert(\@data, $nPos++, $grp)); + } + } + $fh->close; + + # Cool we have new Channels! + my $LastChannel = $obj->_LastChannel; + if($obj->{LastChannel}->{POS} and $LastChannel->{POS} > $obj->{LastChannel}->{POS}) { + $obj->_brandNewChannels($obj->{LastChannel}->{POS}); + } + + # Remember the maximum Channelposition + $obj->{LastChannel} = $obj->_LastChannel; + + $console->message(sprintf(gettext("Write %d channels into database."), $c)) + if(ref $console); + + # sort list with CA numerical + my %CA; + @CA{@{$obj->{knownCA}}} = (); + @{$obj->{knownCA}} = sort { if(is_numeric($a) && is_numeric($b)) { + $a <=> $b + } else { + $a cmp $b } } keys %CA; + + $obj->{LastRefreshTime} = $mtime; + return 1; +} +# ------------------ +sub getnum { +# ------------------ + use POSIX qw(strtod); + my $str = shift; + $str =~ s/^\s+//; + $str =~ s/\s+$//; + $! = 0; + my($num, $unparsed) = strtod($str); + if (($str eq '') || ($unparsed != 0) || $!) { + return undef; + } else { + return $num; + } +} +# ------------------ +sub is_numeric { defined getnum($_[0]) } +# ------------------ + +# ------------------ +sub list { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || ''; + my $params = shift; + + my $sql = qq| +select + c.*, cg.Name as __GrpName +from + CHANNELS as c, + CHANNELGROUPS as cg +where + c.Name like ? + and + c.GRP = cg.Id +|; + + my $fields = fields($obj->{dbh}, $sql); + + my $sortby = "POS"; + $sortby = $params->{sortby} + if(exists $params->{sortby} && grep(/^$params->{sortby}$/i,@{$fields})); + $sql .= "order by $sortby"; + $sql .= " desc" + if(exists $params->{desc} && $params->{desc} == 1); + + + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute('%'.$id.'%') + or return error sprintf("Can't execute query: %s.",$sth->errstr); + + my $erg = $sth->fetchall_arrayref(); + unshift(@$erg, $fields); + $console->table($erg,{sortable => 1 }); +} + + +# ------------------ +sub NameToChannel { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return undef; + + my $sth = $obj->{dbh}->prepare('select Id from CHANNELS where UPPER(Name) = UPPER( ? )'); + $sth->execute($name) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchrow_hashref(); + return $erg ? $erg->{Id} : undef; +} + +# ------------------ +sub PosToName { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $pos = shift || return undef; + + my $sth = $obj->{dbh}->prepare('select Name from CHANNELS where POS = ?'); + $sth->execute($pos) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchrow_hashref(); + return $erg ? $erg->{Name} : undef; +} + +# ------------------ +sub PosToChannel { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $pos = shift || return undef; + + my $sth = $obj->{dbh}->prepare('select Id from CHANNELS where POS = ?'); + $sth->execute($pos) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchrow_hashref(); + return $erg ? $erg->{Id} : undef; +} + +# ------------------ +sub ChannelGroupsArray { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $field = shift || return undef; + my $where = shift || ''; + $where = sprintf('WHERE %s', $where) if($where); + + my $sql = sprintf('select %s, Id from CHANNELGROUPS %s order by Id', $field, $where); + my $erg = $obj->{dbh}->selectall_arrayref($sql); + return $erg; +} + +# ------------------ +sub ChannelArray { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $field = shift || return undef; + my $where = shift || ''; + $where = sprintf('WHERE %s', $where) if($where); + + my $sql = sprintf('select %s, POS from CHANNELS %s order by POS', $field, $where); + my $erg = $obj->{dbh}->selectall_arrayref($sql); + return $erg; +} + +# ------------------ +sub ChannelIDArray { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $field = shift || return undef; + my $where = shift || ''; + $where = sprintf('WHERE %s', $where) if($where); + + my $sql = sprintf('select %s, Id from CHANNELS %s order by POS', $field, $where); + my $erg = $obj->{dbh}->selectall_arrayref($sql); + return $erg; +} + +# ------------------ +sub ChannelHash { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $field = shift || return undef; + my $where = shift || ''; + $where = sprintf('WHERE %s', $where) if($where); + + my $sql = sprintf('select * from CHANNELS %s', $where); + my $erg = $obj->{dbh}->selectall_hashref($sql, $field); + return $erg; +} + +# ------------------ +sub ChannelToName { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || return undef; + + my $sth = $obj->{dbh}->prepare('select Name from CHANNELS where Id = ?'); + $sth->execute($id) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchrow_hashref(); + return $erg ? $erg->{Name} : undef; +} + +# ------------------ +sub ChannelToPos { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || return undef; + + my $sth = $obj->{dbh}->prepare('select POS from CHANNELS where Id = ?'); + $sth->execute($id) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchrow_hashref(); + return $erg ? $erg->{POS} : undef; +} + + +# ------------------ +sub getChannelType { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || return undef; + my $pos = $obj->ChannelToPos($id); + if($pos and $pos >= 1) + { + my $data = $obj->ChannelHash('POS', sprintf('POS = %d', $pos)); + if(exists $data->{$pos}) { + my $ch = $data->{$pos}; + if($ch->{VPID}) { + return 'TV'; + } elsif($ch->{APID}) { + return 'RADIO'; + } + } + } + error("Unknown channel! Can't identify type of channel with id: %s", $id); + return 'UNKNOWN'; +} + +# ------------------ +sub _LastChannel { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $sql = sprintf('select * from CHANNELS order by POS desc limit 1'); + my $erg = $obj->{dbh}->selectrow_hashref($sql); + return $erg; +} + +# ------------------ +sub newChannel { +# ------------------ + my $self = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $defaultData = shift || 0; + + $self->editChannel($watcher, $console, 0, $defaultData); +} + +# ------------------ +sub editChannel { +# ------------------ + my $self = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $cid = shift || 0; # If channelid then edit channel + my $data = shift || 0; # Data for defaults + + my $defaultData; + if($cid and not ref $data) { + + $cid = $self->PosToChannel($cid) + unless(index($cid, '-') > -1); + + my $sth = $self->{dbh}->prepare('select POS, Name, Frequency, Parameters, Source, Srate, VPID, APID, TPID, CA, SID, NID, TID, RID from CHANNELS where Id = ?'); + $sth->execute($cid) + or return $console->err(sprintf(gettext("Channel '%s' does not exist in the database!"),$cid)); + $defaultData = $sth->fetchrow_hashref(); + } elsif (ref $data eq 'HASH') { + $defaultData = $data; + } + + my $questions = [ + 'POS' => { + typ => 'hidden', + def => $defaultData->{POS} || 0, + } ]; + + my $newpos = [ + 'NEWPOS' => { + typ => 'integer', + msg => gettext('Position'), + def => int($defaultData->{POS}), + check => sub{ + my $value = shift; + if(int($value) > 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + } ]; + #Change Position only on editing + push(@{$questions},@{$newpos}) + if($cid && main::getVdrVersion >= 10332); + + my $more = [ + 'Name' => { + typ => 'string', + def => $defaultData->{Name} || gettext('New channel'), + msg => gettext("Name"), + check => sub{ + my $value = shift || return; + if($value ne '') { + return $value; + } else { + return undef, gettext('This is required!'); + } + }, + }, + 'Frequency' => { + typ => 'integer', + msg => gettext('Transponder frequency'), + def => int($defaultData->{Frequency}) || 0, + check => sub{ + my $value = shift; + if(int($value) > 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'Source' => { + typ => 'string', + def => $defaultData->{Source} || "", + msg => gettext("Signal source"), + check => sub{ + my $value = shift || return; + if($value ne '') { + return $value; + } else { + return undef, gettext('This is required!'); + } + }, + }, + 'Parameters' => { + typ => 'string', + def => $defaultData->{Parameters} || "", + msg => gettext("Various parameters, depends on signal source"), + check => sub{ + my $value = shift || return; + if($value ne '') { + return $value; + } else { + return undef, gettext('This is required!'); + } + }, + }, + 'Srate' => { + typ => 'integer', + msg => gettext('Symbol rate'), + def => int($defaultData->{Srate}) || 27500, + check => sub{ + my $value = shift; + if(int($value) > 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'VPID' => { + typ => 'integer', + msg => gettext('Video PID (VPID)'), + def => int($defaultData->{VPID}) || 0, + check => sub{ + my $value = shift; + if(int($value) >= 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'APID' => { + typ => 'string', + def => $defaultData->{APID} || 0, + msg => gettext("Audio PID (APID)"), + check => sub{ + my $value = shift || return; + if($value ne '') { + return $value; + } else { + return undef, gettext('This is required!'); + } + }, + }, + 'TPID' => { + typ => 'integer', + msg => gettext('Teletext PID (TPID)'), + def => int($defaultData->{TPID}) || 0, + check => sub{ + my $value = shift; + if(int($value) >= 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'CA' => { + typ => 'string', + def => $defaultData->{CA} || 0, + msg => gettext("Conditional access (CA)"), + check => sub{ + my $value = shift || return; + if($value ne '') { + return $value; + } else { + return undef, gettext('This is required!'); + } + }, + }, + 'SID' => { + typ => 'integer', + msg => gettext('Service ID (SID)'), + def => int($defaultData->{SID}) || 0, + check => sub{ + my $value = shift; + if(int($value) >= 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'NID' => { + typ => 'integer', + msg => gettext('Network ID (NID)'), + def => int($defaultData->{NID}) || 0, + check => sub{ + my $value = shift; + if(int($value) >= 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'TID' => { + typ => 'integer', + msg => gettext('Transport stream ID (TID)'), + def => int($defaultData->{TID}) || 0, + check => sub{ + my $value = shift; + if(int($value) >= 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'RID' => { + typ => 'integer', + msg => gettext('Radio ID (RID)'), + def => int($defaultData->{RID}) || 0, + check => sub{ + my $value = shift; + if(int($value) >= 0) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + ]; + push(@{$questions},@{$more}); + + # Ask Questions + my $datasave = $console->question(($cid ? gettext('Edit channel') + : gettext('New channel')), $questions, $data); + + if(ref $datasave eq 'HASH') { + my $erg = $self->saveChannel($datasave, $datasave->{POS}); + + my $error; + foreach my $zeile (@$erg) { + if($zeile =~ /^(\d{3})\s+(.+)/) { + $error = $2 if(int($1) >= 500); + } + } + unless($error) { + debug sprintf('%s channel with name "%s" is saved%s', + ($cid ? 'Changed' : 'New'), + $data->{Name}, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ ); + $console->message($erg); + } else { + error sprintf('%s channel with name "%s" does\'nt saved : %s', + ($cid ? 'Changed' : 'New'), + $data->{Name}, + $error + ); + $console->err($erg); + } + sleep(1); + $self->readData($watcher,$console); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 2}) + if($console->typ eq 'HTML'); + } +} + +# ------------------ +sub saveChannel { +# ------------------ + my $self = shift || return error ('No Object!' ); + my $data = shift || return error('No Data to Save!'); + my $pos = shift || 0; + + my $erg; + + if($pos + && defined $data->{NEWPOS} + && $pos != $data->{NEWPOS} ) { + $erg = $self->{svdrp}->command( + sprintf("movc %s %s", + $pos, + $data->{NEWPOS} + )); + $pos = $data->{NEWPOS}; + push(@{$erg},"\r\n"); + } + + $erg = $self->{svdrp}->command( + sprintf("%s %s:%s:%s:%s:%s:%s:%s:%s:%s:%s:%s:%s:%s", + $pos ? "modc $pos" : "newc", + $data->{Name}, + int($data->{Frequency}), + $data->{Parameters}, + $data->{Source}, + int($data->{Srate}), + int($data->{VPID}), + $data->{APID}, + int($data->{TPID}), + $data->{CA} ? $data->{CA} : '0', + int($data->{SID}), + int($data->{NID}), + int($data->{TID}), + int($data->{RID}) + ) + ); + return $erg; +} + +# ------------------ +sub deleteChannel { +# ------------------ + my $self = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $channelid = shift || return $console->err(gettext("No channel to delete! Please use cdelete 'pos'")); + my $answer = shift || 0; + + my @channels = reverse sort{ $a <=> $b } split(/[^0-9]/, $channelid); + + my $sql = sprintf('select Id,POS,Name from CHANNELS where POS in (%s)', join(',' => ('?') x @channels)); + my $sth = $self->{dbh}->prepare($sql); + $sth->execute(@channels) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $data = $sth->fetchall_hashref('POS'); + + foreach my $pos (@channels) { + unless(exists $data->{$pos}) { + $console->err(sprintf(gettext("Channel with number '%s' does not exist in database!"), $pos)); + next; + } + + if(ref $console and $console->{TYP} ne 'HTML') { + $console->table($data->{$pos}); + my $confirm = $console->confirm({ + typ => 'confirm', + def => 'y', + msg => gettext('Are you sure to delete this channel?'), + }, $answer); + next if(! $answer eq 'y'); + } + + debug sprintf('Channel with name "%s" is deleted%s', + $data->{$pos}->{Name}, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ ); + + $self->{svdrp}->queue_cmds("delc $pos"); # Sammeln der Kommandos + } + + if($self->{svdrp}->queue_cmds('COUNT')) { + my $erg = $self->{svdrp}->queue_cmds("CALL"); # Aufrufen der Kommandos + $console->msg($erg, $self->{svdrp}->err) + if(ref $console); + + sleep(1); + + $self->readData($watcher,$console); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 1}) + if(ref $console and $console->typ eq 'HTML'); + } else { + $console->err(gettext("No channel to delete!")); + } + + return 1; +} + +# ------------------ +sub _brandNewChannels { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $oldmaximumpos = shift || return; + + my $sql = 'select * from CHANNELS where POS > ?'; + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($oldmaximumpos) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_hashref('POS'); + + my $text; + foreach my $chpos (sort {$erg->{$a} <=> $erg->{$b}} keys %$erg) { + my $c = $erg->{$chpos}; + $text .= sprintf(gettext('New %s channel: %s on position: %d %s'), + ($c->{VPID} > 5 or index('+', $c->{VPID}) + ? gettext('TV') + : gettext('Radio')), + $c->{Name}, + $c->{POS}, + (index('+', $c->{VPID}) || $c->{VPID} == 1 ? gettext('(encrypted)') : ''), + ); + } + + my $rm = main::getModule('REPORT'); + $rm->news( + sprintf(gettext('Discover %d new channels!'), scalar keys %$erg), + $text, + 'clist', + undef, + 'veryinteresting', + ); + return 1; +} + + +1; diff --git a/lib/XXV/MODULES/CHRONICLE.pm b/lib/XXV/MODULES/CHRONICLE.pm new file mode 100644 index 0000000..f2fdd2c --- /dev/null +++ b/lib/XXV/MODULES/CHRONICLE.pm @@ -0,0 +1,249 @@ +package XXV::MODULES::CHRONICLE; + +use strict; +use Tools; +use Locale::gettext; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $self = shift || return error ('No Object!' ); + + my $args = { + Name => 'CHRONICLE', + Prereq => {
+ # 'Perl::Module' => 'Description',
+ }, + Description => gettext('This module store recordings at chronicle.'), + Version => '0.91', + Date => '09.01.2007', + Author => 'a.brachold', + Preferences => { + active => {
+ description => gettext('Activate this service'),
+ default => 'y',
+ type => 'confirm',
+ required => gettext('This is required!'),
+ }, + }, + Commands => { + chrlist => { + description => gettext('List recording chronicle'), + short => 'chrl', + callback => sub{ $self->list(@_) }, + DenyClass => 'rlist', + }, + chrsearch => { + description => gettext("Search at chronicle for 'text'"), + short => 'chrs', + callback => sub{ $self->search(@_) }, + DenyClass => 'rlist', + }, + chrdelete => { + description => gettext("Delete at chronicle with 'id'"), + short => 'chrd', + callback => sub{ $self->delete(@_) }, + DenyClass => 'redit', + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $self = shift || return error ('No Object!' ); + + if($self->{active} eq 'y') { + return 0, panic("Session to database is'nt connected") + unless($self->{dbh}); + + # don't remove old table, if updated rows => warn only + tableUpdated($self->{dbh},'CHRONICLE',6,0); + + # Look for table or create this table + my $version = main::getVersion; + $self->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS CHRONICLE ( + id int unsigned auto_increment not NULL, + hash varchar(16) NOT NULL default '',
+ title text NOT NULL default '',
+ channel_id varchar(100) NOT NULL default '',
+ starttime datetime NOT NULL default '0000-00-00 00:00:00',
+ duration int NOT NULL default '0', + PRIMARY KEY (id), + UNIQUE KEY (hash) + ) COMMENT = '$version' + |); + + main::after(sub{ + my $m = main::getModule('RECORDS'); + $m->updated(sub{ + return 0 if($self->{active} ne 'y'); + + lg 'Start chronicle callback to store recordings!';
+ return $self->_insertData(); + + }); + return 1; + }, "CHRONICLE: Install callback at update recordings ...", 15); + } + 1; +} + +# ------------------ +sub _insertData { +# ------------------ + my $self = shift || return error ('No Object!' ); + + my $sql = qq|
+INSERT IGNORE INTO CHRONICLE + SELECT + 0, PASSWORD(CONCAT(e.channel_id,e.starttime,title)), + REPLACE(IF(Length(e.subtitle)<=0, IF(left(e.title,1) = '%',right(e.title,length(e.title)-1),e.title), CONCAT_WS('~',e.title,e.subtitle)),'~%','~') as title, + IF(e.channel_id <> "<undef>",e.channel_id , NULL), + e.starttime, + e.duration + FROM OLDEPG as e,RECORDS as r + WHERE r.eventid = e.eventid +|; + $self->{dbh}->do($sql);
+ + return 1; +} + +# ------------------ +sub list { +# ------------------ + my $self = shift; + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my %f = (
+ 'id' => umlaute(gettext('Service')),
+ 'title' => umlaute(gettext('Title')),
+ 'subtitle' => umlaute(gettext('Subtitle')),
+ 'channel' => umlaute(gettext('Channel')),
+ 'day' => umlaute(gettext('Day')),
+ 'start' => umlaute(gettext('Start')),
+ 'stop' => umlaute(gettext('Stop'))
+ ); + + my $sql = qq|
+SELECT + CHRONICLE.id as $f{'id'}, + CHRONICLE.title as $f{'title'}, + CHRONICLE.channel_id as $f{'channel'}, + DATE_FORMAT(CHRONICLE.starttime, '%d.%m.%Y') as $f{'day'}, + DATE_FORMAT(CHRONICLE.starttime, '%H:%i') as $f{'start'}, + DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(CHRONICLE.starttime) + CHRONICLE.duration), '%H:%i') as $f{'stop'} +FROM CHRONICLE +ORDER BY CHRONICLE.starttime +|; + my $fields = fields($self->{dbh}, $sql); + my $erg = $self->{dbh}->selectall_arrayref($sql);
+ unshift(@$erg, $fields); + $console->table($erg); + + return 1; +} + +# ------------------ +sub search { +# ------------------ + my $self = shift; + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $quest = shift || return $console->err(gettext("No 'text' to search! Please use chrsearch 'text'")); + + $quest =~ s/\'/\./sg; + $quest =~ s/\+/\\\\\+/sg; + + my %f = (
+ 'id' => umlaute(gettext('Service')),
+ 'title' => umlaute(gettext('Title')),
+ 'subtitle' => umlaute(gettext('Subtitle')),
+ 'channel' => umlaute(gettext('Channel')),
+ 'day' => umlaute(gettext('Day')),
+ 'start' => umlaute(gettext('Start')),
+ 'stop' => umlaute(gettext('Stop'))
+ ); + + my $sql = qq|
+SELECT + CHRONICLE.id as $f{'id'}, + CHRONICLE.title as $f{'title'}, + CHRONICLE.channel_id as $f{'channel'}, + DATE_FORMAT(CHRONICLE.starttime, '%d.%m.%Y') as $f{'day'}, + DATE_FORMAT(CHRONICLE.starttime, '%H:%i') as $f{'start'}, + DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(CHRONICLE.starttime) + CHRONICLE.duration), '%H:%i') as $f{'stop'} +FROM CHRONICLE +WHERE CHRONICLE.title RLIKE ? +ORDER BY CHRONICLE.starttime +|; + my $fields = fields($self->{dbh}, $sql); + my $sth = $self->{dbh}->prepare($sql); + $sth->execute($quest) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_arrayref(); + unshift(@$erg, $fields); + $console->table($erg); + + return 1; +} + +# ------------------ +sub delete { +# ------------------ + my $self = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $items = shift || return $console->err(gettext("No ID to delete! Please use chrdelete 'id'")); + + my @ids = reverse sort{ $a <=> $b } split(/[^0-9]/, $items); + + my $sql = sprintf('DELETE FROM CHRONICLE WHERE id in (%s)', join(',' => ('?') x @ids)); + my $sth = $self->{dbh}->prepare($sql); + $sth->execute(@ids) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + + return 1; +} + +1; diff --git a/lib/XXV/MODULES/CONFIG.pm b/lib/XXV/MODULES/CONFIG.pm new file mode 100644 index 0000000..771b172 --- /dev/null +++ b/lib/XXV/MODULES/CONFIG.pm @@ -0,0 +1,283 @@ +package XXV::MODULES::CONFIG; + +use strict; + +use Tools; +use Locale::gettext; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'CONFIG', + Prereq => { + # 'Perl::Module' => 'Description', + }, + Description => gettext('This module edit, write and reconfigure the configuration.'), + Version => '0.01', + Date => '27.10.2004', + Author => 'xpix', + Level => 'admin', + Commands => { + configedit => { + description => gettext("Edit configuration 'sector'"), + short => 'ce', + callback => sub{ $obj->edit(@_) }, + }, + configwrite => { + description => gettext('Write configuration'), + short => 'cw', + callback => sub{ $obj->write(@_) }, + }, + configget => { + description => gettext("Get configuration from 'modname'"), + short => 'cg', + callback => sub{ $obj->get(@_) }, + }, + reconfigure => { + description => gettext('Reconfigure all Processes'), + short => 'cr', + callback => sub{ $obj->reconfigure(@_) }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the Configdata + $self->{config} = $attr{'-config'}; + + return $self; +} + +# ------------------ +sub menu { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $sector = shift || 0; + + my $ret = {}; + $ret->{title} = gettext("Preferences for XXV"); + $ret->{highlight} = $sector; + + my $mods = main::getModules; + foreach my $module (sort keys %{$mods}) { + my $name = $mods->{$module}->{MOD}->{Name}; + next unless(exists $obj->{config}->{$name}); + + $ret->{links}->{$name} = { + text => $name, + link => "?cmd=configedit&data=$name", + }; + } + $ret->{links}->{'reconfigure'} = { + text => gettext("Reconfigure"), + link => "?cmd=reconfigure", + }; + $ret->{links}->{'write'} = { + text => gettext("Write configuration"), + link => "?cmd=configwrite", + }; + + return $console->littlemenu($ret); +} + +# ------------------ +sub edit { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $sector = shift || 0; + my $data = shift || 0; + + $obj->menu( $watcher, $console, $sector ) + if($console->{TYP} eq 'HTML' or ($console->{TYP} ne 'HTML' and not $sector)); + return unless $sector; + + $sector = uc($sector) unless($sector eq 'General'); + + my $cfg = $obj->{config}->{$sector} + or return $console->err(sprintf(gettext("Sorry, but the section %s does not exist in configuration!"),$sector)); + + my $mod = main::getModule($sector); + + my $prefs = $mod->{MOD}->{Preferences} + or return $console->err(sprintf(gettext("Sorry, but the 'Preferences' in Module: %s do not exist"),$sector)); + + my $questions = []; + foreach my $name (sort { lc($a) cmp lc($b) } keys(%{$prefs})) { + my $def = $prefs->{$name}->{default}; + $def = $cfg->{$name} + if(defined $cfg->{$name} && $cfg->{$name} ne ""); + push(@$questions, $name, + { + typ => $prefs->{$name}->{type} || 'string', + options => $prefs->{$name}->{options}, + msg => sprintf("%s:\n%s", ucfirst($name), ($prefs->{$name}->{description} || gettext('No Description'))), + def => $def, + req => $prefs->{$name}->{required}, + choices => $prefs->{$name}->{choices}, + check => $prefs->{$name}->{check}, + readonly => $prefs->{$name}->{readonly} || 0, + } + ); + } + + $console->link({text => sprintf(gettext('%s manual'), $sector), url => "?cmd=doc&data=$sector"}) + if($console->typ eq 'HTML'); + + $cfg = $console->question(sprintf(gettext('Change %s configuration'), $sector), $questions, $data); + + if(ref $cfg eq 'HASH') { + $obj->{config}->{$sector} = $cfg; + $obj->reconfigure(); + $obj->write(); + + debug sprintf('Config Section "%s" is changed and saved%s', + $sector, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + $console->message(sprintf(gettext("Sector: '%s' save .. please wait."), $sector)); + $console->redirect({url => $console->{browser}->{Referer}, wait => 2}) + if($console->typ eq 'HTML'); + } +} + +# ------------------ +sub write { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + + $obj->reconfigure($watcher, $console); + my $configfile = main::getUsrConfigFile; + + $obj->{config}->write( $configfile ) + or return error( sprintf ("Can't written '%s': %s", $configfile , $! )); + $console->message(sprintf gettext("Configuration written in '%s'."), $configfile) + if(ref $console); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 1}) + if(ref $console and $console->typ eq 'HTML'); +} + +# ------------------ +sub get { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $modname = shift || 0; + + return $console->err(gettext('I need a name of the module, in order to indicate the configuration!')) + unless($modname and ref $console); + + $modname = uc($modname) unless($modname eq 'General'); + + my $cfg = $obj->{config}->{$modname}; + + $console->err(sprintf(gettext("Sorry, but the section %s does not exist in configuration!"),$modname)) + if(! $cfg and ref $console); + + if(ref $console) { + return $console->table($cfg); + } else { + return $cfg; + } +} + +# ------------------ +sub reconfigure { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + + my $cfg = $obj->{config}; + foreach my $moduleName (keys %$cfg) { + if($moduleName eq 'General') { + main::reconfigure(); + } else { + my $mod = main::getModule($moduleName) + or (error("$moduleName does not exist!") && next); + foreach my $parameter (keys %{$mod->{MOD}->{Preferences}}) { + if(defined $mod->{$parameter}) { + $cfg->{$moduleName}->{$parameter} = $mod->{MOD}->{Preferences}->{$parameter}->{default} + if(not defined $cfg->{$moduleName}->{$parameter}); + $mod->{$parameter} = $cfg->{$moduleName}->{$parameter}; + + # Check this input + if(my $check = $mod->{MOD}->{Preferences}->{$parameter}->{check}) { + if(ref $check eq 'CODE') { + my ($ok, $err) = &$check($mod->{$parameter}); + unless($ok || not $err) { + my $message = sprintf("Config -> %s -> %s: %s %s", $moduleName, $parameter, $mod->{$parameter}, $err); + if(ref $console) { + $console->err($message); + } else { + error $message; + } + } + } + } + + } else { + $console->err(sprintf(gettext("Strange, i can not find %s in %s"), $parameter, $moduleName)) + if(ref $console); + } + } + } + } + + $obj->menu( $watcher, $console ) + if(ref $console and $console->{TYP} eq 'HTML'); + $console->message(gettext('Reconfigure successfully')) + if(ref $console); +} + +# ------------------ +sub realModNames { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $mods = main::getModules(); + my @realModName; + + # Search for command and display the Description + foreach my $modName (sort keys %{$mods}) { + my $modCfg = $mods->{$modName}->{MOD}; + push(@realModName, $mods->{$modName}->{MOD}->{Name}) + if(exists $mods->{$modName}->{MOD}->{Name}); + } + + return sort @realModName; +} + + +1; diff --git a/lib/XXV/MODULES/EPG.pm b/lib/XXV/MODULES/EPG.pm new file mode 100644 index 0000000..6ad8107 --- /dev/null +++ b/lib/XXV/MODULES/EPG.pm @@ -0,0 +1,1243 @@ +package XXV::MODULES::EPG;
+use strict;
+
+use Tools;
+use File::Basename;
+use Locale::gettext;
+
+
+# This module method must exist for XXV
+# ------------------
+sub module {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $args = {
+ Name => 'EPG',
+ Prereq => {
+ 'Date::Manip' => 'date manipulation routines',
+ 'Time::Local' => 'efficiently compute time from local and GMT time ',
+ },
+ Description => gettext('This module reads new EPG Data and stores them in the database.'),
+ Version => '0.92', + Date => '2007-06-03',
+ Author => 'xpix',
+ Status => sub{ $obj->status(@_) },
+ Preferences => {
+ epgimages => {
+ description => gettext('Location of additional EPG images.'),
+ default => '/var/cache/vdr/epgimages',
+ type => 'dir',
+ },
+ interval => {
+ description => gettext('How often EPG data are to be analyzed (in seconds)'),
+ default => 60 * 60,
+ type => 'integer',
+ required => gettext('This is required!'),
+ },
+ periods => {
+ description => gettext("Pre-defined list for the 'Running Now' view (comma separated list)"),
+ default => '12:00,18:00,20:15,22:00',
+ type => 'string',
+ required => gettext('This is required!'),
+ },
+ timeframe => {
+ description => gettext("How much hours to display in schema"),
+ default => 2,
+ type => 'integer',
+ required => gettext('This is required!'),
+ },
+ },
+ Commands => {
+ search => {
+ description => gettext('Search in EPG Data'),
+ short => 's',
+ callback => sub{ $obj->search(@_) },
+ },
+ program => {
+ description => gettext("List program for channel 'channel name'"),
+ short => 'p',
+ callback => sub{ $obj->program(@_) },
+ },
+ display => {
+ description => gettext("Show program event 'eventid'"),
+ short => 'd',
+ callback => sub{ $obj->display(@_) },
+ },
+ now => {
+ description => gettext('Display events is running now'),
+ short => 'n',
+ callback => sub{ $obj->runningNow(@_) },
+ },
+ next => {
+ description => gettext('Display events is running next'),
+ short => 'nx',
+ callback => sub{ $obj->runningNext(@_) },
+ },
+ schema => {
+ description => gettext('Display events in a schematic way'),
+ short => 'sch',
+ callback => sub{ $obj->schema(@_) },
+ },
+ erestart => {
+ description => gettext('Reload EPG data'),
+ short => 'er',
+ callback => sub{
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+
+ debug sprintf('Start reload EPG data%s',
+ ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ );
+
+ $obj->startReadEpgData($watcher,$console);
+ },
+ Level => 'admin',
+ },
+ erun => {
+ description => gettext('Display the epg event running in vdr'),
+ short => 'en',
+ callback => sub{ $obj->NowOnChannel(@_) },
+ Level => 'user', + DenyClass => 'remote', + },
+ conflict => {
+ hidden => 'yes',
+ callback => sub{ $obj->checkOnTimer(@_) },
+ },
+ edescription => {
+ hidden => 'yes',
+ short => 'ed',
+ callback => sub { $obj->getDescription(@_) }, + }, + esuggest => { + hidden => 'yes',
+ callback => sub{ $obj->suggest(@_) }, + }, + },
+ };
+ return $args;
+}
+
+# ------------------
+sub status {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift;
+ my $console = shift;
+ my $lastReportTime = shift || 0;
+ + my $total = 0; + my $newEntrys = 0;
+ + { + my $sth = $obj->{dbh}->prepare("select count(*) as count from EPG"); + if(!$sth->execute()) + { + error sprintf("Can't execute query: %s.",$sth->errstr); + } else { + my $erg = $sth->fetchrow_hashref(); + $total = $erg->{count} if($erg && $erg->{count});
+ } + }
+ + { + my $sth = $obj->{dbh}->prepare("select count(*) as count from EPG where UNIX_TIMESTAMP(addtime) > ?"); + if(!$sth->execute($lastReportTime)) + { + error sprintf("Can't execute query: %s.",$sth->errstr); + } else { + my $erg = $sth->fetchrow_hashref(); + $newEntrys = $erg->{count} if($erg && $erg->{count});
+ } + } +
+ return {
+ message => sprintf(gettext('EPG table contains %d entries and since the last login at %s %d new entries'),
+ $total, scalar localtime($lastReportTime), $newEntrys),
+ };
+}
+
+# ------------------
+sub new {
+# ------------------
+ my($class, %attr) = @_;
+ my $self = {};
+ bless($self, $class);
+
+ # paths
+ $self->{paths} = delete $attr{'-paths'};
+
+ # who am I
+ $self->{MOD} = $self->module;
+
+ # all configvalues to $self without parents (important for ConfigModule)
+ map {
+ $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_};
+ $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_});
+ } keys %{$self->{MOD}->{Preferences}};
+
+ # Try to use the Requirments
+ map {
+ eval "use $_";
+ return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@);
+ } keys %{$self->{MOD}->{Prereq}};
+
+ # read the DB Handle
+ $self->{dbh} = delete $attr{'-dbh'};
+
+ # The Initprocess
+ $self->_init or return error('Problem to initialize module');
+
+ return $self;
+}
+
+# ------------------
+sub _init {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+
+ return 0, panic("Session to database is'nt connected")
+ unless($obj->{dbh});
+
+ # Look for table or create this table
+ foreach my $table (qw/EPG OLDEPG/) {
+ + # remove old table, if updated rows + tableUpdated($obj->{dbh},$table,14,1);
+ + my $version = main::getVersion;
+ $obj->{dbh}->do(qq|
+ CREATE TABLE IF NOT EXISTS $table (
+ eventid bigint unsigned NOT NULL default '0',
+ title text NOT NULL default '',
+ subtitle text default '',
+ description text,
+ channel_id varchar(100) NOT NULL default '',
+ starttime datetime NOT NULL default '0000-00-00 00:00:00',
+ duration int(11) NOT NULL default '0',
+ tableid tinyint(4) default 0,
+ image text default '',
+ version tinyint(3) default 0,
+ video varchar(100) default '',
+ audio varchar(255) default '',
+ addtime datetime NOT NULL default '0000-00-00 00:00:00',
+ vpstime datetime default '0000-00-00 00:00:00',
+ PRIMARY KEY (eventid),
+ INDEX (starttime),
+ INDEX (channel_id)
+ ) COMMENT = '$version'
+ |);
+ }
+ + $obj->{after_updated} = []; +
+ # Repair later Data ...
+ main::after(sub{ + $obj->{svdrp} = main::getModule('SVDRP'); + unless($obj->{svdrp}) { + panic ("Can't get modul SVDRP"); + return 0; + } + + $obj->startReadEpgData();
+
+ # Restart watcher every x hours
+ Event->timer(
+ interval => $obj->{interval},
+ prio => 6, # -1 very hard ... 6 very low
+ cb => sub{
+ lg sprintf('The read on epg data is restarted!');
+ $obj->startReadEpgData();
+ }, + );
+ return 1; + }, "EPG: Start read epg data and repair ...", 40);
+
+ return 1;
+}
+
+# ------------------
+sub startReadEpgData {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift;
+ my $console = shift;
+
+ my $waiter;
+ if(ref $console && $console->typ eq 'HTML') {
+ $waiter = $console->wait(gettext("Read EPG data ..."),0,1000,'no');
+ }
+
+ # Read data over SVDRP
+ my $vdata = $obj->{svdrp}->command('LSTE');
+ map {
+ $_ =~ s/^\d{3}.//;
+ $_ =~ s/[\r|\n]$//;
+ } @$vdata;
+ debug sprintf('The read on epg data start now!');
+
+
+ # Adjust waiter max value now.
+ $waiter->max(scalar @$vdata)
+ if(ref $console && ref $waiter);
+
+ $obj->moveOldEPGEntrys();
+
+ # Read file row by row
+ my $updated = $obj->compareEpgData($vdata,$watcher,$console,$waiter);
+
+ $obj->deleteDoubleEPGEntrys();
+ + $obj->updated() if($updated); +
+ # last call of waiter
+ $waiter->end() if(ref $waiter);
+
+ if(ref $console) {
+ $console->start() if(ref $waiter);
+ $console->message(sprintf(gettext("%d events in database updated."), $updated));
+
+ $console->redirect({url => $console->{browser}->{Referer}, wait => 2})
+ if($console->typ eq 'HTML');
+ }
+}
+ +# Routine um Callbacks zu registrieren und +# diese nach dem Aktualisieren der EPG Daten zu starten +# ------------------ +sub updated { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $cb = shift || 0; + my $log = shift || 0; + + if($cb) { + push(@{$obj->{after_updated}}, [$cb, $log]); + } else { + foreach my $CB (@{$obj->{after_updated}}) { + next unless(ref $CB eq 'ARRAY'); + lg $CB->[1] + if($CB->[1]); + &{$CB->[0]}() + if(ref $CB->[0] eq 'CODE'); + } + } +}
+# This Routine will compare data from epg.data
+# and EPG Database row by row
+# ------------------
+sub compareEpgData {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $vdata = shift || return error('No data');
+ my $watcher = shift;
+ my $console = shift;
+ my $waiter = shift;
+
+ my $changedData = 0;
+ my $updatedData = 0;
+ my $deleteData = 0;
+
+ # Second - read data
+ my $count = 0;
+
+ my $vdrData;
+ my $channel;
+ my $channelname;
+ while($count < scalar $vdata) {
+ ($vdrData,$channel,$channelname,$count) = $obj->readEpgData($vdata,$count);
+ last if(not $channel);
+
+ $waiter->next($count,undef, sprintf(gettext("Analyze channel '%s'"), $channelname))
+ if(ref $waiter);
+
+ # First - read database
+ my $sql = qq|select eventid, title, subtitle, length(description) as ldescription, duration, UNIX_TIMESTAMP(starttime) as starttime, UNIX_TIMESTAMP(vpstime) as vpstime, video, audio from EPG where channel_id = ? |; + my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($channel) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $db_data = $sth->fetchall_hashref('eventid');
+
+ lg sprintf( 'Compare EPG Database with data from vdr : %d / %d for channel %s', scalar keys %$db_data,scalar keys %$vdrData, $channel);
+ # Compare this Hashes
+ foreach my $eid (keys %{$vdrData}) {
+ my $row = $vdrData->{$eid};
+
+ # Exists in DB .. update
+ if(exists $db_data->{$eid}) {
+ # Compare fields
+ foreach my $field (qw/title subtitle ldescription duration starttime vpstime video audio/) {
+ next if(not exists $row->{$field} or not $row->{$field});
+ if((not exists $db_data->{$eid}->{$field})
+ or (not $db_data->{$eid}->{$field})
+ or ($db_data->{$eid}->{$field} ne $row->{$field})) {
+ $obj->replace($eid, $row);
+ $updatedData++;
+ last;
+ }
+ }
+ + # delete updated rows from hash
+ delete $db_data->{$eid}; +
+ } else {
+ # Not exists in DB .. insert
+ $obj->replace($eid, $row);
+ $changedData++;
+ }
+ }
+
+ # Delete unused EpgEntrys in DB
+ $deleteData += scalar keys %$db_data;
+ if(scalar keys %$db_data > 0) { + my $sth = $obj->{dbh}->prepare('DELETE FROM EPG WHERE eventid IN (?)'); + foreach my $eventid (keys %$db_data) { + if(!$sth->execute($eventid)) { + error sprintf("Can't execute query: %s.",$sth->errstr); + } + } + }
+ }
+ debug 'Finish .. %d events created, %d events replaced, %d events deleted', $changedData, $updatedData, $deleteData;
+
+ return ($changedData + $updatedData + $deleteData);
+}
+
+# ------------------
+sub moveOldEPGEntrys {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+
+ # Copy and delete old EPG Entrys
+ $obj->{dbh}->do('REPLACE INTO OLDEPG SELECT * FROM EPG WHERE (UNIX_TIMESTAMP(EPG.starttime) + EPG.duration) < UNIX_TIMESTAMP()');
+ $obj->{dbh}->do('DELETE FROM EPG WHERE (UNIX_TIMESTAMP(EPG.starttime) + EPG.duration) < UNIX_TIMESTAMP()');
+}
+
+# ------------------
+sub deleteDoubleEPGEntrys {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+
+ # Delete double EPG Entrys
+ my $erg = $obj->{dbh}->selectall_arrayref('SELECT eventid FROM EPG GROUP BY starttime, channel_id having count(*) > 1');
+ if(scalar @$erg > 0) { + lg sprintf('Repair data found %d wrong events!', scalar @$erg);
+ my $sth = $obj->{dbh}->prepare('DELETE FROM EPG WHERE eventid = ?');
+ foreach my $row (@$erg) {
+ $sth->execute($row->[0]);
+ } + }
+}
+
+# ------------------
+sub replace {
+# ------------------
+ my $obj = shift || return error ('No Object!');
+ my $eventid = shift || return error ('No eventid to insert!');;
+ my $attr = shift || return error ('No data to insert!');
+
+ my $sth = $obj->{dbh}->prepare('REPLACE INTO EPG(eventid, title, subtitle, description, channel_id, duration, tableid, image, version, video, audio, starttime, addtime, vpstime) VALUES (?,?,?,?,?,?,?,?,?,?,?,FROM_UNIXTIME(?),FROM_UNIXTIME(?),FROM_UNIXTIME(?))');
+ $sth->execute(
+ $eventid,
+ $attr->{title},
+ $attr->{subtitle},
+ $attr->{description},
+ $attr->{channel},
+ $attr->{duration},
+ $attr->{tableid},
+ $attr->{image} || '',
+ hex($attr->{version}),
+ $attr->{video} || '1 01 deu 4:3',
+ $attr->{audio} || "2 03 deu stereo",
+ $attr->{starttime},
+ time,
+ $attr->{vpstime}
+ ) if($attr->{channel});
+}
+
+# ------------------
+sub encodeEpgId {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $epgid = shift || return error('No EPG Id!');
+ my $channel = shift || return error('No Channel!');
+
+ # look for NID-TID-SID for unique eventids (SID 0-30000 / TID 0 - 1000 / NID 0 - 10000
+ my @id = split('-', $channel);
+
+ # Make a fix format 0xCCCCEEEE : C-Channelid (high-word), E-Eventid(low-word) => real-eventid = uniqueid & FFFF
+ my $eventid = ((($id[-3] + $id[-2] + $id[-1]) & 0x3FFF) << 16) | ($epgid & 0xFFFF);
+
+ return $eventid;
+}
+
+# ------------------
+sub readEpgData {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $vdata = shift || return error('Problem to read Data!');
+ my $count = shift || 0;
+ my $dataHash = {};
+
+ my $cmod = main::getModule ('CHANNELS');
+ my $channels = $cmod->ChannelArray ('Id,Name');
+ my $channel;
+ my $channelname;
+ my $event;
+
+ #debug 'Read %d lines in EPG Database from %d', scalar @$vdata,$offset;
+ for(;$count < scalar (@$vdata);$count++) {
+ my $line = @{$vdata}[$count];
+
+ # Ok, Datarow complete...
+ if($line eq 'e' and $event->{eventid} and $event->{channel}) {
+ if(-e sprintf('%s/%d.png', $obj->{epgimages}, $event->{eventid})) {
+ my $firstimage = sprintf('%d.png',$event->{eventid});
+ $event->{image} = $firstimage."\n";
+ my $imgpath = sprintf('%s/%d_?.png',$obj->{epgimages},$event->{eventid});
+ foreach my $img (glob($imgpath)) {
+ $event->{image} .= sprintf("%s.png\n", basename($img, '.png'));
+ }
+ }
+
+ $channel = $event->{channel};
+ my $eventid = $obj->encodeEpgId($event->{eventid}, $channel);
+
+ $event->{title} = gettext("No Title")
+ unless($event->{title});
+ $event->{description} = ""
+ unless($event->{description});
+
+ %{$dataHash->{$eventid}} = %{$event};
+
+ $event = undef;
+ $event->{channel} = $channel;
+ next;
+ }
+ elsif($line eq 'c') {
+ # Finish this channel
+ return ($dataHash,$channel,$channelname,$count+1)
+ if(scalar keys %$dataHash);
+
+ undef $event->{channel};
+ undef $channel;
+ undef $channelname;
+ }
+
+ my ($mark, $data) = $line =~ /^(\S)\s+(.+)/g;
+ next unless($mark and $data);
+
+ # Next channel
+ if($mark eq 'C') {
+ if($channel) {
+ debug 'Missing channel endtag c at line %d',$count;
+ return ($dataHash,$channel,$channelname,$count) if(scalar keys %$dataHash);
+ }
+ undef $event->{channel};
+ my $channel = (split(/\s+/, $data))[0];
+ # import only known channels
+ foreach my $ch (@{$channels}) {
+ if($ch->[0] eq $channel) {
+ $event->{channel} = $channel;
+ $channelname = $ch->[1];
+ last;
+ }
+ }
+ } elsif($mark eq 'E') {
+ ($event->{eventid}, $event->{starttime}, $event->{duration}, $event->{tableid}, $event->{version}) = split(/\s+/, $data);
+ } elsif($mark eq 'T') {
+ $event->{title} = $data;
+ } elsif($mark eq 'S') {
+ $event->{subtitle} = $data;
+ } elsif($mark eq 'D') {
+ $event->{description} = $data;
+ $event->{description} =~ s/\|/\r\n/g; # pipe used from vdr as linebreak
+ $event->{description} =~ s/^\s+//; # no leading white space
+ $event->{description} =~ s/\s+$//; # no trailing white space
+ $event->{ldescription} = length($event->{description});
+ } elsif($mark eq 'X') {
+ my @d = split(/\s+/, $data);
+ if($d[0] eq '1') {
+ $event->{video} .= $data;
+ } else {
+ $event->{audio} .= $data."\n";
+ }
+ } elsif($mark eq 'V') {
+ $event->{vpstime} = $data;
+ }
+ }
+# debug 'Finish Read %d lines in EPG Database at %d', scalar @$vdata,$count;
+ return ($dataHash,$channel,$channelname,$count);
+}
+
+# ------------------
+sub search {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $data = shift;
+ my $params = shift;
+
+ my $tim = main::getModule('TIMERS');
+
+ # Textsearch
+ my $search;
+ if($data) {
+ if($params->{Where} && $params->{Where} eq 'title') {
+ $search = buildsearch("e.title",$data);
+ } elsif($params->{Where} && $params->{Where} eq 'titlesubtitle') {
+ $search = buildsearch("e.title,e.subtitle",$data);
+ } else {
+ $search = buildsearch("e.title,e.subtitle,e.description",$data);
+ }
+ }
+
+ # Channelsearch
+ if($params->{channel}) {
+ $search .= ' AND '
+ if($search);
+ $search .= sprintf('c.POS = %lu ', $params->{channel});
+ }
+
+ # Videoformat search
+ if($params->{Videoformat} && $params->{Videoformat} eq 'widescreen') {
+ $search .= ' AND '
+ if($search);
+ $search .= 'e.video like "%%16:9%%" ';
+ }
+
+ # Audioformat search
+ # XXX: Leider kann man an den Audioeintrag nicht richtig erkennnen
+ # hab erst zu spät erkannt das diese Info aus dem tvm2vdr kommen ;(
+# if($params->{Audioformat} eq 'dts') {
+# $search .= ' AND '
+# if($search);
+# $search .= 'e.audio like "%%Digital%%" ';
+# }
+
+ # MinLength search
+ if($params->{MinLength}) {
+ $search .= ' AND '
+ if($search);
+ $search .= sprintf('e.duration >= %d ', ($params->{MinLength}*60));
+ }
+
+
+ my $erg = [];
+ if($search) {
+ my $sql = qq|
+ select
+ e.eventid as Service,
+ e.title as Title,
+ e.subtitle as __Subtitle,
+ c.Name as Channel,
+ c.POS as __Pos,
+ DATE_FORMAT(e.starttime, '%H:%i') as Start,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(e.starttime) + e.duration), '%H:%i') as Stop,
+ UNIX_TIMESTAMP(e.starttime) as Day,
+ e.description,
+ IF(e.vpstime!=0,DATE_FORMAT(e.vpstime, '%H:%i'),'') as __VPS
+ from
+ EPG as e,
+ CHANNELS as c
+ where
+ e.channel_id = c.Id
+ AND ( $search )
+ order by
+ starttime
+ |;
+ #dumper($sql);
+ my $fields = fields($obj->{dbh}, $sql);
+
+ $erg = $obj->{dbh}->selectall_arrayref($sql);
+ unshift(@$erg, $fields);
+ }
+ $console->table($erg, {
+ timers => $tim->getEpgIds,
+ runningTimer => $tim->getRunningTimer('eventid'),
+ }
+ );
+}
+
+# ------------------
+sub program {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $channel = shift || $obj->{dbh}->selectrow_arrayref("select POS from CHANNELS limit 1")->[0];
+
+ my $mod = main::getModule('CHANNELS');
+ my $tim = main::getModule('TIMERS');
+
+ my $cid;
+ if($channel =~ /^\d+$/sig) {
+ $cid = $mod->PosToChannel($channel)
+ or return $console->err(sprintf(gettext("This channel '%s' does not exist in the database!"),$channel));
+ } else {
+ $cid = $mod->NameToChannel($channel)
+ or return $console->err(sprintf(gettext("This channel '%s' does not exist in the database!"),$channel));
+ }
+
+ my $sql = qq|
+select
+ e.eventid as Service,
+ e.title as Title,
+ e.subtitle as __Subtitle,
+ DATE_FORMAT(e.starttime, '%H:%i') as Start,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(e.starttime) + e.duration), '%H:%i') as Stop,
+ UNIX_TIMESTAMP(e.starttime) as Day,
+ e.description as __Description,
+ e.video as __Video,
+ e.audio as __Audio,
+ IF(e.vpstime!=0,DATE_FORMAT(e.vpstime, '%H:%i'),'') as __VPS
+from
+ EPG as e, CHANNELS as c
+where
+ e.channel_id = c.Id and
+ e.channel_id = ?
+order by
+ starttime
+|;
+ my $fields = fields($obj->{dbh}, $sql);
+ my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($cid) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_arrayref();
+ unshift(@$erg, $fields);
+
+ $console->table($erg, {
+ channels => $mod->ChannelArray('Name'),
+ current => $mod->ChannelToPos($cid),
+ timers => $tim->getEpgIds,
+ runningTimer => $tim->getRunningTimer('eventid'),
+ }
+ );
+}
+
+# ------------------
+sub display {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $eventid = shift || return $console->err(gettext("No EventID to display the Event Programm! Please use display 'eventid'"));
+
+ my %f = (
+ 'Id' => umlaute(gettext('Service')),
+ 'Title' => umlaute(gettext('Title')),
+ 'Subtitle' => umlaute(gettext('Subtitle')),
+ 'Channel' => umlaute(gettext('Channel')),
+ 'Start' => umlaute(gettext('Start')),
+ 'Stop' => umlaute(gettext('Stop')),
+ 'Description' => umlaute(gettext('Description')),
+ 'Percent' => umlaute(gettext('Percent')),
+ );
+
+ my $fields;
+ my $erg;
+
+ my $start = "e.starttime";
+ my $stopp = "FROM_UNIXTIME(UNIX_TIMESTAMP(e.starttime) + e.duration)";
+ my $vps = "e.vpstime";
+
+ $start = "UNIX_TIMESTAMP(e.starttime)" if($console->typ eq "HTML");
+ $stopp = "UNIX_TIMESTAMP(e.starttime) + e.duration" if($console->typ eq "HTML");
+ $vps = "UNIX_TIMESTAMP(e.vpstime)" if($console->typ eq "HTML");
+
+ foreach my $table (qw/EPG OLDEPG/) {
+ my $sql = qq|
+select
+ e.eventid as $f{'Id'},
+ e.title as $f{'Title'},
+ e.subtitle as $f{'Subtitle'},
+ $start as $f{'Start'},
+ $stopp as $f{'Stop'},
+ c.Name as $f{'Channel'},
+ e.description as $f{'Description'},
+ e.image as __Image,
+ (unix_timestamp(e.starttime) + e.duration - unix_timestamp())/duration*100 as $f{'Percent'},
+ e.video as __Video,
+ e.audio as __Audio,
+ IF(e.vpstime!=0,$vps,'') as __VPS
+from
+ $table as e,CHANNELS as c
+where
+ e.channel_id = c.Id
+ and eventid = ?
+|;
+ $fields = fields($obj->{dbh}, $sql);
+ my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($eventid) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + $erg = $sth->fetchall_arrayref();
+
+ last
+ if(scalar @{$erg} != 0 );
+ }
+
+ return $console->err(sprintf(gettext("No data for event '%d' present to display!"),$eventid))
+ if(scalar @{$erg} == 0 );
+
+ unshift(@$erg, $fields);
+
+ my $tim = main::getModule('TIMERS');
+ $console->table($erg,{timers => $tim->getEpgIds});
+}
+
+# ------------------
+sub runningNext {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $data = shift;
+ my $param = shift || {};
+ my $cgroups = main::getModule('CHANNELS')->ChannelGroupsArray('Name');
+ my $cgrp = $param->{cgrp} || $cgroups->[0][1]; # Erster GroupEintrag
+
+ # Create temporary table
+ $obj->{dbh}->do(qq|
+CREATE TEMPORARY TABLE IF NOT EXISTS NEXTEPG (
+ channel_id varchar(100) NOT NULL default '',
+ nexttime datetime NOT NULL default '0000-00-00 00:00:00'
+ )
+|);
+ # Remove old data
+ $obj->{dbh}->do('delete from NEXTEPG');
+
+ # Get channelid and starttime of next broadcasting
+ my $sqltemp = qq|
+INSERT INTO NEXTEPG select
+ c.Id as channel_id,
+ MIN(e.starttime) as nexttime
+ FROM EPG as e, CHANNELS as c
+ WHERE e.channel_id = c.Id
+AND UNIX_TIMESTAMP(e.starttime) > UNIX_TIMESTAMP(NOW())
+AND c.GRP = ?
+
+GROUP BY c.Id
+|;
+ my $sthtemp = $obj->{dbh}->prepare($sqltemp);
+ $sthtemp->execute($cgrp) + or return error sprintf("Can't execute query: %s.",$sthtemp->errstr); +
+ my %f = (
+ 'Service' => umlaute(gettext('Service')),
+ 'Title' => umlaute(gettext('Title')),
+ 'Channel' => umlaute(gettext('Channel')),
+ 'Start' => umlaute(gettext('Start')),
+ 'Stop' => umlaute(gettext('Stop'))
+ );
+ my $sql =
+qq|
+select
+ e.eventid as $f{'Service'},
+ e.title as $f{'Title'},
+ e.subtitle as __Subtitle,
+ c.Name as $f{'Channel'},
+ c.POS as __POS,
+ g.Name as __Channelgroup,
+ DATE_FORMAT(e.starttime, "%H:%i") as $f{'Start'},
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(starttime) + e.duration), "%H:%i") as $f{'Stop'},
+ e.description as __Description, + 999 as __Percent,
+ IF(e.vpstime!=0,DATE_FORMAT(e.vpstime, '%H:%i'),'') as __VPS +FROM
+ EPG as e, CHANNELS as c, NEXTEPG as n, CHANNELGROUPS as g
+WHERE
+ e.channel_id = c.Id
+ AND n.channel_id = c.Id
+ AND c.GRP = g.Id
+ AND e.starttime = n.nexttime
+ AND c.GRP = ?
+ORDER BY
+ c.POS|;
+ my $fields = fields($obj->{dbh}, $sql);
+ my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($cgrp) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_arrayref();
+ unshift(@$erg, $fields);
+
+ my $tim = main::getModule('TIMERS');
+
+ $console->table($erg,
+ {
+ timers => $tim->getEpgIds,
+ runningTimer => $tim->getRunningTimer('eventid'),
+ periods => $obj->{periods},
+ cgroups => $cgroups,
+ channelgroup => $cgrp,
+ }
+ );
+}
+
+# ------------------
+sub runningNow {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $zeit = shift || time;
+ my $param = shift || {};
+ my $cgroups = main::getModule('CHANNELS')->ChannelGroupsArray('Name');
+ my $cgrp = $param->{cgrp} || $cgroups->[0][1]; # Erster GroupEintrag
+
+ # i.e.: 635 --> 06:35
+ $zeit = fmttime($zeit)
+ if(length($zeit) <= 4);
+
+ # i.e.: 06:35 --> timeinsecs
+ if($zeit =~ /^\d+:\d+$/sig) {
+ $zeit = UnixDate(ParseDate($zeit),"%s") || time;
+ }
+
+ $zeit += 86400 if($zeit < time);
+ $zeit++;
+
+ my %f = (
+ 'Service' => umlaute(gettext('Service')),
+ 'Title' => umlaute(gettext('Title')),
+ 'Channel' => umlaute(gettext('Channel')),
+ 'Start' => umlaute(gettext('Start')),
+ 'Stop' => umlaute(gettext('Stop')),
+ 'Percent' => umlaute(gettext('Percent')),
+ );
+ my $sql =
+qq|
+select
+ e.eventid as $f{'Service'},
+ e.title as $f{'Title'},
+ e.subtitle as __Subtitle,
+ c.Name as $f{'Channel'},
+ c.POS as __POS,
+ g.Name as __Channelgroup,
+ DATE_FORMAT(e.starttime, "%H:%i") as $f{'Start'},
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(starttime) + e.duration), "%H:%i") as $f{'Stop'},
+ e.description as __Description,
+ (unix_timestamp(e.starttime) + e.duration - unix_timestamp())/e.duration*100 as $f{'Percent'},
+ IF(e.vpstime!=0,DATE_FORMAT(e.vpstime, '%H:%i'),'') as __VPS
+FROM
+ EPG as e, CHANNELS as c, CHANNELGROUPS as g
+WHERE
+ e.channel_id = c.Id
+ AND c.GRP = g.Id
+ AND ? BETWEEN UNIX_TIMESTAMP(e.starttime)
+ AND (UNIX_TIMESTAMP(e.starttime) + e.duration)
+ AND c.GRP = ?
+ORDER BY
+ c.POS|;
+
+ my $fields = fields($obj->{dbh}, $sql);
+ my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($zeit, $cgrp) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_arrayref(); + unshift(@$erg, $fields);
+
+ my $tim = main::getModule('TIMERS');
+ $console->table($erg,
+ {
+ timers => $tim->getEpgIds,
+ runningTimer => $tim->getRunningTimer('eventid'),
+ zeit => $zeit,
+ periods => $obj->{periods},
+ cgroups => $cgroups,
+ channelgroup => $cgrp,
+ }
+ );
+}
+
+# ------------------
+sub NowOnChannel {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $channel = shift || $obj->_actualChannel || return error('No Channel!');
+ my $zeit = time;
+
+ my $sql =
+qq|
+select
+ e.eventid as Service,
+ e.title as Title,
+ e.subtitle as Subtitle,
+ c.Name as Channel,
+ c.POS as POS,
+ e.video as __video,
+ e.audio as __audio,
+ DATE_FORMAT(e.starttime, "%a %d.%m") as StartDay,
+ DATE_FORMAT(e.starttime, "%H:%i") as StartTime,
+ (unix_timestamp(e.starttime) + e.duration - unix_timestamp())/e.duration*100 as __Percent,
+ e.description as Description,
+ IF(e.vpstime!=0,DATE_FORMAT(e.vpstime, '%H:%i'),'') as __VPS
+FROM
+ EPG as e, CHANNELS as c
+WHERE
+ e.channel_id = c.Id
+ AND ? BETWEEN UNIX_TIMESTAMP(e.starttime)
+ AND (UNIX_TIMESTAMP(e.starttime) + e.duration)
+ AND c.POS = ?
+ORDER BY
+ starttime
+LIMIT 1
+|;
+#dumper($sql); + my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($zeit, $channel) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchrow_hashref();
+
+ if(ref $console) {
+ return $console->table($erg);
+ } else {
+ return $erg;
+ }
+}
+
+# ------------------
+sub _actualChannel {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+
+ my $erg = $obj->{svdrp}->command('chan');
+ my ($chanpos, $channame) = $erg->[1] =~ /^250\s+(\d+)\s+(\S+)/sig;
+ return $chanpos;
+}
+
+# ------------------
+sub schema {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $zeit = shift || time;
+ my $param = shift || {};
+
+
+ # i.e.: 635 --> 06:35
+ $zeit = fmttime($zeit)
+ if(length($zeit) <= 4);
+
+ # i.e.: 06:35 --> timeinsecs
+ if($zeit =~ /^\d+:\d+$/sig) {
+ $zeit = UnixDate(ParseDate($zeit),"%s") || time;
+ }
+
+ $zeit += 86400 if($zeit < time - ($obj->{timeframe} * 3600));
+ $zeit++;
+ my $zeitvon = $obj->toFullHour($zeit);
+
+ my $zeitbis = $zeitvon + ($obj->{timeframe}*3600);
+ my $cgroups = main::getModule('CHANNELS')->ChannelGroupsArray('Name');
+ my $cgrp = $param->{cgrp} || $cgroups->[0][1]; # Erster GroupEintrag
+
+ my $sql =
+qq|
+select
+ e.eventid as Service,
+ e.title as Title,
+ e.subtitle as __Subtitle,
+ c.Name as Channel,
+ c.POS as __POS,
+ DATE_FORMAT(e.starttime, "%H:%i") as Start,
+ DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(starttime) + e.duration), "%H:%i") as Stop,
+ (unix_timestamp(e.starttime) + e.duration - unix_timestamp())/e.duration*100 as Percent,
+ e.description as __Description,
+ UNIX_TIMESTAMP(starttime) as second_start,
+ UNIX_TIMESTAMP(starttime) + e.duration as second_stop,
+ e.video as __video,
+ e.audio as __audio,
+ e.image as __image
+FROM
+ EPG as e, CHANNELS as c
+WHERE
+ e.channel_id = c.Id
+ AND
+ (
+ ( UNIX_TIMESTAMP(e.starttime) >= ? AND UNIX_TIMESTAMP(e.starttime) <= ? )
+ OR
+ ( UNIX_TIMESTAMP(e.starttime) + e.duration >= ? AND UNIX_TIMESTAMP(e.starttime) + e.duration <= ? )
+ OR
+ ( UNIX_TIMESTAMP(e.starttime) <= ? AND UNIX_TIMESTAMP(e.starttime) + e.duration >= ? )
+ )
+ AND
+ c.GRP = ?
+ORDER BY
+ c.POS,e.starttime
+|;
+
+ my $fields = fields($obj->{dbh}, $sql); + my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($zeitvon,$zeitbis,$zeitvon,$zeitbis,$zeitvon,$zeitbis,$cgrp) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_arrayref();
+
+ my $data = {};
+ foreach my $c (@$erg) {
+ push(@{$data->{$c->[4]}}, $c);
+ }
+
+ my $tim = main::getModule('TIMERS');
+ $console->table($data,
+ {
+ timers => $tim->getEpgIds,
+ runningTimer => $tim->getRunningTimer('eventid'),
+ zeitvon => $zeitvon,
+ zeitbis => $zeitbis,
+ periods => $obj->{periods},
+ cgroups => $cgroups,
+ channelgroup => $cgrp,
+ HouresProSite => $obj->{timeframe}
+ }
+ );
+}
+
+# ------------------
+sub checkOnTimer {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $eid = shift || return error('No Id');
+ my $tim = main::getModule('TIMERS');
+
+ my $sql = qq|
+SELECT
+ e.starttime as NextStartTime,
+ ADDDATE(e.starttime, INTERVAL e.duration SECOND) as NextStopTime,
+ LEFT(c.Source,1) as source,
+ c.TID as transponderid
+FROM
+ EPG as e, CHANNELS as c
+WHERE
+ e.eventid = ?
+ and
+ e.channel_id = c.Id
+|; + + my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($eid) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $data = $sth->fetchrow_hashref();
+ my $erg = $tim->checkOverlapping($data) || ['ok'];
+ my $tmod = main::getModule('TIMERS');
+ # Zeige den Title des Timers
+ foreach (@$erg) {
+ $_ = $tmod->getTimerById((split(':', $_))[0])->{File}
+ unless($_ eq 'ok');
+ }
+
+ $console->message(join(',',@$erg))
+ if(ref $console);
+
+}
+ +# ------------------
+sub getDescription {
# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $eid = shift || 0;
+ + my $event = $obj->getId($eid,"description"); + + $console->message($event && $event->{description} ? $event->{description} : "")
+ if(ref $console);
+}
+
+# ------------------
+sub toFullHour {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $zeit = shift || return error ('No Time to convert!' );
+
+ my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
+ localtime($zeit);
+ my $retzeit = timelocal(0, 0, $hour, $mday, $mon, $year);
+ return $retzeit;
+}
+
+
+# ------------------
+sub getId {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $id = shift || return error ('No Id!' );
+ my $fields = shift || '*';
+ + foreach my $table (qw/EPG OLDEPG/) {
+ # EPG
+ my $sql = sprintf('select %s from %s WHERE eventid = ?',$fields, $table); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($id) + or return error "Can't execute query: $sth->errstr."; + + my $erg = $sth->fetchrow_hashref();
+ return $erg
+ if($erg); + }
+ debug("Event %d not exist!", $id); + return {};
+} + +# ------------------
+sub suggest {
# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $search = shift; + my $params = shift; + + if($search) { + my $ch = ''; + if($params->{channel}) { + $ch = " AND c.POS = ? "; + } + + my $sql = qq| + SELECT
+ e.title as title
+ FROM + EPG as e,
+ CHANNELS as c + WHERE + channel_id = c.Id + AND ( e.title LIKE ? )
+ $ch
+ GROUP BY + title +UNION + SELECT
+ e.subtitle as title
+ FROM + EPG as e,
+ CHANNELS as c + WHERE + channel_id = c.Id + AND ( e.subtitle LIKE ? )
+ $ch
+ GROUP BY + title +ORDER BY + title +LIMIT 25 + |;
+ my $sth = $obj->{dbh}->prepare($sql); + if($params->{channel}) { + $sth->execute('%'.$search.'%',$params->{channel},'%'.$search.'%',$params->{channel}) + or return error "Can't execute query: $sth->errstr."; + } else { + $sth->execute('%'.$search.'%','%'.$search.'%') + or return error "Can't execute query: $sth->errstr."; + } + my $result = $sth->fetchall_arrayref();
+ $console->table($result)
+ if(ref $console && $result); + } +}
+
+1;
diff --git a/lib/XXV/MODULES/EVENTS.pm b/lib/XXV/MODULES/EVENTS.pm new file mode 100644 index 0000000..23b94b6 --- /dev/null +++ b/lib/XXV/MODULES/EVENTS.pm @@ -0,0 +1,190 @@ +package XXV::MODULES::EVENTS; +use strict; + +use Tools; +use Locale::gettext; +use File::Basename; +use File::Find; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'EVENTS', + Prereq => { + 'Data::Dumper' => 'stringified perl data structures, suitable for both printing and eval', + }, + Description => gettext( +"This module manage the events for control and watch the xxv system. +An additional Loghandler is installed and parse every Message. If +a defined Event exists and match the keywords defined in +Module->RegEvent->SearchForEvent then call the Loghandler 'callEvent'. +This sub look in Module->RegEvent->Actions, and call this Routines. +"), + Version => '0.92', + Date => '2007-01-28', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + }, + Commands => { +# list => { +# description => gettext('Display the event list'), +# short => 'el', +# callback => sub{ $obj->list(@_) }, +# Level => 'user', +# }, +# eedit => { +# description => gettext('Edit a event'), +# short => 'ee', +# callback => sub{ $obj->edit(@_) }, +# Level => 'user', +# }, +# etoogle => { +# description => gettext('Change a event on or off'), +# short => 'eto', +# callback => sub{ $obj->toogle(@_) }, +# Level => 'user', +# }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + $self->{Trenner} = "\n#-- NextSub --#\n"; + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + main::after(sub{ + $obj->{EVENTS} = $obj->searchForEvents(); + # This will add a callback for log events (ignore verbose) + $Tools::LOGCALLB = sub{ + $obj->callEvent(@_); + }; + return 1; + }, "EVENTS: Look for event entrys in modules ...", 3); + + return 1; +} + +# ------------------ +sub searchForEvents { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $mods = main::getModules(); + my $events = {}; + foreach my $modname (keys %$mods) { + if(exists $mods->{$modname}->{MOD}->{RegEvent} + and my $re = $mods->{$modname}->{MOD}->{RegEvent} + ) { + foreach my $rname (keys %$re) { + my $options = $re->{$rname}; + $options->{Grp} = (split(/::/, $modname))[-1]; + $events->{$rname} = $options; + } + } + } + return $events; +} + +# ------------------ +sub callEvent { +# ------------------ + my $obj = shift || return error ('No Object in callEvent!' ); + my $args = { + 'Mod' => shift, + 'Sub' => shift, + 'Msg' => shift, + }; + return unless(exists $obj->{EVENTS}); + return if($obj->{active} ne 'y'); + + foreach my $id (keys %{$obj->{EVENTS}}) { + my $entry = $obj->{EVENTS}->{$id}; + my $bool = 0; + + # Search for right fields + next unless(exists $entry->{SearchForEvent}); + for my $sType (keys %{$entry->{SearchForEvent}}) { + my $sValue = $entry->{SearchForEvent}->{$sType}; + $bool++ if(index($args->{$sType}, $sValue) > -1); + } + next unless($bool >= scalar keys %{$entry->{SearchForEvent}}); + + # Search for Matchtext + my $MatchVar = {}; + if(exists $entry->{Match}) { + $bool = 0; + for my $mName (keys %{$entry->{Match}}) { + my $mRegex = $entry->{Match}->{$mName}; + $MatchVar->{$mName} = $1 + if($args->{Msg} =~ $mRegex); + $bool = 1 if($MatchVar->{$mName}); + } + next unless($bool); + } + + # Call the Actions + if(exists $entry->{Actions}) { + for my $action (@{$entry->{Actions}}) { + my $callback; + my $code = sprintf('$callback = %s;', $action); + eval($code); + if($@) { + error($@); + next; + } + my $erg = &$callback($MatchVar, $entry) + if(ref $callback eq 'CODE'); + } + } + } + + return 1; +} +1; diff --git a/lib/XXV/MODULES/GRAB.pm b/lib/XXV/MODULES/GRAB.pm new file mode 100644 index 0000000..d421203 --- /dev/null +++ b/lib/XXV/MODULES/GRAB.pm @@ -0,0 +1,290 @@ +package XXV::MODULES::GRAB; +use strict; + +use Tools; +use Locale::gettext; +use File::Basename; +use File::Find; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'GRAB', + Prereq => { + 'GD' => 'image manipulation routines', + 'Template' => 'Front-end module to the Template Toolkit ', + }, + Description => gettext('This module grab a picture from livestream.'), + Version => '0.01', + Date => '06.09.2004', + Author => 'xpix', + Preferences => { + xsize => { + description => gettext('Image width'), + default => 320, + type => 'integer', + required => gettext('This is required!'), + }, + ysize => { + description => gettext('Image height'), + default => 240, + type => 'integer', + required => gettext('This is required!'), + }, + file => { + description => gettext('Location where the grabbed image file will be stored'), + default => '/tmp/live.jpg', + type => 'file', + }, + imgtext => { + description => gettext('Text to display in the grabbed picture.'), + default => "[?- i = channel.split(' ') -?][[? i.shift ?]] [? i.join(' ') ?]", + type => 'string', + }, + vpos => { + description => gettext('Vertical position of displayed text, in pixels.'), + default => 10, + type => 'integer', + }, + font => { + description => gettext('True type font to draw image text.'), + default => 'VeraIt.ttf', + type => 'list', + choices => $obj->findttf, + }, + imgfontsize => { + description => gettext('Font size to draw image text (only for ttf font!).'), + default => 10, + type => 'integer', + }, + imgquality => { + description => gettext('Quality from image in percent.'), + default => 80, + type => 'integer', + }, + }, + Commands => { + grab => { + description => gettext('Grab a picture'), + short => 'gr', + callback => sub{ $obj->grab(@_) }, + Level => 'user', + DenyClass => 'remote', + }, + gdisplay => { + description => gettext('Display the picture'), + short => 'gd', + callback => sub{ $obj->display(@_) }, + Level => 'user', + DenyClass => 'remote', + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # create Template object + $self->{tt} = Template->new( + START_TAG => '\[\?', # Tagstyle + END_TAG => '\?\]', # Tagstyle + INTERPOLATE => 1, # expand "$var" in plain text + PRE_CHOMP => 1, # cleanup whitespace + EVAL_PERL => 1, # evaluate Perl code blocks + ); + + $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + main::after(sub{ + $obj->{svdrp} = main::getModule('SVDRP'); + unless($obj->{svdrp}) { + panic ("Can't get modul SVDRP"); + return 0; + } + return 1; + }, "GRAB: Init module ..."); + return 1; +} + +# ------------------ +sub grab { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $file = $obj->{file}; + my $erg; + + if(main::getVdrVersion() >= 10338) { + + # command for get inline data (JPEG BASE64 coded) + my $cmd = sprintf('grab - %d %d %d', + $obj->{imgquality}, + $obj->{xsize}, + $obj->{ysize}, + ); + + my $data = $obj->{svdrp}->command($cmd); + my $uu = [ grep(/^216-/, @$data) ]; + foreach (@{$uu}) { s/^216-//g; } + + if(scalar @{$uu} <= 0) { + # None data with 216-, maybe svdrp message contain reason + $erg = $data; + } elsif(!open(F, ">$file")) { + # Open failed + $erg = sprintf("Can't write to file %s : %s",$file,$!); + } else { + # uudecode data to file + binmode(F); + foreach (@{$uu}) { print F MIME::Base64::decode_base64($_); } + close F; + } + } else { + + if(-e $file) { + unlink($file) || error("Can't remove '%s' : %s",$file,$!); + } + # the command + my $cmd = sprintf('grab %s jpeg %d %d %d', + $obj->{file}, + $obj->{imgquality}, + $obj->{xsize}, + $obj->{ysize}, + ); + + $erg = $obj->{svdrp}->command($cmd); + } + # Make imgtext + $file = $obj->makeImgText($file, $obj->{imgtext}) + if($obj->{imgtext} && -s $file); + + $console->msg($erg, $obj->{svdrp}->err) + if(ref $console); + return $file; +} + +# ------------------ +sub display { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my $file = $obj->grab(); + if(-s $file) { # Datei existiert und hat eine Grösse von mehr als 0 Bytes + $console->{nocache} = 1; + return $console->image($file); + } else { + error("Can't locate file : $file, maybe grabbing was failed"); + return 0; + } +} + +# ------------------ +sub makeImgText { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $file = shift || $obj->{file} || return error ('No File to display'); + my $text = shift || $obj->{imgtext} || return error ('No Text to display'); + + my $im; + if(int(${GD::VERSION}) >= 2.0) { + $im = GD::Image->newFromJpeg($file, 1) || return error("Can't read $file $!"); + } else { + $im = GD::Image->newFromJpeg($file) || return error("Can't read $file $!"); + } + my $color = $im->colorClosest(255,255,255); + my $shadow = $im->colorClosest(0,0,0); + + + # XXX: Hier sollten noch mehr Informationen dazu kommen + my $channeltext = main::getModule('REMOTE')->switch(); + my $channelpos = (split(' ', $channeltext))[0]; + my $vars = { + channel => $channeltext, + event => main::getModule('EPG')->NowOnChannel($watcher, $console, $channelpos), + }; + + my $output = ''; + $obj->{tt}->process(\$text, $vars, \$output) + or return error($obj->{tt}->error()); + + my $font = sprintf("%s/%s",$obj->{paths}->{FONTPATH},$obj->{font}); + if($obj->{paths}->{FONTPATH} and $obj->{font} and -r $font) { + $im->stringFT($shadow,$font,$obj->{imgfontsize},0,11,($obj->{vpos}-1),$output); + $im->stringFT($color,$font,$obj->{imgfontsize},0,10,($obj->{vpos}),$output); + } else { + # Schatten + $im->string(&gdGiantFont,11, ($obj->{vpos}-1),$output,$shadow); + # Text + $im->string(&gdGiantFont,10, ($obj->{vpos}),$output,$color); + } + + my $img_data = $im->jpeg($obj->{imgquality}); + my @f = split('\.', $file); + my $newfile = ($file =~ 'text' ? $file : sprintf('%s_text.%s', @f)); + save_file($newfile, $img_data); + return $newfile; +} + +# ------------------ +sub findttf +# ------------------ +{ + my $obj = shift || return error ('No Object!' ); + my $found; + find({ wanted => sub{ + if($File::Find::name =~ /\.ttf$/sig) { + my $l = basename($File::Find::name); + push(@{$found},[$l,$l]); + } + }, + follow => 1, + follow_skip => 2, + }, + $obj->{paths}->{FONTPATH} + ); + error "Can't find useful font at : ", $obj->{paths}->{FONTPATH} + if(scalar $found == 0); + return $found; +} + +1; diff --git a/lib/XXV/MODULES/HTTPD.pm b/lib/XXV/MODULES/HTTPD.pm new file mode 100644 index 0000000..3efbf83 --- /dev/null +++ b/lib/XXV/MODULES/HTTPD.pm @@ -0,0 +1,588 @@ +package XXV::MODULES::HTTPD; + +use Locale::gettext; +use XXV::OUTPUT::Html; +use XXV::OUTPUT::Ajax; +use File::Basename; +use File::Find; + +use Tools; + +$| = 1; + +use strict; + +my $mime = { + png => "image/png", + gif => "image/gif", + jpg => "image/jpeg", + css => "text/css", + ico => "image/x-icon", + js => "application/x-javascript", + m3u => "audio/x-mpegurl", + rss => "application/xhtml+xml", + avi => "video/avi", + mp4 => "video/mp4", + mpg => "video/x-mpeg", + mpeg => "video/x-mpeg", + mov => "video/quicktime", + wmv => "video/x-ms-wmv", + flv => "video/x-flv" +}; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'HTTPD', + Prereq => { + 'IO::Socket::INET' => 'Object interface for AF_INET domain sockets ', + 'MIME::Base64' => 'Encoding and decoding of base64 strings', + 'CGI qw/:push -nph -no_xhtml -compile/' + => 'Simple Common Gateway Interface Class', + 'Compress::Zlib' => 'Interface to zlib compression library. ', + }, + Description => gettext('This module is a multisession HTTPD server.'), + Version => '0.92', + Date => '2007-01-21', + Author => 'xpix', + Status => sub{ $obj->status(@_) }, + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + Clients => { + description => gettext('Maximum number from simultaneous connections to the same time'), + default => 5, + type => 'integer', + required => gettext('This is required!'), + }, + Port => { + description => gettext('Number of port to listen for http clients'), + default => 8080, + type => 'integer', + required => gettext('This is required!'), + }, + Interface => { + description => gettext('Local interface to bind service'), + default => '0.0.0.0', + type => 'host', + required => gettext('This is required!'), + }, + HtmlRoot => { + description => gettext('Used Skin'), + default => 'default', + type => 'list', + required => gettext('This is required!'), + choices => sub{ return $obj->findskins }, + }, + StartPage => { + description => gettext('First page, which is to be seen when logon'), + default => 'now', + type => 'list', + required => gettext('This is required!'), + choices => [ + [ gettext('Schema'), 'schema'], + [ gettext('Running now'), 'now'], + [ gettext('Program guide'), 'program'], + [ gettext('Autotimer'), 'alist'], + [ gettext('Timers'), 'tlist'], + [ gettext('Recordings'), 'rlist'], + [ gettext('Music'), 'mlist'], + [ gettext('Remote'), 'remote'], + [ gettext('Teletext'), 'vtxpage'], + [ gettext('Status'), 'sa'], + ], + }, + Debug => { + description => gettext('Dump additional debugging information, needed only for software development.'), + default => 'n', + type => 'confirm', + }, + }, + Commands => { + checkvalue => { + hidden => 'yes', + callback => sub{ $obj->checkvalue(@_) }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + $self->init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + # globals + my $channels; + + $obj->{STATUS}->{'starttime'} = scalar localtime; + + # make socket + my $socket = IO::Socket::INET->new( + Listen => $obj->{Clients}, + LocalPort => $obj->{Port}, + LocalAddr => $obj->{Interface}, + Reuse => 1 + ) or return error("Can't create Socket: $!"); + + # install an initial watcher + Event->io( + fd => $socket, + prio => -1, # -1 very hard ... 6 very low + cb => sub { + # accept client + my $client=$socket->accept; + panic "Can't connect http to new client." and return unless $client; + $client->autoflush; + + # make "channel" number + my $channel=++$channels; + + $obj->{STATUS}->{'connects'}++; + + # install a communicator + Event->io( + fd => $client, + prio => -1, # -1 very hard ... 6 very low + poll => 'r', + cb => sub { + my $watcher = shift; + $obj->communicator($watcher); + } + ); + }, + ) if($obj->{active} eq 'y'); + + return 1; +} + +sub communicator +{ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!' ); + + # read new line and report it + my $handle=$watcher->w->fd; + + my $data = $obj->parseRequest($handle,(defined $obj->{LOGOUT} && $obj->{LOGOUT} == 1 )); + unless($data) { + undef $obj->{LOGOUT}; + $watcher->w->cancel; + $handle->close(); + undef $watcher; + return 1; + } + undef $obj->{LOGOUT} + if(exists $obj->{LOGOUT}); + + my $ip = getip($handle); + my $htmlRootDir = sprintf('%s/%s', $obj->{paths}->{HTMLDIR}, $obj->{HtmlRoot}); + my $htmlDefDir = sprintf('%s/%s', $obj->{paths}->{HTMLDIR}, 'default'); + + my $query = $data->{Query}; + if($data->{Method} eq 'POST' && $data->{Post}) { + $query .= '&' if($query); + $query .= $data->{Post}; + } + my $cgi = CGI->new( $query ); + + my $console; + if(my $outputtype = $cgi->param('ajax')) { + # Is a Ajax Request + $console = XXV::OUTPUT::Ajax->new( + -handle => $handle, + -cgi => $cgi, + -browser=> $data, + -output => $outputtype, + -debug => ($obj->{Debug} eq 'y' ? 1 : 0), + + ); + } else { + # Is a Html Request + $console = XXV::OUTPUT::Html->new( + -handle => $handle, + -dbh => $obj->{dbh}, + -htmdir => $htmlRootDir, + -htmdef => $htmlDefDir, + -cgi => $cgi, + -mime => $mime, + -browser=> $data, + -paths => $obj->{paths}, + -start => $obj->{StartPage}, + -debug => ($obj->{Debug} eq 'y' ? 1 : 0), + ); + } + + my $userMod = main::getModule('USER'); + if(ref $userMod and $userMod->{active} eq 'y') { + $console->{USER} = $userMod->check($handle, $data->{username}, $data->{password}); + $console->login(gettext('You have no permissions to this system!')) + unless(exists $console->{USER}->{Level}); + } + + if(ref $userMod and + ($userMod->{active} ne 'y' + or exists $console->{USER}->{Level})) { + + $console->{call} = 'nothing'; + if(($data->{Request} eq '/' or $data->{Request} =~ /\.html$/) and not $data->{Query}) { + # Send the first page (index.html) + my $page = $data->{Request}; + if($page eq '/') { + if(-r sprintf('%s/index.tmpl', $htmlRootDir)) { + $console->index; + } else { + $console->datei(sprintf('%s/index.html', $htmlRootDir)); + } + } else { + $console->datei(sprintf('%s%s', $htmlRootDir, $page)); + } + } elsif(my $typ = $mime->{lc((split('\.', $data->{Request}))[-1])}) { + # Send multimedia files (this must registered in $mime!) + if($data->{Request} =~ /epgimages\//) { + my $epgMod = main::getModule('EPG'); + $data->{Request} =~ s/.*epgimages\//$epgMod->{epgimages}\//; + $console->datei($data->{Request}, $typ); + } elsif($data->{Request} =~ /previewimages\//) { + my $recMod = main::getModule('RECORDS'); + $data->{Request} =~ s/.*previewimages\//$recMod->{previewimages}\//; + $console->datei($data->{Request}, $typ); + } elsif($data->{Request} =~ /coverimages\//) { + my $musicMod = main::getModule('MUSIC'); + $data->{Request} =~ s/.*coverimages\//$musicMod->{coverimages}\//; + $console->datei($data->{Request}, $typ); + } elsif($data->{Request} =~ /vtximages\//) { + my $vtxMod = main::getModule('VTX'); + $data->{Request} =~ s/.*vtximages\//$obj->{paths}->{VTXPATH}\//; + $console->datei($data->{Request}, $typ); + } elsif($data->{Request} =~ /tempimages\//) { + my $tmp = $userMod->userTmp; + $data->{Request} =~ s/.*tempimages\//$tmp\//; + $console->datei($data->{Request}, $typ); + } else { + $console->datei(sprintf('%s%s', $htmlRootDir, $data->{Request}), $typ); + } + } elsif( $cgi->param('binary') ) { + # Send multimedia files (if param binary) + $obj->handleInput($watcher, $console, $cgi); + } else { + $obj->handleInput($watcher, $console, $cgi); + $console->footer() unless($console->typ eq 'AJAX' or $console->{noFooter}); + } + + } + $console->printout(); + + # make entry more readable + $data->{Query} =~ s/%([a-f0-9][a-f0-9])/pack("C", hex($1))/ieg + if($data->{Query}); + $data->{Referer} =~ s/%([a-f0-9][a-f0-9])/pack("C", hex($1))/ieg + if($data->{Referer}); + # Log like Apache Format ip, resolved hostname, user, request, status, bytes, referer, useragent + lg sprintf('%s - %s "%s%s" %s %s "%s" "%s"', + $ip, + $data->{username} ? $data->{username} : "-", + $data->{Request} ? $data->{Request} : "", + $data->{Query} ? "?" . $data->{Query} : "", + $console->{'header'}, + $console->{'sendbytes'}, + $data->{Referer} ? $data->{Referer} : "-", + "-" #$data->{http_useragent} ? $data->{http_useragent} : "" + ); + + $obj->{STATUS}->{'sendbytes'} += $console->{'sendbytes'}; + $watcher->w->cancel; + undef $watcher; +} + +# ------------------ +sub _readline { +# ------------------ + my $fh = $_[0]; + my $c=''; + my $line=''; + my $eof=0; + + while ($c ne "\n" && ! $eof) { + if (sysread($fh, $c, 1) > 0) { + $line = $line . $c; + } else { + $eof=1; + } + } + return $line; +} +# ------------------ +sub parseRequest { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $socket = shift || return error ('No Handle!' ); + my $logout = shift || 0; + + binmode $socket; + my $data = {}; + my $line; + while (defined($line = &_readline($socket))) { + if(!$line || $line =~ /^\r\n$/) { + last; + } elsif(!$data->{Method} && $line =~ /^(\w+) (\/[\w\.\/\-\:\%]*)([\?[\w=&\.\+\%-\:\!]*]*)[\#\d ]+HTTP\/1.\d/) { + ($data->{Method}, $data->{Request}, $data->{Query}) = ($1, $2, $3 ? substr($3, 1, length($3)) : undef); + } elsif($line =~ /Referer: (.*)/) { + $data->{Referer} = $1; + $data->{Referer} =~ s/(\r|\n)//g; + } elsif($line =~ /Host: (.*)/) { + $data->{HOST} = $1; + $data->{HOST} =~ s/(\r|\n)//g; + } elsif($line =~ /Authorization: basic (.*)/i and not $logout) { + ($data->{username}, $data->{password}) = split(":", MIME::Base64::decode_base64($1), 2); + } elsif($line =~ /User-Agent: (.*)/i) { + $data->{http_useragent} = $1; + $data->{http_useragent} =~ s/(\r|\n)//g; + } elsif($line =~ /Accept-Encoding:.+?gzip/i) { + $data->{accept_gzip} = 1; + } elsif($line =~ /If-None-Match: (\S+)/i) { + $data->{Match} = $1; + } elsif($line =~ /Cookie: (\S+)=(\S+)/i) { + $data->{$1} = $2; + } elsif($line =~ /Content-Type: (\S+)/i) { + $data->{ContentType} = $1; + } elsif($line =~ /Content-Length: (\S+)/i) { + $data->{ContentLength} = $1; + } else { + #dumper($line); + } + } + + $data->{Request} =~ s/%([a-f0-9][a-f0-9])/pack("C", hex($1))/ieg + if($data->{Request}); + if($data->{Method} eq 'GET') { + #dumper($data); + return $data; + } elsif($data->{Method} eq 'POST') { + if(int($data->{ContentLength})>0) { + my $post; + my $bytes = sysread($socket,$post,$data->{ContentLength}); + $data->{Post} = $post + if($bytes && $data->{ContentLength} == $bytes); + } + #dumper($data); + return $data; + } else { + return undef; + } + +} + +# ------------------ +sub handleInput { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $cgi = shift || return error ('No CGI Object'); + + my $ucmd = $cgi->param('cmd') || '<undef>'; + my $udata = $cgi->param('data') || ''; + + # Set the referer, if come a form with a error + # then patch the referer + $console->{browser}->{Referer} = $cgi->param('referer') + if($cgi->param('referer')); + + # Test on result set (user has save) and + # get the DataVars in a special Hash + my $result; + foreach my $name ($cgi->param) { + if(my ($n) = $name =~ /^__(.+)/sig) { + my @vals = $cgi->param($name); + if(scalar @vals > 1) { + @{$result->{$n}} = @vals; + } else { + $result->{$n} = shift @vals; + } + } + } + + # Test the command on exists, permissions and so on + my $u = main::getModule('USER'); + my ($cmdobj, $cmdname, $shorterr, $err) = $u->checkCommand($console, $ucmd); + $console->{call} = $cmdname; + if($cmdobj and not $shorterr) { + $console->{CMDSTAT} = $cmdobj->{callback}($watcher, $console, $udata, $result ); + } elsif($shorterr eq 'noperm' or $shorterr eq 'noactive') { + $console->status403($err); + $console->{CMDSTAT} = undef; + } else { + $obj->usage($watcher, $console, undef, $err); + $console->{CMDSTAT} = undef; + } +} + +# ------------------ +sub usage { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return main::getModule('TELNET')->usage(@_); +} + +# ------------------ +sub status { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift || return; + my $lastReportTime = shift || 0; + + return { + message => sprintf(gettext('Traffic on HTTPD Socket since %s: send: %d kbytes - received: %d kbytes - connects: %d'), + $obj->{STATUS}->{'starttime'}, convert($obj->{STATUS}->{'sendbytes'}), convert($obj->{STATUS}->{'readbytes'}), $obj->{STATUS}->{'connects'} ), + }; + +} + +# ------------------ +sub findskins +# ------------------ +{ + my $obj = shift || return error ('No Object!' ); + my $found; + find({ wanted => sub{ + if(-d $File::Find::name + and ( -e $File::Find::name.'/index.tmpl' + or -e $File::Find::name.'/index.html') + ) { + my $l = basename($File::Find::name); + push(@{$found},[$l,$l]); + } + }, + follow => 1, + follow_skip => 2, + }, + $obj->{paths}->{HTMLDIR} + ); + error "Can't find useful HTML Skin at : $obj->{paths}->{HTMLDIR}" + if(scalar $found == 0); + return sort { lc($a->[0]) cmp lc($b->[0]) } @{$found}; +} + +# ------ unzip ------------ +# Name: unzip +# Desc: Uncompress Files in gz format +# Usag: my $res = $obj->unzip(file.gz); +# Test: my $res = $obj->unzip('t/abc.gz'); +# return 1 if(load_file($res) eq 'abc'); +# ------ unzip ------------ +sub unzip { + my $obj = shift || return error ('No Object'); + my $file = shift || return error ('No File'); + + my $gz = gzopen($file, "rb") + or return $obj->msg(undef, sprintf(gettext("can't open file '%s' : %s"), $file, &gzerror )); + + my $text; + while($gz->gzread(my $buffer) > 0) { + $text .= $buffer; # nothing + } + + $gz->gzclose(); + + my $tmpfile = sprintf('%s/gz_%d.tmp', main::getModule('USER')->userTmp, time); + + return save_file($tmpfile, $text); +} + + +# ------------------ +# Callback for ajax, to check for right values in HTML Widget +# supported : +# isdir:/tmp +# isfile:/bla/foobar +# getip:localhost +sub checkvalue { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $data = shift || return error ('No Data!' ); + + my @query = split(':',$data); + my $check = $query[0]; + shift @query; + my $value = join(':',@query); + + my $erg; + # e.g. isdir:/tmp + if($check eq "isdir") { + if(-d $value) { + $erg = "SUCCESS: directory found."; + } else { + $erg = "ERROR: directory not found."; + } + # e.g. isfile:/bla/foobar + } elsif($check eq "isfile") { + if(-r $value) { + $erg = "SUCCESS: file found."; + } else { + $erg = "ERROR: file not found."; + } + # e.g. getip:localhost + } elsif($check eq "getip") { + my $aton = inet_aton($value); + if($aton) { + $erg = inet_ntoa($aton); + } else { + $erg = "ERROR: host does not exist."; + } + # Unknown query + } else { + $erg = "ERROR: Query : " . $check . " not supported."; + } + + return $console->msg($erg) + if(ref $console); +} + + +1; diff --git a/lib/XXV/MODULES/INTERFACE.pm b/lib/XXV/MODULES/INTERFACE.pm new file mode 100644 index 0000000..b468dac --- /dev/null +++ b/lib/XXV/MODULES/INTERFACE.pm @@ -0,0 +1,179 @@ +package XXV::MODULES::INTERFACE; + +use Locale::gettext; +use XXV::OUTPUT::Dump; +use Tools; + + +use strict; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'INTERFACE', + Prereq => { + 'IO::Socket::INET' => 'Object interface for AF_INET domain sockets ', + "SOAP::Lite" => 'Client and server side SOAP implementation', + "SOAP::Transport::HTTP" => 'Server/Client side HTTP support for SOAP::Lite', + "SOAP::Transport::HTTP::Event" => 'Server/Client side HTTP support for SOAP::Lite', + }, + Description => gettext('This module is a multichannel soap server for second party software.'), + Version => '0.01', + Date => '06.09.2004', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + LocalPort => { + description => gettext('Number of port to listen for soap clients'), + default => 8082, + type => 'integer', + required => gettext('This is required!'), + }, + Interface => { + description => gettext('Local interface to bind service'), + default => '0.0.0.0', + type => 'host', + required => gettext('This is required!'), + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_} || ''; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + $self->init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + if($obj->{active} eq 'y') { + + # Install the SOAP Server + my $daemon = SOAP::Transport::HTTP::Event + -> new ( + LocalAddr => $obj->{Interface}, + LocalPort => $obj->{LocalPort}, + ) + -> dispatch_to('SOAPService'); + + debug("Install the SOAP server at %s", $daemon->url); + my ($sock, $httpd) = $daemon->getDaemon(); + + Event->io( + fd => $sock, + prio => -1, # -1 very hard ... 6 very low + cb => sub { + $daemon->handle($sock, $httpd); + } + ); + } + + return 1; + +} + + +1; + +BEGIN { + + package SOAPService; + + use vars qw(@ISA); +# @ISA = qw(Exporter SOAP::Server::Parameters); + use SOAP::Lite; + use Tools; + + # ------------------ + # Name: getCommand + # Descr: Call every commands. + # Usage: my $data = $obj->getCommand($cmd, [$data, $params]); + # ------------------ + sub getCommand { + my $obj = shift || return error ('No Object!' ); + my $cmd = shift || return error ('No Command!' ); + my $data = shift; + + my $ret = $obj->handleInput($cmd, $data); + return $ret; + } + + # ------------------ + sub handleInput { + # ------------------ + my $obj = shift || return error ('No Object!' ); + my $ucmd = shift || return error ('No Command'); + my $udata = shift; + + my $watcher = $obj; + + my $console = XXV::OUTPUT::Dump->new(); + $console->{USER}->{Name} = undef; + $console->{USER}->{Level} = 'admin'; + $console->{USER}->{value} = 10; + + # Test the command on exists, permissions and so on + my $u = main::getModule('USER'); + my ($cmdobj, $cmdname, $shorterr, $err) = $u->checkCommand($console, $ucmd); + $console->{call} = $cmdname; + if($cmdobj and not $shorterr) { + my @ret = $cmdobj->{callback}($watcher, $console, $udata); + return \@ret; + } elsif($shorterr eq 'noperm' or $shorterr eq 'noactive') { + return $console->err($err); + } else { + return $obj->usage($watcher, $console, undef, $err); + } + } + + # ------------------ + sub usage { + # ------------------ + my $obj = shift || return error ('No Object!' ); + return main::getModule('TELNET')->usage(@_); + } + +} # End BEGIN + +1; diff --git a/lib/XXV/MODULES/LOGREAD.pm b/lib/XXV/MODULES/LOGREAD.pm new file mode 100644 index 0000000..88a0a7c --- /dev/null +++ b/lib/XXV/MODULES/LOGREAD.pm @@ -0,0 +1,221 @@ +package XXV::MODULES::LOGREAD; + +use strict; + +use Tools; +use Locale::gettext; +use XXV::OUTPUT::HTML::PUSH; + +$|++; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'LOGREAD', + Prereq => { + # 'Perl::Module' => 'Description', + }, + Description => gettext('This module read the xxv log file and show it on console.'), + Version => '0.01', + Date => '17.09.2005', + Author => 'xpix', + Level => 'admin', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + tail => { + description => sprintf(gettext("Path of command '%s'"),'tail'), + default => '/usr/bin/tail', + type => 'file', + required => gettext('This is required!'), + }, + rows => { + description => gettext('How much lines to display?'), + default => '100', + type => 'integer', + required => gettext('This is required!'), + }, + syslog => { + description => gettext('Path of syslog file?'), + default => '/var/log/syslog', + type => 'file', + required => gettext('This is required!'), + }, + }, + Commands => { + logger => { + description => gettext("Display the last log entries"), + short => 'lg', + callback => sub{ $obj->logger(@_) }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + return $self; +} + +# ------------------ +sub logger { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $logname = shift || 'standard'; + my $params = shift || {}; + + $obj->{logfiles} = { + main => { + # Path to logfile + logfile => $obj->{paths}->{LOGFILE}, + #24 (14870) [22:29:08 09/22/05] CHANNELS: Read and register Channels ... + # Regular expression for every loglines + regex => qr/^(\d+)\s+\((\d+)\)\s+\[(\d+\-\d+\-\d+ \d+\:\d+\:\d+)\]\s+(.+?)$/s, + # Fields List for describe the rows + fields => [qw/Nr Typ Time Message/], + # Callback for coloring rows + display=> sub{ + my $typ = $_[0][1]; + return 'black' if($typ < 200); + return 'green' if($typ < 300); + return 'blue' if($typ < 400); + return 'brown' if($typ < 500); + return 'red' if($typ >= 500); + }, + # Maximum letters for truncate in template + maxlet=> 50, + }, + syslog => { + logfile => $obj->{syslog}, + #Sep 23 00:35:01 vdr /USR/SBIN/CRON[16971]: (root) CMD (/usr/bin/weatherng.sh) + regex => qr/^(.+?)\s+(\d+)\s+(\d+\:\d+\:\d+)\s+(.+?)\s+(.+)/s, + fields => [qw/Month MDay Time Prg Message/], + display=> sub{ + my $txt = $_[0][-1]; + return 'red' if($txt =~ /ERROR/si); + return 'blue' if($txt =~ /WARNING/si); + return 'green' if($txt =~ /INFO/si); + return 'black'; + }, + maxlet=> 80, + }, + }; + + if( ! ref $obj->{logfiles}->{$logname}) { + return $console->err(sprintf("The log with the name %s does not exist! Please use '%s'!", $logname, join("' or '", keys %{$obj->{logfiles}}))); + } + + my $logfile = $obj->{logfiles}->{$logname}->{logfile}; + my @out = $obj->tail($logfile); + + return $console->msg(undef, sprintf(gettext("Can't read log file %s!"), $logfile)) + unless(scalar @out); + + my $output = $obj->parseLogOutput($obj->{logfiles}->{$logname}, \@out); + + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) + = stat($logfile); + + $console->table($output, { + type => $logname, + logfile => $logfile, + Size => convert($size), + LastChanged => scalar localtime($mtime), + full => $params->{full}, + color => $obj->{logfiles}->{$logname}->{display}, + maxlet => $obj->{logfiles}->{$logname}->{maxlet}, + }); + return 1; +} + +# ------------------ +sub tail { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $logfile = shift || return error ('No Logfile!' ); + my $rows = shift || $obj->{rows}; + + my $cmd = sprintf('%s --lines=%d %s', $obj->{tail}, $rows, $logfile); + my @out = (`$cmd`); + return @out; +} + + +# ------------------ +sub parseLogOutput { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $log = shift || return error ('No Prefs for logfile!' ); + my $out = shift || return; + + my $regex = $log->{regex}; + $obj->{logbuf} = undef; + + my $ret = []; + foreach my $line (@$out) { + if(my @d = $line =~ $regex) { + $obj->parseData($ret, \@d) if($d[0]); + } else { + $obj->parseData($ret, $line); + } + } + my @r = reverse @$ret; + + unshift(@r, $log->{fields}); + return \@r; +} + +# ------------------ +sub parseData { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $ret = shift || return error('No Referenced Array'); + my $data = shift || 0; + + + if(ref $data eq 'ARRAY') { # Set Data + $data->[-1] .= $obj->{logbuf} + if($obj->{logbuf}); + push(@$ret, $data); + $obj->{logbuf} = undef; + } elsif($data) { # Message (last row, last item) .+ $line + $obj->{logbuf} .= $data; + } + return $ret; +} + +1; diff --git a/lib/XXV/MODULES/MEDIALIB.pm b/lib/XXV/MODULES/MEDIALIB.pm new file mode 100644 index 0000000..5cf20b6 --- /dev/null +++ b/lib/XXV/MODULES/MEDIALIB.pm @@ -0,0 +1,1328 @@ +package XXV::MODULES::MEDIALIB; + +use strict; + +use Tools; +use Locale::gettext; +use Data::Dumper; +use File::Path; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $args = { + Name => 'MEDIALIB', + Prereq => { + 'Digest::MD5' => 'Perl interface to the MD5 Algorithm', + 'LWP::Simple' => 'simple procedural interface to LWP', + 'LWP::UserAgent' => 'simple procedural interface to LWP', + }, + Description => gettext('This module manages media like DVDs, VCD, etc.'), + Version => '0.04', + Date => '2007-03-11', + Author => 'poetter', + Status => sub{ $obj->status(@_) }, + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + usecache => { + description => gettext('Cache images'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + libraryimagedir => { + description => gettext('Location of coverimages.'), + default => '/var/cache/xxv/libraryimages', + type => 'dir', + required => gettext("This is required!"), + }, + listcols => { + description => gettext('Number of columns in listview'), + default => 4, + type => 'integer', + required => gettext('This is required!'), + }, + actorcols => { + description => gettext('Number of columns of actors in detailview'), + default => 6, + type => 'integer', + required => gettext('This is required!'), + }, + deflanguage => { + description => gettext('Default media language'), + default => 'german', + type => 'string', + }, + defmediatype => { + description => gettext('Default mediatype'), + default => 1, + type => 'list', + choices => sub { + my $erg = $obj->_get_mediatype_as_array(); + map { my $x = $_->[1]; $_->[1] = $_->[0]; $_->[0] = $x; } @$erg; + return @$erg; + }, + }, + defrange => { + description => gettext('Default range'), + default => 'ABC', + type => 'list', + choices => sub { + my $erg = $obj->_get_ranges_as_array(); + map { my $x = $_->[1]; $_->[1] = $_->[0]; $_->[0] = $x; } @$erg; + return @$erg; + }, + }, }, + Commands => { + mllist => { + description => gettext('List medias'), + short => 'mll', + callback => sub{ $obj->listMedia(@_) }, + DenyClass => 'media', + }, + mldisplay => { + description => gettext('Display media'), + short => 'mld', + callback => sub{ $obj->displayMedia(@_) }, + DenyClass => 'media', + }, + mlnew => { + description => gettext('Create new media'), + short => 'mln', + callback => sub{ $obj->createMedia(@_) }, + DenyClass => 'media', + }, + mledit => { + description => gettext('Edit media'), + short => 'mle', + callback => sub{ $obj->editMedia(@_) }, + DenyClass => 'media', + }, + mlcopy => { + description => gettext('Copy media'), + short => 'mlc', + callback => sub{ $obj->copyMedia(@_) }, + DenyClass => 'media', + }, + mldelete => { + description => gettext('Delete media'), + short => 'mlt', + callback => sub{ $obj->deleteMedia(@_) }, + DenyClass => 'media', + }, + mlresearch => { + description => gettext('Research media'), + short => 'mlr', + callback => sub{ $obj->researchMedia(@_) }, + DenyClass => 'media', + }, + mlcache => { + description => gettext('Get image from media cache'), + short => 'mlca', + callback => sub{ $obj->mediacache(@_) }, + DenyClass => 'media', + }, + mlsave => { + description => gettext('Save media'), + short => 'mls', + callback => sub{ $obj->saveMedia(@_) }, + DenyClass => 'media', + }, + mlimport => { + description => gettext('Import media'), + short => 'mli', + callback => sub{ $obj->importMedia(@_) }, + DenyClass => 'media', + }, + mlsearch => { + description => gettext('Search media'), + short => 'mlse', + callback => sub{ $obj->searchMedia(@_) }, + DenyClass => 'media', + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return 0, panic("Session to database is'nt connected") + unless($obj->{dbh}); + + # don't remove old table, if updated rows => warn only + tableUpdated($obj->{dbh},'MEDIALIB_ACTORS',4,0); + tableUpdated($obj->{dbh},'MEDIALIB_VIDEODATA',33,0); + tableUpdated($obj->{dbh},'MEDIALIB_VIDEOGENRE',2,0); + + # Look for tables or create this tables + my $version = main::getVersion; + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS MEDIALIB_ACTORS ( + name varchar(255) NOT NULL default '', + actorid varchar(15) NOT NULL default '', + imgurl varchar(255) NOT NULL default '', + checked timestamp(14) NOT NULL, + PRIMARY KEY (name) + ) COMMENT = '$version' + |); + + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS MEDIALIB_VIDEODATA ( + id int(10) unsigned NOT NULL auto_increment, + md5 varchar(32) default NULL, + title varchar(255) default NULL, + subtitle varchar(255) default NULL, + language varchar(255) default NULL, + diskid varchar(15) default NULL, + comment varchar(255) default NULL, + disklabel varchar(32) default NULL, + imdbID varchar(15) default NULL, + year year(4) default NULL, + imgurl varchar(255) default NULL, + director varchar(255) default NULL, + actors text, + runtime int(10) unsigned default NULL, + country varchar(255) default NULL, + plot text, + filename varchar(255) default NULL, + filesize int(16) unsigned default NULL, + filedate datetime default NULL, + audio_codec varchar(255) default NULL, + video_codec varchar(255) default NULL, + video_width int(10) unsigned default NULL, + video_height int(10) unsigned default NULL, + istv tinyint(1) unsigned NOT NULL default '0', + lastupdate timestamp(14) NOT NULL, + seen tinyint(1) unsigned NOT NULL default '0', + mediatype int(10) unsigned NOT NULL default '0', + custom1 varchar(255) default NULL, + custom2 varchar(255) default NULL, + custom3 varchar(255) default NULL, + custom4 varchar(255) default NULL, + created datetime default NULL, + owner_id int(11) NOT NULL default '0', + PRIMARY KEY (id), + KEY seen (seen), + KEY title_idx (title), + KEY diskid_idx (diskid), + KEY mediatype (mediatype,istv), + FULLTEXT KEY actors_idx (actors), + FULLTEXT KEY comment (comment) + ) COMMENT = '$version' + |); + + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS MEDIALIB_VIDEOGENRE ( + video_id int(10) unsigned NOT NULL default '0', + genre_id int(10) unsigned NOT NULL default '0', + PRIMARY KEY (video_id,genre_id) + ) COMMENT = '$version' + |); + + unless(-d $obj->{libraryimagedir}) { + mkpath($obj->{libraryimagedir}) or error "Can't mkpath $obj->{libraryimagedir} : $!"; + lg sprintf('mkdir path "%s" ', + $obj->{coverimages}, + ); + } + + 1; +} + +# ------------------ +# Name: status +# Descr: Standardsubroutine to report statistical data for Report Plugin. +# Usage: my $report = $obj->status([$watcher, $console]); +# ------------------ +sub status { + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + + my $sql = qq| +SELECT + COUNT(id) +FROM + MEDIALIB_VIDEODATA +|; + + my $erg = $obj->{dbh}->selectrow_arrayref($sql); + return { + message => sprintf(gettext('Media Library has stored %d medias'), $erg->[0]), + }; + +} + +# ------------------ +sub researchMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $params = shift || {}; + + + if(ref $params eq 'HASH') { + + #print Dumper( $params ); + my $medias; + if ( $params->{source} eq 'dvdpalace' ) { + + eval "use MediaLibParser::DVDPalace"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + + my $mlp = MediaLibParser::DVDPalace->new( + 'lookup_result' => $params->{title}, + 'start_result' => defined $params->{start} ? $params->{start} : 0, + ); + + ( $medias, $params->{hitcount} ) = $mlp->result; + } + return $console->table($medias, $params); + } + +} + +# ------------------ +sub createMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $params = shift || 0; + + $obj->editMedia($watcher, $console, 0, $params); +} + +# ------------------ +sub copyMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $params = shift || 0; + + my $sql = qq| +SELECT + * +FROM + MEDIALIB_VIDEODATA +WHERE + id = ? +|; + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($id) + or return $console->err(sprintf(gettext("Media with ID '%s' does not exist in the database!"),$id)); + my $erg = $sth->fetchrow_hashref(); + delete $erg->{id}; + $erg->{range} = $params->{range} if($params && $params->{range}); + + $obj->editMedia($watcher, $console, 0, $erg); +} + +# ------------------ +sub importMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $params = shift || {}; + + #print Dumper($id, $params); + $id = delete $params->{id} if defined $params->{id}; + my $range = delete $params->{range} if defined $params->{range}; + + if ( ref $params && defined $params->{import} ) { + + if ( $params->{source} eq 'dvdpalace' ) { + eval "use MediaLibParser::DVDPalace"; + return panic("\nCan not load Module: MediaLibParser::DVDPalace") if($@); + + my $mlp = MediaLibParser::DVDPalace->new( + 'url_media' => $params->{import}, + ); + + $params = $mlp->media; + } + + $params->{id} = $id; + + #print Dumper('$params', $params); + if ( $params->{genres} ) { + my $gen_hash_1 = $obj->_get_videogenres_as_hash; + my $gen_hash_2 = { + 'Komödie' => 'Comedy', + 'Musik' => 'Music', + 'Musikfilm' => 'Music', + 'Kriegsfilm' => 'War', + 'Abenteuer' => 'Adventure', + 'Kinderfilm' => 'Childs', + 'Science Fiction' => 'Sci-Fi', + + # noch mit Genres auffuellen so wie sie auftauchen. + }; + #print Dumper('$gen_hash_1', $gen_hash_1); + #print Dumper('$gen_hash_2', $gen_hash_2); + my $ret; + foreach my $key ( @{$params->{genres}} ) { + #print Dumper('$key', $key); + if( defined $gen_hash_1->{$key} ) { + push (@$ret, $gen_hash_1->{$key}->{id}); + } elsif ( defined $gen_hash_2->{$key} ) { + foreach my $name ( keys %$gen_hash_1 ) { + push (@$ret, $gen_hash_1->{$name}->{id}) if $gen_hash_2->{$key} eq $gen_hash_1->{$name}->{name}; + } + } elsif ( $key =~ /TV-Serie/i ) { + $params->{istv} = 1; + } else { + debug ('Unknown genre: '. $key); + } + } + #print Dumper('$ret', $ret); + $params->{genres} = $ret; + } + + foreach my $key ( keys %$params ) { + $params->{$key} =~ s/\r\n/\n/g; + } + } + + $params->{mediatype} = $obj->{defmediatype} unless defined $params->{mediatype} && $params->{mediatype} != 0; + $params->{language} = $obj->{deflanguage} unless defined $params->{language} && $params->{language} ne ''; + + #print Dumper($params); + $console->table({}, + { + %$params, + mediatypes => $obj->_get_mediatype_as_array, + allgenres => $obj->_get_videogenres_as_array, + range => $range, + ranges => $obj->_get_ranges_as_array, + } + ); +} + +# ------------------ +sub searchMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $params = shift || {}; + #print Dumper($params); + my $erg = []; + my $setcount; + + if ( defined $params->{'search'} ) { + + my @wheres; + my ($where, $join); + my $like = defined $params->{'searchitem'} && $params->{'searchitem'} ne '' ? '%%'.$params->{'searchitem'}.'%%' : '%%'; + if ( ( defined $params->{'searchitem'} && $params->{'searchitem'} ne '' && defined $params->{'selfields'} ) || + defined $params->{'genres'} ) { + $where .= "WHERE "; + } + if ( defined $params->{'searchitem'} && $params->{'searchitem'} ne '' && defined $params->{'searchitem'} ) { + if ( ref $params->{'selfields'} ) { + foreach my $field ( @{$params->{'selfields'}} ) { + if ( $field eq "mediatype" ) { + push @wheres, $field. "=". $obj->_get_mediatype_idbyname($params->{'searchitem'}); + } else { + push @wheres, $field. " LIKE ". '"'. $like. '"'; + } + } + $where .= join " OR ", @wheres; + } else { + if ( $params->{'selfields'} eq "mediatype" ) { + $where .= $params->{'selfields'}. "=". $obj->_get_mediatype_idbyname($params->{'searchitem'}); + } else { + $where .= $params->{'selfields'}. " LIKE ". '"'. $like. '"'; + } + } + } + if ( defined $params->{'searchitem'} && $params->{'searchitem'} ne '' && defined $params->{'selfields'} && defined $params->{'genres'} ) { + $where .= " AND "; + } + if ( defined $params->{'genres'} ) { + if ( ref $params->{'genres'} ) { + $where .= 'genre_id IN ('. join (",", @{ $params->{'genres'} } ). ')'; + } else { + $where .= 'genre_id='. $params->{'genres'}; + } + $join = qq| +LEFT JOIN + MEDIALIB_VIDEOGENRE +ON + id=video_id +|; + } + + my $sql = qq| +SELECT + id, imgurl, title, subtitle, year, director, SUBSTRING(plot,1,200) +FROM + MEDIALIB_VIDEODATA +$join +$where +ORDER BY title +|; + + $erg = $obj->{dbh}->selectall_arrayref($sql); + $setcount = defined $erg ? scalar @$erg : 0; + map { + $_->[1] =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg; + } @$erg if $obj->{usecache} eq "y"; + } + + $console->table($erg, + { + %$params, + fields => $obj->_getsearchsfields_as_array, + allgenres => $obj->_get_videogenres_as_array, + setcount => $setcount, + range => defined $params->{range} && $params->{range} ne '' ? $params->{range} : $obj->{defrange}, + ranges => $obj->_get_ranges_as_array, + cols => $obj->{listcols}, + usecache => $obj->{usecache}, + } + ); +} + +# ------------------ +sub editMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $params = shift || {}; + #print Dumper($params); + my $range = delete $params->{range} if defined $params->{range}; + if ( $id ) { + my $sql = qq| +SELECT + * +FROM + MEDIALIB_VIDEODATA +WHERE + id = ? +|; + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($id) + or return $console->err(sprintf(gettext("Media with ID '%s' does not exist in the database!"),$id)); + $params = $sth->fetchrow_hashref(); + $params->{genres} = $obj->_get_videogenres_byvideoid($id); + $params->{filedate} = '' if $params->{filedate} eq '0000-00-00 00:00:00'; + } + + if ( ref $params ) { + foreach my $key ( keys %$params ) { + $params->{$key} =~ s/\r\n/\n/g if($params->{$key}); + } + } + + $params->{mediatype} = $obj->{defmediatype} unless defined $params->{mediatype} && $params->{mediatype} != 0; + $params->{language} = $obj->{deflanguage} unless defined $params->{language} && $params->{language} ne ''; + + #print Dumper($params); + $console->table({}, + { + %$params, + mediatypes => $obj->_get_mediatype_as_array, + allgenres => $obj->_get_videogenres_as_array, + range => $range, + ranges => $obj->_get_ranges_as_array, + } + ); +} + +# ------------------ +sub listMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || ""; + my $params = shift; + + my ($r, $range,$where); + $r = uc($params->{range}) + if ( $params && defined $params->{range} && $params->{range}=~ /^.+?/ ); + $r = uc($obj->{defrange}) + if ( ! $r ); + + if ( $r eq "SEEN" ) { + $where = qq| WHERE seen=1 |; + } elsif ( $r eq "UNSEEN" ) { + $where = qq| WHERE seen=0 |; + } elsif ( $r eq "WANTED" ) { + $where = qq| WHERE mediatype=50 |; + } elsif( $r ne "ALL" ) { + if ( $r eq "NUM" ) { + $range = '"1","2","3","4","5","6","7","8","9","0"'; + } else { + $range = '"'. join( '","', split( //, $r)). '"'; + } + $where = qq| WHERE UCASE(SUBSTRING(title,1,1)) IN ($range) |; + } else { + $where = ""; + } + + my $sql = qq| +SELECT + id, imgurl, title, subtitle, year, director, SUBSTRING(plot,1,200) +FROM + MEDIALIB_VIDEODATA +$where +ORDER BY title +|; + + my $erg = $obj->{dbh}->selectall_arrayref($sql); + my $setcount = defined $erg ? scalar @$erg : 0; + + # Hier darf in Feld 6 \n nicht durch \r\n ersetzt werden + # da sonst die Formatierung des Listenansicht nicht mehr passt + map { + $_->[1] =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg; + } @$erg if $obj->{usecache} eq "y"; + + my $param = { + setcount => $setcount, + range => $r, + ranges => $obj->_get_ranges_as_array, + cols => $obj->{listcols}, + usecache => $obj->{usecache}, + }; + return $console->table($erg, $param); +} + +# ------------------ +sub displayMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || ""; + my $params = shift; + + lg("Details for mediaid:". $id); + + my $sql = qq| +SELECT + * +FROM + MEDIALIB_VIDEODATA +WHERE id = ? +|; + + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($id) + or return $console->err(sprintf(gettext("Media with ID '%s' does not exist in the database!"),$id)); + my $erg = $sth->fetchall_arrayref(); + my $actors = $obj->_get_actors( $erg->[0][12] ); + my $actorcount = ref $actors ? scalar @$actors : 0; + $erg->[0][10] =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg if $obj->{usecache} eq "y"; + $erg->[0][18] = '' if $erg->[0][18] eq '0000-00-00 00:00:00'; + + #\r\n will be replace with <br/> by output from OUTPUT::HTML + $erg->[0][6] =~ s/\n/\r\n/g; + $erg->[0][15] =~ s/\n/\r\n/g; + + my $param = { + mediatype => $obj->_get_mediatype_namebyid( $erg->[0][26] ), + actors => $actors, + actorcount => $actorcount, + genres_all => $obj->_get_videogenres_as_hash_by_id, + genres_sel => $obj->_get_videogenres_byvideoid( $id ), + range => defined $params->{range} && $params->{range} ne '' ? $params->{range} : $obj->{defrange}, + ranges => $obj->_get_ranges_as_array, + actorcols => $obj->{actorcols}, + usecache => $obj->{usecache}, + }; + return $console->table($erg, $param); +} + +# ------------------ +sub saveMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || ""; + my $params = shift; + + if ( ref $params && defined $params->{save} ) { + + delete $params->{save}; + delete $params->{source}; + my $range = delete $params->{range}; + + foreach my $key ( keys %$params ) { + $params->{$key} =~ s/\r\n/\n/g; + } + + $obj->_saveActors($console, $watcher, $params->{actors}); + my $genres = delete $params->{genres}; + $obj->_saveMedia($params); + + if(not $params->{id}) { + lg("Got no id from CGI"); + $params->{id} = $obj->{dbh}->selectrow_arrayref('SELECT max(ID) FROM MEDIALIB_VIDEODATA')->[0]; + lg("ID fetched from DB: ". $params->{id}); + } + + if ( $params->{id} ) { + $obj->_saveGenres($params->{id}, $genres); + } + + $console->message(sprintf gettext('Media %s saved!'), $params->{id}); + debug sprintf('%s media is saved%s', + ($id ? 'New' : 'Changed'), + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + $console->redirect({url => '?cmd=mldisplay&data='. $params->{id}."&__range=". $range, wait => 2}) + if($console->typ eq 'HTML'); + + } +} + +# ------------------ +sub deleteMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || ""; + my $params = shift; + + my @media = reverse sort{ $a <=> $b } split(/[^0-9]/, $id); + + { + my $sql = sprintf('DELETE FROM MEDIALIB_VIDEODATA WHERE id IN (%s)', join(',' => ('?') x @media)); + my $sth = $obj->{dbh}->prepare($sql); + if(!$sth->execute(@media)) { + error sprintf("Can't execute query: %s.",$sth->errstr); + $console->err(sprintf gettext("Media with ID '%s' does not exist in the database!"), join(',', @media)); + return 0; + } + } + + { + my $sql = sprintf('DELETE FROM MEDIALIB_VIDEOGENRE WHERE video_id IN (%s)', join(',' => ('?') x @media)); + my $sth = $obj->{dbh}->prepare($sql); + if(!$sth->execute(@media)) { + error sprintf("Can't execute query: %s.",$sth->errstr); + $console->err(sprintf gettext("Genres for Media with ID '%s' does not exist in the database!"), join(',', @media)); + return 0; + } + } + + $console->message(sprintf gettext("Media %s is deleted."), join(',', @media)); + debug sprintf('media with id "%s" is deleted%s', + join(',', @media), + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ ); + $console->redirect({url => '?cmd=mllist', wait => 1}) + if($console->typ eq 'HTML'); +} + +# ------------------ +sub _saveActors { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $input = shift || ''; + + $input =~ s/\r\n/\n/g; + my @actors = split /\n/, $input; + #print Dumper( $input, @actors ); + + my $rob = main::getModule('ROBOT') + or return error('No ROBOT Module installed!'); + + $rob->saveRobot('actorimage', sub{ + my $dbh = shift || return; + my $name = shift || return; + + lg( sprintf("Looking for image of %s", $name )); + + eval "use MediaLibParser::IMDb"; + return panic("\nCan not load Module: MediaLibParser::DVDPalace") if($@); + + my $mlp = MediaLibParser::IMDb->new( + 'lookup_actor' => $name, + 'regex_actor' => qr/$name/, + ); + + my $image = $mlp->actor || ''; + if ( $image ) { + lg( sprintf("Found image for %s at %s",($name, $image))); + } else { + lg( sprintf("No image found for %s", $name)); + } + + + my $sql = sprintf("INSERT INTO MEDIALIB_ACTORS (%s) VALUES (%s)", + 'name, imgurl', + '?, ?', + ); + my $sth = $dbh->prepare( $sql ); + $sth->execute( $name, $image ); + $sth->finish; + return 1; + } + ); + + + my $db_actors = $obj->_get_actors_as_hash_by_name($input); + + my $needrobot; + foreach my $name ( @actors ) { + + next if grep /^$name$/i, ( keys %$db_actors ); + $rob->register('actorimage', $obj->{dbh}, $name); + lg( sprintf("Registered ROBOT for %s", $name)); + $needrobot = 1; + } + + if ( $needrobot ) { + $rob->start('actorimage'); + $rob->clean('actorimage'); + } +} + +# ------------------ +sub _saveGenres { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $videoid = shift || 0; + my $genres = shift || []; + #print Dumper( $videoid,$genres); + + my $sql = sprintf("REPLACE INTO MEDIALIB_VIDEOGENRE (%s) VALUES (%s)", + 'video_id, genre_id', + '?, ?', + ); + my $sth = $obj->{dbh}->prepare( $sql ); + + if ( ref $genres ) { + foreach my $genre ( @$genres ) { + $sth->execute( $videoid, $genre ); + } + } else { + $sth->execute( $videoid, $genres ); + } + $sth->finish; +} + + + + + +# ------------------ +sub _saveMedia { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to Save!' ); + + if(ref $data eq 'HASH') { + my ($names, $vals, $kenn); + map { + push(@$names, $_); + push(@$vals, $data->{$_}), + push(@$kenn, '?'), + } sort keys %$data; + + my $sql = sprintf("REPLACE INTO MEDIALIB_VIDEODATA (%s) VALUES (%s)", + join(', ', @$names), + join(', ', @$kenn), + ); + my $sth = $obj->{dbh}->prepare( $sql ); + $sth->execute( @$vals ); + $sth->finish; + } else { + #my $sth = $obj->{dbh}->prepare('REPLACE INTO AUTOTIMER VALUES (?,?,?,?,?,?,?,?,?)'); + #$sth->execute( @$data ); + } +} + +# ------------------ +sub _get_actors { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $input = shift || return ''; + + $input =~ s/\r\n/\n/g; + my @actors = split /\n/, $input; + map { + $_ = uc($_); + } @actors; + + my $sql = sprintf(qq| +SELECT + UPPER(name) as name, imgurl +FROM + MEDIALIB_ACTORS +WHERE + UPPER(name) IN (%s) +|, join(',' => ('?') x @actors)); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@actors) + or return undef; + my $erg = $sth->fetchall_hashref('name'); + #print Dumper( $sql, $erg ); + foreach my $actor ( split /\n/, $input ) { + if ( not defined $erg->{uc($actor)} ) { + $erg->{$actor} = { + 'name' => $actor, + 'imgurl' => '', + }; + } + } + + my $ret = []; + foreach my $actor ( split /\n/, $input ) { + $erg->{uc($actor)}->{imgurl} =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg; + push @$ret, [$actor, $erg->{uc($actor)}->{imgurl}]; + } + + #print Dumper($erg, $ret); + return $ret; +} + +# ------------------ +sub _get_actors_as_hash_by_name { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $input = shift || return ''; + + $input =~ s/\r\n/\n/g; + my @actors = split /\n/, $input; + + my $sql = sprintf(qq| +SELECT + name, imgurl +FROM + MEDIALIB_ACTORS +WHERE + name IN (%s) +|, join(',' => ('?') x @actors)); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@actors) + or return undef; + my $erg = $sth->fetchall_hashref('name'); + return $erg; +} + +sub _nocover { + my $obj = shift || return error ('No Object!' ); + my $HTTPD = main::getModule('HTTPD'); + my $nocover = sprintf('%s/%s/images/nocover', $HTTPD->{paths}->{HTMLDIR}, $HTTPD->{HtmlRoot}); + + if(-r $nocover . ".png") { + return ($nocover . ".png"); + } + elsif(-r $nocover . ".gif") { + return ($nocover . ".gif"); + } else { + $nocover = sprintf('%s/default/images/nocover', $HTTPD->{paths}->{HTMLDIR}); + + if(-r $nocover . ".png") { + return ($nocover . ".png"); + } else { + return ($nocover . ".gif"); + } + } +} + + +# ------------------ +sub mediacache { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $params = shift || ''; + + my $image; + if ( ref $params ) { + if ( defined $params->{source} && $params->{source} ne '') { + my $ctx = Digest::MD5->new; + $ctx->add($params->{source}); + my $digest = $ctx->hexdigest;; + my $cache_image = $obj->{libraryimagedir}. '/'. $digest. '.jpg'; + my $cache_noimage = $obj->{libraryimagedir}. '/'. $digest. '.missed'; + if ( -e $cache_image ) { + $image = $cache_image; + } elsif ( -e $cache_noimage ) { + $image = $obj->_nocover(); + } else { + my $ret = getstore( $params->{source}, $cache_image ); + lg( 'Get store return code: '. $ret ); + if ( $ret == 200 ) { + $image = $cache_image; + } else { + touch($cache_noimage); + $image = $obj->_nocover(); + } + } + } else { + $image = $obj->_nocover(); + } + } else { + $image = $obj->_nocover(); + } + $console->image( $image ); +} + +# ------------------ +sub _get_mediatype_as_array { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return [ + [1,'DVD'], + [2,'SVCD'], + [3,'VCD'], + [4,'CD-R'], + [5,'CD-RW'], + [6,'VHS'], + [7,'DVD-R'], + [8,'DVD-RW'], + [9,'DVD+R'], + [10,'DVD+RW'], + [11,'DVD-DL'], + [12,'DVD+DL'], + [13,'Divx'], + [14,'Xvid'], + [50,gettext('wanted')], + ]; +} + +# ------------------ +sub _get_mediatype_as_hash { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $types = $obj->_get_mediatype_as_array; + + my $erg; + foreach my $set ( @$types ) { + $erg->{$set->[1]} = { + 'id' => $set->[0], + 'name' => $set->[1], + }; + } + return $erg; +} + +# ------------------ +sub _get_mediatype_namebyid { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || return error ('No Mediatype ID given'); + + my $types = $obj->_get_mediatype_as_array; + + foreach my $set ( @$types ) { + return $set->[1] if $set->[0] == $id; + } + return 0; +} + +# ------------------ +sub _get_mediatype_idbyname { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return error ('No Mediatype Name given'); + + my $types = $obj->_get_mediatype_as_array; + + foreach my $set ( @$types ) { + return $set->[0] if $set->[1] == $name; + } + return ''; +} + +# ------------------ +sub _get_videogenres_byvideoid { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || 0; + + return [] unless $id; + + my $sql = qq| +SELECT + genre_id +FROM + MEDIALIB_VIDEOGENRE +WHERE + video_id = ? +|; + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($id) + or return undef; + my $erg = $sth->fetchall_arrayref(); + my $ret; + map { + push @$ret, $_->[0]; + } @$erg; + return $ret; +} + +# ------------------ +sub _get_videogenres_as_hash_by_id { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $genres = $obj->_get_videogenres_as_array; + + my $erg; + foreach my $set ( @$genres ) { + $erg->{$set->[0]} = { + 'id' => $set->[0], + 'name' => $set->[1], + }; + } + return $erg; +} + +# ------------------ +sub _get_videogenres_as_hash_by_name { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $genres = $obj->_get_videogenres_as_array; + + my $erg; + foreach my $set ( @$genres ) { + $erg->{$set->[1]} = { + 'id' => $set->[0], + 'name' => $set->[1], + }; + } + return $erg; +} + +# ------------------ +sub _get_videogenres_as_hash { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return { + gettext('Action') => { + 'id' => 1, + 'name' => 'Action', + }, + gettext('Adventure') => { + 'id' => 2, + 'name' => 'Adventure', + }, + gettext('Animation') => { + 'id' => 3, + 'name' => 'Animation', + }, + gettext('Comedy') => { + 'id' => 4, + 'name' => 'Comedy', + }, + gettext('Crime') => { + 'id' => 5, + 'name' => 'Crime', + }, + gettext('Documentary') => { + 'id' => 6, + 'name' => 'Documentary', + }, + gettext('Drama') => { + 'id' => 7, + 'name' => 'Drama', + }, + gettext('Family') => { + 'id' => 8, + 'name' => 'Family', + }, + gettext('Fantasy') => { + 'id' => 9, + 'name' => 'Fantasy', + }, + gettext('Film-Noir') => { + 'id' => 10, + 'name' => 'Film-Noir', + }, + gettext('Horror') => { + 'id' => 11, + 'name' => 'Horror', + }, + gettext('Musical') => { + 'id' => 12, + 'name' => 'Musical', + }, + gettext('Mystery') => { + 'id' => 13, + 'name' => 'Mystery', + }, + gettext('Romance') => { + 'id' => 14, + 'name' => 'Romance', + }, + gettext('Sci-Fi') => { + 'id' => 15, + 'name' => 'Sci-Fi', + }, + gettext('Short') => { + 'id' => 16, + 'name' => 'Short', + }, + gettext('Thriller') => { + 'id' => 17, + 'name' => 'Thriller', + }, + gettext('War') => { + 'id' => 18, + 'name' => 'War', + }, + gettext('Western') => { + 'id' => 19, + 'name' => 'Western', + }, + gettext('Adult') => { + 'id' => 20, + 'name' => 'Adult', + }, + gettext('Music') => { + 'id' => 21, + 'name' => 'Music', + }, + gettext('Biography') => { + 'id' => 22, + 'name' => 'Biography', + }, + gettext('MLHistory') => { + 'id' => 23, + 'name' => 'History', + }, + gettext('Childs') => { + 'id' => 24, + 'name' => 'Childs', + }, + gettext('Splatter') => { + 'id' => 25, + 'name' => 'Splatter', + }, + }; + +} + +# ------------------ +sub _get_videogenres_as_array { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $hashref = $obj->_get_videogenres_as_hash; + + my $ret = []; + foreach my $key ( sort keys %$hashref ) { + push @$ret, [ $hashref->{$key}->{id}, $key ]; + } + return $ret; +} + +# ------------------ +sub _getsearchsfields_as_array { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return [ + [ 'title', gettext('Title') ], + [ 'subtitle', gettext('Subtitle') ], + [ 'director', gettext('Director') ], + [ 'actors', gettext('Actors') ], + [ 'plot', gettext('Plot') ], + [ 'year', gettext('Year') ], + [ 'country', gettext('Country') ], + [ 'diskid', gettext('DiskID') ], + [ 'mediatype', gettext('Mediatype') ], + [ 'language', gettext('Language') ], + [ 'comment', gettext('Comment') ], + ]; +} + +# ------------------ +sub _get_ranges_as_array { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return [ + [ 'NUM', gettext('#') ], + [ 'ABC', gettext('ABC') ], + [ 'DEF', gettext('DEF') ], + [ 'GHI', gettext('GHI') ], + [ 'JKL', gettext('JKL') ], + [ 'MNO', gettext('MNO') ], + [ 'PQRS', gettext('PQRS') ], + [ 'TUV', gettext('TUV') ], + [ 'WXYZ', gettext('WXYZ') ], + [ 'ALL', gettext('All') ], + [ 'SEEN', gettext('Seen') ], + [ 'UNSEEN', gettext('Unseen') ], + [ 'WANTED', gettext('Wanted') ] + ]; +} + + +1; diff --git a/lib/XXV/MODULES/MUSIC.pm b/lib/XXV/MODULES/MUSIC.pm new file mode 100644 index 0000000..1b8d1fb --- /dev/null +++ b/lib/XXV/MODULES/MUSIC.pm @@ -0,0 +1,1352 @@ +package XXV::MODULES::MUSIC; +use strict; + +use Tools; +use Locale::gettext; +use File::Basename; +use File::Path; +use File::Find; + +$SIG{CHLD} = 'IGNORE'; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'MUSIC', + Prereq => { + 'DBI' => 'Database independent interface for Perl ', + 'DBD::mysql' => 'MySQL driver for the Perl5 Database Interface (DBI)', + 'MP3::Icecast' => 'Generate Icecast streams, as well as M3U and PLSv2 playlists', + 'MP3::Info' => 'Manipulate / fetch info from MP3 audio files ', + 'CGI' => 'Simple Common Gateway Interface Class', + 'LWP::Simple' => 'get, head, getprint, getstore, mirror - Procedural LWP interface', + 'Net::Amazon' => 'Framework for accessing amazon.com via SOAP and XML/HTTP', + 'Net::Amazon::Request::Artist' => + 'Class for submitting Artist requests', + }, + Description => gettext('This module managed music files.'), + Version => '0.92', + Date => '2007-02-04', + Author => 'xpix', + Status => sub{ $obj->status(@_) }, + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + path => { + description => gettext('Directory with the music files'), + default => '/music', + type => 'dir', + required => gettext('This is required!'), + }, + port => { + description => gettext('Port to listen for icecast clients.'), + default => 8100, + type => 'integer', + required => gettext('This is required!'), + }, + Interface => { + description => gettext('Local interface to bind service'), + default => '0.0.0.0', + type => 'host', + required => gettext('This is required!'), + }, + proxy => { + description => gettext('Proxy URL to music server. e.g. (http://vdr/xxv) Please remember you must write the Port to icecast server in your Proxy Konfiguration!'), + default => '', + type => 'string', + }, + clients => { + description => gettext('Maximum Clients to connect at the same time.'), + default => 5, + type => 'integer', + required => gettext('This is required!'), + }, + coverimages => { + description => gettext('common directory for cover images'), + default => '/var/cache/xxv/cover', + type => 'dir', + required => gettext('This is required!'), + }, + muggle => { + description => gettext('DSN for muggle Database'), + default => 'DBI:mysql:database=GiantDisc;host=localhost;port=3306', + type => 'string', + check => sub{ + my $value = shift; + $obj->{mdbh} = $obj->ConnectToMuggleDB($value); + return $value; + }, + }, + mugglei => { + description => gettext('Path to the binary from mugglei.'), + default => 'mugglei', + type => 'file', + }, + }, + Commands => { + mrefresh => { + description => gettext('Rereading of the music directory.'), + short => 'mr', + callback => sub{ $obj->refresh(@_) }, + Level => 'admin', + DenyClass => 'mlist', + }, + mcovers => { + description => gettext('Download album covers.'), + short => 'mc', + callback => sub{ $obj->getcovers(@_) }, + Level => 'admin', + DenyClass => 'mlist', + }, + mplay => { + description => gettext("play music file 'fid'"), + short => 'mp', + callback => sub{ $obj->play(@_) }, + DenyClass => 'stream', + }, + mplaylist => { + description => gettext("get a m3u playlist for 'fid'"), + short => 'm3', + callback => sub{ $obj->playlist(@_) }, + DenyClass => 'stream', + }, + mlist => { + description => gettext("list music 'dir'"), + short => 'ml', + callback => sub{ $obj->list(@_) }, + DenyClass => 'mlist', + }, + msearch => { + description => gettext("search music 'txt'"), + short => 'mf', + callback => sub{ $obj->search(@_) }, + DenyClass => 'mlist', + }, + mcoverimage => { + description => gettext('Show album covers.'), + short => 'mi', + callback => sub{ $obj->coverimage(@_) }, + DenyClass => 'mlist', + }, + mgetfile => { + description => gettext("Get music file 'fid'"), + short => 'mg', + callback => sub{ $obj->getfile(@_) }, + DenyClass => 'mlist', + }, + msuggest => { + hidden => 'yes',
+ callback => sub{ $obj->suggest(@_) }, + DenyClass => 'mlist', + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return 1 + if($obj->{active} eq 'n'); + + $obj->{Amazon} = Net::Amazon->new( + token => '1CCSPM94SQW5RNWY6682', + ); + + $obj->{mdbh} = $obj->ConnectToMuggleDB($obj->{muggle}); + + #create an instance to find all files below /usr/local/mp3 + $obj->{ICE} = MP3::Icecast->new(); +# $obj->{ICE}->recursive(1); + +# Use "file::find" & "add_file" instead of use "add_directory" +# avoid dead of modul via link-loops like cd /mp3; ln -s foo ../mp3 +# $obj->{ICE}->add_directory($obj->{path}); + find( { + wanted => sub{ + if(-r $File::Find::name) { + $obj->{ICE}->add_file($File::Find::name) + if($File::Find::name =~ /\.mp3$/sig); # Lookup for *.mp3 + } else { + lg "Permissions deny, can't read : $File::Find::name"; + } + }, + follow => 1, + follow_skip => 2, + }, + $obj->{path} + ); + + $obj->{SOCK} = IO::Socket::INET->new( + LocalPort => $obj->{port}, #standard Icecast port + LocalAddr => $obj->{Interface}, + Listen => $obj->{clients}, + Proto => 'tcp', + Reuse => 1, + Timeout => 3600 + ); + + my $channels; + + Event->io( + fd => $obj->{SOCK}, + prio => -1, # -1 very hard ... 6 very low + cb => sub { + # accept client + my $client = $obj->{SOCK}->accept; + panic "Can't connect to new icecast client." and return unless $client; + $client->autoflush; + + # make "channel" number + my $channel=++$channels; + + # install a communicator + Event->io( + fd => $client, + prio => -1, # -1 very hard ... 6 very low + poll => 'r', + cb => sub { + my $watcher = shift; + # report + lg(sprintf("Talking on icecast channel %d", $channel)); + + # read new line and report it + my $handle=$watcher->w->fd; + my $data = $obj->parseRequest($handle); + my $files = $obj->handleInput($data); + unless(ref $files eq 'ARRAY') { + $watcher->w->cancel; + $client->close(); + undef $watcher; + return 1; + } + + $obj->stream($files, $client); + + $watcher->w->cancel; + undef $watcher; + $client->close; + }, + ); + + # report + lg(sprintf("Open new icecast channel %d", $channel)); + }, + ); + + # Look for table or create this table + my $version = main::getVersion; + + unless($obj->{mdbh}) { + # don't remove old table, if updated rows => warn only + tableUpdated($obj->{dbh},'MUSIC',12,0); + + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS MUSIC ( + Id int(11) unsigned auto_increment NOT NULL, + FILE text NOT NULL, + ARTIST varchar(128) default 'unknown', + ALBUM varchar(128) default 'unknown', + TITLE varchar(128) default 'unknown', + COMMENT varchar(128), + TRACKNUM varchar(10) default '0', + YEAR smallint(4) unsigned, + GENRE varchar(128), + BITRATE smallint(4) unsigned, + FREQUENCY varchar(4), + SECS int (11) NOT NULL, + PRIMARY KEY (ID) + ) COMMENT = '$version' + |); + + $obj->{fields} = fields($obj->{dbh}, 'select * from MUSIC'); + + # Read File to Database, if the DB empty and Musicdir exists + $obj->refresh() + unless($obj->{dbh}->selectrow_arrayref("select count(*) from MUSIC")->[0]); + } + + return 1; + +} + +# ------------------ +sub refresh { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + if( ref $console and not -d $obj->{path} ) { + my $errmsg = sprintf(gettext("Directory of the music files '%s' not found"), $obj->{path}); + error($errmsg); + $console->err($errmsg); + $console->link({ + text => gettext("Back to music list"), + url => "?cmd=mlist", + }) if($console->typ eq 'HTML'); + return; + } + + if($obj->{mugglei} and $obj->{mdbh}) { + my $usr = main::getGeneralConfig->{USR}; + my $pwd = main::getGeneralConfig->{PWD}; + my $host = (split(/ /, $dbh->{'mysql_hostinfo'}))[0]; + # /usr/local/bin/mugglei -h 127.0.0.1 -c -u xpix -w xpix97 -t /NAS/Music . + my $command = sprintf('%s -h %s -z -c -u %s -w %s -t %s . 2>&1', + $obj->{mugglei}, lc($host), $usr, $pwd, $obj->{path}); + lg sprintf("Execute: cd '%s';%s",$obj->{path},$command); + chdir($obj->{path}); + my @erg = (`$command`); + + if( ref $console) { + $console->message(gettext("Reread the music files ...")); + $console->link({ + text => gettext("Back to music list"), + url => "?cmd=mlist", + }) if($console->typ eq 'HTML'); + } + undef $obj->{GENRES}; # delete genres cache + + return 1; + } + + my $waiter; + # Show waiter, early as is possible + if(ref $console && $console->typ eq 'HTML') { + $waiter = $console->wait(gettext("Get information from music files ..."), 0, 1000, 'no'); + } + + lg('Please wait! I search for new Musicfiles!'); + + #create an instance to find all files below /usr/local/mp3 + $obj->{ICE} = MP3::Icecast->new(); + $obj->{ICE}->recursive(1); + $obj->{ICE}->add_directory($obj->{path}); + + $obj->{CACHE} = {}; + + my $data = $dbh->selectall_hashref("select ID, FILE from MUSIC", 'FILE'); + my @files = $obj->{ICE}->files; + + lg sprintf('Found %d music files !', scalar @files); + + return unless(scalar @files); + + if( ref $console and not scalar @files ) { + + # last call of waiter + $waiter->end() if(ref $waiter); + + $console->start() if(ref $waiter); + + $console->err(gettext("No music files found!")); + $console->link({ + text => gettext("Back to music list"), + url => "?cmd=mlist", + }) if($console->typ eq 'HTML'); + + return; + } + + # Adjust waiter max value now. + $waiter->max(scalar @files) + if(ref $waiter); + + my $c = 0; + my $new = 0; + foreach my $file (@files) { + ++$c; + $waiter->next($c) + if(ref $waiter); + next if(delete $data->{$file}); + my $info = MP3::Info->new($file); + $new++ + if($obj->insert($info)); + } + + foreach my $f (sort keys %$data) { + unless(-e $f) { + $dbh->do(sprintf('DELETE FROM MUSIC WHERE ID = %lu', $data->{$f}->{ID})); + } + } + + # last call of waiter + $waiter->end() if(ref $waiter); + + if(ref $console) { + $console->start() + if(ref $waiter); + my $msg = sprintf(gettext("%d new music files in database saved and %d non exists entries deleted!"), $new, scalar keys %$data); + $console->message($msg); + lg $msg; + $console->link({ + text => gettext("Back to music list"), + url => "?cmd=mlist", + }) if($console->typ eq 'HTML'); + } +} + +# ------------------ +sub play { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $data = shift || return error ('No data'); + + debug sprintf('Call play%s', + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + $console->player("?cmd=mplaylist&data=${data}&binary=1"); +} + +# ------------------ +sub playlist { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $data = shift || return error ('No data'); + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + my $host = main::getModule('STREAM')->{host} || main::getModule('STATUS')->IP; + my $output; + + foreach my $id (split('_', $data)) { + my $data; + if($obj->{mdbh}) { + $data = $dbh->selectrow_hashref("select * from tracks where id = '$id'"); + } else { + $data = $dbh->selectrow_hashref("select * from MUSIC where ID = '$id'"); + } + next unless($data); + + $output .= "#EXTM3U\r\n" unless($output); + + my $file; + my $proxy = $obj->{proxy}; + $proxy =~ s/^\s+//; # no leading white space + $proxy =~ s/\s+$//; # no trailing white space + if(length($proxy)) { + $file = sprintf('%s/?cmd=play&data=%s&field=id', $proxy, $id); + } else { + $file = sprintf('http://%s:%lu/?cmd=play&data=%s&field=%s', $host, $obj->{port}, $id, ($obj->{mdbh} ? 'id' : 'ID')); + } + if($obj->{mdbh}) { + $output .= sprintf("#EXTINF:%d,%s - %s (%s)\r\n",$data->{'length'},$data->{title},$data->{artist},$data->{sourceid}); + } else { + $output .= sprintf("#EXTINF:%d,%s - %s (%s)\r\n",$data->{SECS},$data->{TITLE},$data->{ARTIST},$data->{ALBUM}); + } + $output .= sprintf("%s\r\n", $file); + } + + if($output && $console->typ eq 'HTML') { + $console->{noFooter} = 1; + $console->{nopack} = 1; + $console->{nocache} = 1; + + my $arg; + $arg->{'attachment'} = "playlist.m3u"; + $arg->{'Content-Length'} = length($output); + + $console->out($output, "audio/x-mpegurl", %{$arg} ); + } else { + $console->err(gettext("Sorry, playback is'nt supported")); + } +} + +# ------------------ +sub search { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $text = shift || return $console->err(gettext("No Text to search! Please use msearch 'text'")); + + return $obj->list($watcher,$console,"search:".$text); +} + +# ------------------ +sub list { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $search = shift; + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + return 0 + if(!$dbh); + + # Genres cachen + $obj->{GENRES} = $dbh->selectall_hashref('select * from genre', 'id') + if($obj->{mdbh} && !$obj->{GENRES}); + + if($obj->{mdbh} && ! $search) { + my $eg = $dbh->selectrow_arrayref('select title from album limit 1') + || return $console->err($obj->{mdbh}->errstr); + $search = sprintf('album:%s', $eg->[0]); + } elsif(! $search) { + my $eg = $dbh->selectrow_arrayref('select ALBUM from MUSIC limit 1') + || return $console->err($dbh->errstr); + $search = sprintf('album:%s', $eg->[0]); + } + + my @field = split(':',$search); + my $typ = $field[0]; + + # Muggleübersetzer ;) + my $translate = { + artist => 'artist', + album => 'title', + genre => 'genre1', + title => 'title', + year => 'year', + }; + + shift @field; + my $text = join(':',@field); + + my $t; + if($typ eq 'genre') { + $t = ($obj->{mdbh} ? 'tracks.'.$translate->{$typ} : uc($typ)); + $text = $obj->{GENRES}->{$text}->{id} if($obj->{mdbh}); + } elsif($typ eq 'year') { + $t = ($obj->{mdbh} ? 'tracks.'.$translate->{$typ} : uc($typ)); + } elsif($typ eq 'album') { + $t = ($obj->{mdbh} ? 'album.'.$translate->{$typ} : uc($typ)); + } else { + $t = ($obj->{mdbh} ? 'tracks.'.$translate->{$typ} : uc($typ)); + } + + my $where; + if($typ eq 'search') { + if($obj->{mdbh}) { + $where = buildsearch("album.artist,tracks.artist,album.title,tracks.title,album.covertxt",$text); + } else { + $where = buildsearch("ALBUM,ARTIST,TITLE,COMMENT",$text); + } + } elsif($typ eq 'genre' && $obj->{mdbh}) { + $text =~ s/\'/\\'/sg;#' + $where = sprintf("%s LIKE '%s%%'", $t, $text); + } else { + $text =~ s/\'/\\'/sg;#' + $where = sprintf("%s LIKE '%%%s%%'", $t, $text); + } + + my %f = ( + 'Id' => umlaute(gettext('Sv')), + 'Artist' => umlaute(gettext('Artist')), + 'Album' => umlaute(gettext('Album')), + 'Title' => umlaute(gettext('Title')), + 'Tracknum' => umlaute(gettext('Tracknum')), + 'Year' => umlaute(gettext('Year')), + 'Length' => umlaute(gettext('Length')), + ); + + my $sql; + if($obj->{mdbh}) { + + $sql = qq| + SELECT + tracks.id as $f{'Id'}, + tracks.artist as $f{'Artist'}, + album.title as $f{'Album'}, + tracks.title as $f{'Title'}, + tracks.tracknb as $f{'Tracknum'}, + tracks.year as $f{'Year'}, + IF(tracks.length >= 3600,SEC_TO_TIME(tracks.length),DATE_FORMAT(FROM_UNIXTIME(tracks.length), '%i:%s')) as $f{'Length'}, + genre.genre as __GENRE, + album.covertxt as __COMMENT + FROM + tracks, album, genre + WHERE + tracks.sourceid = album.cddbid and + tracks.genre1 = genre.id and + ( $where ) + |; + + $sql .= qq| + + UNION + SELECT + tracks.id as $f{'Id'}, + tracks.artist as $f{'Artist'}, + album.title as $f{'Album'}, + tracks.title as $f{'Title'}, + tracks.tracknb as $f{'Tracknum'}, + tracks.year as $f{'Year'}, + IF(tracks.length >= 3600,SEC_TO_TIME(tracks.length),DATE_FORMAT(FROM_UNIXTIME(tracks.length), '%i:%s')) as $f{'Length'}, + "" as __GENRE, + album.covertxt as __COMMENT + FROM + tracks, album + WHERE + tracks.sourceid = album.cddbid and + tracks.genre1 = 'NULL' and + ( $where ) + | if($typ ne 'genre'); + + + $sql .= qq| + ORDER BY + $f{'Album'}, + $f{'Tracknum'} + |; + + } else { + + $sql = qq| + SELECT + ID as $f{'Id'}, + ARTIST as $f{'Artist'}, + ALBUM as $f{'Album'}, + TITLE as $f{'Title'}, + TRACKNUM as $f{'Tracknum'}, + YEAR as $f{'Year'}, + IF(SECS >= 3600,SEC_TO_TIME(SECS),DATE_FORMAT(FROM_UNIXTIME(SECS), '%i:%s')) as $f{'Length'}, + GENRE as __GENRE, + COMMENT as __COMMENT + FROM + MUSIC + WHERE + ( $where ) + ORDER BY + FILE + |; + } + + my $fields = fields($dbh, $sql); + my $erg = $dbh->selectall_arrayref($sql); + + unshift(@$erg, $fields); + + my $params = { + albums => ($obj->{mdbh} ? $obj->GroupArray('title', 'album', 'cddbid') : $obj->GroupArray('ALBUM')), + artists => ($obj->{mdbh} ? $obj->GroupArray('artist', 'tracks', 'id'): $obj->GroupArray('ARTIST')), + genres => $obj->GenreArray(), + getCover => sub{ return $obj->_findcoverfromcache(@_, 'relative') }, + proxy => $obj->{proxy}, + }; + + $console->table($erg, $params); +} + +# ------------------ +sub handleInput { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Request!' ); + my $cgi = CGI->new( $data->{Query} ); + + my $ucmd = $cgi->param('cmd') || 'play'; + my $ufield = $cgi->param('field') || ($obj->{mdbh} ? 'id' : 'ID'); + my $udata = $cgi->param('data') || '*'; + + my $files; + if($ucmd eq 'play' and $ufield and my @search = split(',',$udata)) { + $files = $obj->field2path($ufield, \@search); + } else { + return error "I don't understand this command '$ucmd'"; + } + return $files; +} + +# ------------------ +sub field2path { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $field = shift || return error ('No Field!' ); + my $data = shift || return error ('No ids!' ); + my $pathfield; + my $sql; + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + return 0 + if(!$dbh); + + map {$_ = $dbh->quote($_)} @$data; + + if($obj->{mdbh}) { + $pathfield = 'mp3file'; + $sql = sprintf "select %s, %s from tracks", $pathfield, $field; + } else { + $pathfield = 'FILE'; + $sql = sprintf "select %s, %s from MUSIC", $pathfield, $field; + } + $sql .= sprintf " where %s in (%s)", $field, join(',', @$data) + if($data->[0] ne '*'); + + my $ret = $dbh->selectall_hashref($sql, $pathfield); + my @files = sort keys %$ret; + return \@files; +} + +# ------------------ +sub insert { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return 0; + + my @setdata; + foreach my $name (keys %$data) { + next unless(grep($name eq $_, @{$obj->{fields}})); + push(@setdata, sprintf("%s=%s", $name, $obj->{dbh}->quote($data->{$name}))); + } + + # MD5(File) as ID + my $sql = sprintf('INSERT INTO MUSIC SET %s', join(', ', @setdata)); + # dumper($sql); + $obj->{dbh}->do( $sql ); + return 1; +} + +# ------------------ +sub stream { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $files = shift || return error ('No Files!' ); + my $client = shift || return error ('No Client!' ); + + my %seen = (); + my @uniqu = grep { ! $seen{$_} ++ } @$files; + + defined(my $child = fork()) or die "Can't fork: $!"; + if($child == 0) { + $obj->{SOCK}->close; + $obj->{dbh}->{InactiveDestroy} = 1; + + foreach my $file (@uniqu) { + + $file = $obj->{path} . "/" . $file + if($obj->{mdbh}); + + debug('Stream file "%s" to Client: %s', + $file,$client); + my $erg = $obj->{ICE}->stream($file,0,$client) + || last; + } + exit 0; + } +} + +# ------------------ +sub parseRequest { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $hdl = shift || return error ('No Request!' ); + + my ($Req, $size) = getFromSocket($hdl); + + if(ref $Req eq 'ARRAY' and $Req->[0] =~ /^GET (\/[\w\.\/-\:]*)([\?[\w=&\.\+\%-\:\!]*]*)[\#\d ]+HTTP\/1.\d$/) { + my $data = {}; + ($data->{Request}, $data->{Query}) = ($1, $2 ? substr($2, 1, length($2)) : undef); + + # parse header + foreach my $line (@$Req) { + if($line =~ /Referer: (.*)/) { + $data->{Referer} = $1; + } + if($line =~ /Host: (.*)/) { + $data->{HOST} = $1; + } + if($line =~ /Authorization: basic (.*)/i) { + ($data->{username}, $data->{password}) = split(":", MIME::Base64::decode_base64($1), 2); + } + if($line =~ /User-Agent: (.*)/i) { + $data->{http_useragent} = $1; + } + } + +lg sprintf(qq| +----------------------------------------- +New Request from User: %s at Host: %s! +Query: %s +----------------------------------------- +|, $data->{username}, $data->{HOST}, $data->{Query}); + + return $data; + } else { + +error sprintf(qq| +----------------------------------------- +Unknown Request : +%s +----------------------------------------- +|, join("\n", @$Req)); + + return; + } +} + +# ------------------ +sub GroupArray { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $field = shift || return undef; + my $table = shift; + my $idfield = shift; + my $search = shift; + my $limitquery = shift; + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + my $where = ''; + $where = sprintf("WHERE %s LIKE '%%%%%s%%%%'",$field, $search) + if($search); + my $limit = ''; + $limit = sprintf("LIMIT %s",$limitquery) + if($limitquery && $limitquery > 0); + + my $sql; + if($obj->{mdbh}) { + $sql = sprintf('select %s, %s from %s %s group by %s order by %s %s', $field, $idfield, $table, $where, $field, $field, $limit); + } else { + $sql = sprintf('select %s, ID from MUSIC %s group by %s order by %s %s %s ', $field, $where, $field, $field, $limit); + } + my $erg = $dbh->selectall_arrayref($sql); + + return $erg; +} + +# ------------------ +sub GenreArray { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + my $sql; + if($obj->{mdbh}) { + $sql = "select genre, genre.id as id from genre,tracks where genre.id = tracks.genre1 group by id order by id"; + } else { + my $field = 'genre'; + $sql = sprintf('select %s, %s from MUSIC group by %s order by %s', $field, $field, $field, $field); + } + my $erg = $dbh->selectall_arrayref($sql); + + return $erg; +} + +# ------------------ +sub status { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $lastReportTime = shift || 0; + + return + if($obj->{active} eq 'n'); + + my $report = {}; + if($obj->{mdbh}) { + $report->{FILE} = $obj->{mdbh}->selectrow_arrayref('select count(*) from tracks')->[0]; + $report->{ALBUM} = $obj->{mdbh}->selectrow_arrayref('select count(*) from album')->[0]; + my $d = $obj->{mdbh}->selectall_arrayref('select artist from tracks group by artist'); + $report->{ARTIST} = scalar @$d; + $d = $obj->{mdbh}->selectall_arrayref('select genre1 from tracks group by genre1'); + $report->{GENRE} = scalar @$d; + } else { + foreach my $field (qw/FILE ALBUM ARTIST GENRE/) { + my $data = $obj->GroupArray($field); + $report->{$field} = scalar @$data; + } + } + + + return { + message => sprintf(gettext('Music database contains %d entries with %d albums from %d artists in %d genres'), + $report->{FILE}, $report->{ALBUM},$report->{ARTIST}, $report->{GENRE}), + }; +} + +# ------------------ +sub getcovers { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $force = shift; + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + return error('No valid Amazon token exists. Please sign up at http://amazon.com/soap!') + unless($obj->{Amazon}); + + debug sprintf('Call getcovers%s', + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + my $waiter = $console->wait(gettext("Please wait, search for new covers ..."),0,1000,'no') + if(ref $console); + + unless(-d $obj->{coverimages}) { + mkpath($obj->{coverimages}) or error "Can't mkpath $obj->{coverimages} : $!"; + lg sprintf('mkdir path "%s"', + $obj->{coverimages} + ); + } + + my $rob = main::getModule('ROBOT') + or return error('No ROBOT Module installed!'); + + $rob->saveRobot('coverimage', sub{ + my $artist = shift || return 0, "Missing artist"; + my $album = shift || return 0, "Missing album"; + my $year = shift || 0; + my $target = shift || return 0, "Missing target"; + my $current = shift || 0; + + my $msg = sprintf(gettext("Lookup for cover from '%s-%s'"), $artist,$album); + lg $msg; + # Anzeige der ProcessBar + $waiter->next($current,undef, $msg) if(ref $waiter); + + my $req = Net::Amazon::Request::Artist->new( + artist => $artist, + ); + my $resp = $obj->{Amazon}->request($req); + + $album =~ s/([\)\(\-\?\+\*\[\]\{\}])/\\$1/g; # Replace regex groupsymbols "),(,-,?,+,*,[,],{,}" + $album =~ s/([\/])/\./g; # Replace splash + + foreach my $item ($resp->properties) { + + if($item->album() =~ /$album/i or + ($year and $item->year() and $item->year() == $year)) { + my $image = $item->ImageUrlMedium() + or $item->ImageUrlLarge() + or $item->ImageUrlSmall(); + lg sprintf("Try to get cover %s.", $image); + getstore($image, $target) if($image); + last; + } + } + + return 1; + }); + + my $erg; + if($obj->{mdbh}) { + $erg = $dbh->selectall_hashref('select DISTINCT t.id as ID,t.mp3file as FILE, a.artist as ARTIST, a.title as ALBUM, t.year as YEAR from album as a, tracks as t where a.cddbid = t.sourceid group by a.title', 'ID'); + } else { + $erg = $dbh->selectall_hashref('select DISTINCT Id as ID, FILE, ARTIST, ALBUM, YEAR from MUSIC group by ALBUM', 'ID'); + } + + my $current = 0; + foreach my $id (sort keys %$erg) { + my $e = $erg->{$id}; + + my $file = sprintf('%s/%s', $obj->{path}, $e->{FILE}); + my $target = $obj->_findcover($file,$e->{ARTIST},$e->{ALBUM}); + + next if($target and -e $target and not $force); + + my $dest = $obj->_findcoverfromcache($e->{ALBUM},$e->{ARTIST}); + $rob->register('coverimage', $e->{ARTIST}, $e->{ALBUM}, $e->{YEAR}, $dest, ++$current); + } + + # Adjust waiter max value now. + $waiter->max($current || 1) + if(ref $waiter); + + if(ref $waiter and $current) { + $waiter->endcallback( + sub{ + if(ref $console) { + $console->start(); + $console->message(my $msg = gettext("New covers search was successfully!")); + lg sprintf($msg); + + $console->link({ + text => gettext("Back to music list"), + url => "?cmd=mlist", + }) if($console->typ eq 'HTML'); + $console->footer(); + } + } + ); + } + + if(ref $waiter and not $current) { + $waiter->endcallback( + sub{ + if(ref $console) { + $console->start(); + $console->message(gettext("It is not necessary to look for new covers because already all albums possess cover!")); + + $console->link({ + text => gettext("Back to music list"), + url => "?cmd=mlist", + }) if($console->typ eq 'HTML'); + $console->footer(); + } + } + ); + lg sprintf('All covers exists!'); + } + + # Start Robots + $rob->start( 'coverimage', $watcher, $console, sub{ $waiter->end if(ref $waiter and $current); } ); + + return $erg; +} + +# ------------------ +sub _findcoverfromcache { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $album = shift || return error ('No Album!' ); + my $artist = shift || 0; + my $typ = shift || 'absolute'; + + my $absolute; + my $relative; + + if($artist) { + $absolute = sprintf('%s/%s-%s.jpg', $obj->{coverimages}, $obj->unique($artist), $obj->unique($album)); + $relative = sprintf('/coverimages/%s-%s.jpg', $obj->unique($artist), $obj->unique($album)); + } else { + $absolute = sprintf('%s/%s.jpg', $obj->{coverimages}, $obj->unique($album)); + $relative = sprintf('/coverimages/%s.jpg', $obj->unique($album)); + } + return $absolute + if($typ eq 'absolute'); + return $relative + if(-r $absolute); + + lg sprintf("Don't find cover for %s - %s, as file %s",$artist,$album,$absolute); + return undef; +} + +# ------------------ +sub unique { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $text = shift || return ''; + + $text =~ s/[^0-9a-z]//sig; + return $text; +} + +# ------------------ +sub ConnectToMuggleDB { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $dsn = shift || return 0; + + $dsn =~ s/^\s+//; + $dsn =~ s/\s+$//; + + #try to connect to muggle database + if(length($dsn) and $obj->{active} eq 'y') { + my $usr = main::getGeneralConfig->{USR}; + my $pwd = main::getGeneralConfig->{PWD}; + + my $mdbh = DBI->connect( + $dsn, $usr, $pwd, + { PrintError => 1, + AutoCommit => 1, + }) || error($DBI::errstr); + if($mdbh) { + $mdbh->{InactiveDestroy} = 1; + $mdbh->{mysql_auto_reconnect} = 1; + debug('Successfully connect to: %s', $dsn); + return $mdbh; + } else { + debug('No GiantDisc data base. Use standard music data base!'); + return 0; + } + } else { + return 0; + } +} + +# ------------------ +sub _findcover { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $file = shift || return error ('No file!' ); + my $artist = shift; + my $album = shift; + + my $coverimage; + my $directory = dirname($file); + + if($obj->{coverimages} && -d $obj->{coverimages}) { + my $cache = $obj->_findcoverfromcache($album,$artist); + $coverimage = $cache + if($cache && -r $cache); + } + + if(!$coverimage && -d $directory) { + + my @images = []; + find( + { + wanted => sub{ + if(-r $File::Find::name) { + push(@images,$File::Find::name) + if($File::Find::name =~ /\.jpg$|\.jpeg$|\.gif$|\.png/sig); # Lookup for images + } else { + lg "Permissions deny, can't read : $File::Find::name"; + } + }, + follow => 1, + follow_skip => 2, + }, + $directory + ); + + # An image in the same directory as the song, named like the song but with the + # song extension replaced with the image format extension + # e.g. test.mp3 -> test.jpg + my $song = basename($file); + $song =~ s/([\)\(\-\?\+\*\[\]\{\}])/\\$1/g; # Replace regex groupsymbols "),(,-,?,+,*,[,],{,}" + $song =~ s/([\/])/\./g; # Replace splash + $song =~ s/(.*)\.mp3$/$1./ig; + my @f = grep { /$song/i } @images; + $coverimage = $f[0] + if(scalar @f > 0 && -r $f[0]); + + if(!$coverimage && $artist) { + $artist =~ s/([\)\(\-\?\+\*\[\]\{\}])/\\$1/g; # Replace regex groupsymbols "),(,-,?,+,*,[,],{,}" + $artist =~ s/([\/])/\./g; # Replace splash + @f = grep { /\/$artist\./i } @images; + $coverimage = $f[0] + if(scalar @f > 0 && -r $f[0]); + } + + if(!$coverimage && $album) { + $album =~ s/([\)\(\-\?\+\*\[\]\{\}])/\\$1/g; # Replace regex groupsymbols "),(,-,?,+,*,[,],{,}" + $album =~ s/([\/])/\./g; # Replace splash + @f = grep { /\/$album\./i } @images; + $coverimage = $f[0] + if(scalar @f > 0 && -r $f[0]); + } + + # An image named "cover" with the image format extension in the same directory + # as the song (album cover). + # e.g. cover.gif + if(!$coverimage) { + @f = grep { /\/cover\./i } @images; + $coverimage = $f[0] + if(scalar @f > 0 && -r $f[0]); + } + + # An image named "artist" with the image format extension in the parent + # directory of the song (artist image). + # e.g. artist.png + if(!$coverimage) { + @f = grep { /\/artist\./i } @images; + $coverimage = $f[0] + if(scalar @f > 0 && -r $f[0]); + } + # An image named "album" with the image format extension in the parent + # directory of the song (album image). + # e.g. album.png + if(!$coverimage) { + @f = grep { /\/album\./i } @images; + $coverimage = $f[0] + if(scalar @f > 0 && -r $f[0]); + } + + # An image named "background" with the image format extension in the base + # directory of the MP3 source. + if(!$coverimage) { + @f = grep { /\/background\./i } @images; + $coverimage = $f[0] + if(scalar @f > 0 && -r $f[0]); + } + } + return $coverimage; +} + +# ------------------ +sub coverimage { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $data = shift || return error ('No data'); + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + if($dbh) { + my $sql; + my @id = split('_',$data); + + my $coverimage; + map {$_ = $dbh->quote($_)} @id; + + if($obj->{mdbh}) { + $sql = sprintf qq| + select id, mp3file as file, + tracks.artist as artist, + album.title as album + from tracks, album + where tracks.sourceid = album.cddbid + and id in (%s)|, join(',', @id); + } else { + $sql = sprintf qq| + select ID as id, + FILE as file, + ARTIST as artist, + ALBUM as album + from MUSIC + where id in (%s)|, join(',', @id); + } + + my $ret = $dbh->selectrow_hashref($sql); + + if($ret && $ret->{'id'}) + { + my $file = sprintf('%s/%s', $obj->{path}, $ret->{'file'}); + + $coverimage = $obj->_findcover($file,$ret->{'artist'},$ret->{'album'}); + } + + if($console->typ eq 'HTML') { + if($coverimage) { + $console->datei($coverimage); + } else { + my $HTTPD = main::getModule('HTTPD'); + my $nocover = sprintf('%s/%s/images/nocover', $HTTPD->{paths}->{HTMLDIR}, $HTTPD->{HtmlRoot}); + if(-r $nocover . ".png") { + $console->datei($nocover . ".png"); + } + elsif(-r $nocover . ".gif") { + $console->datei($nocover . ".gif"); + } else { + $nocover = sprintf('%s/default/images/nocover', $HTTPD->{paths}->{HTMLDIR}); + if(-r $nocover . ".png") { + $console->datei($nocover . ".png"); + } else { + $console->datei($nocover . ".gif"); + } + } + } + } + return 1; + } + $console->err(gettext("Sorry, images for cover is'nt supported")); + return 0; +} + +# ------------------ +sub getfile { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $data = shift || return error ('No data'); + + my $dbh = ($obj->{mdbh} ? $obj->{mdbh} : $obj->{dbh}); + + if($dbh) { + my $sql; + my @id = split('_',$data); + + map {$_ = $dbh->quote($_)} @id; + + if($obj->{mdbh}) { + $sql = sprintf qq| + select id, mp3file as file from tracks + where id in (%s)|, join(',', @id); + } else { + $sql = sprintf qq| + select ID as id, FILE as file from MUSIC + where id in (%s)|, join(',', @id); + } + + my $ret = $dbh->selectrow_hashref($sql); + if($ret + && $ret->{'id'} + && $ret->{'file'} + && $console->typ eq 'HTML') { + $console->datei(sprintf('%s/%s', $obj->{path}, $ret->{'file'})); + return 1; + } + } + $console->err(gettext("Sorry, can't get file.")); + return 0; +} + +# ------------------
+sub suggest {
# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $search = shift; + my $params = shift; + + if(exists $params->{get}) { + my $result; + $result = ($obj->{mdbh} ? $obj->GroupArray('title', 'album', 'cddbid',$search, 25) : $obj->GroupArray('ALBUM',undef,undef,$search, 25)) + if($params->{get} eq 'album'); + + $result = ($obj->{mdbh} ? $obj->GroupArray('artist', 'tracks', 'id',$search, 25): $obj->GroupArray('ARTIST',undef,undef,$search, 25)) + if($params->{get} eq 'artist'); + + $result = ($obj->{mdbh} ? $obj->GroupArray('title', 'tracks', 'id',$search, 25): $obj->GroupArray('TITLE',undef,undef,$search, 25)) + if($params->{get} eq 'title'); + + $console->table($result)
+ if(ref $console && $result); + } +
+}
+ + +1; diff --git a/lib/XXV/MODULES/RECORDS.pm b/lib/XXV/MODULES/RECORDS.pm new file mode 100644 index 0000000..ded7e70 --- /dev/null +++ b/lib/XXV/MODULES/RECORDS.pm @@ -0,0 +1,2136 @@ +package XXV::MODULES::RECORDS; + +use strict; + +use Tools; +use File::Find; +use File::Copy; +use File::Path; +use File::Basename; +use File::stat; +use Locale::gettext; + +$SIG{CHLD} = 'IGNORE'; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $args = { + Name => 'RECORDS', + Prereq => { + 'Time::Local' => 'efficiently compute time from local and GMT time ', + }, + Description => gettext('This module managed recordings.'), + Version => '0.93', + Date => '2007-07-22',
+ Author => 'xpix', + Status => sub{ $obj->status(@_) }, + Preferences => { + commandfile => { + description => gettext('Location of reccmds.conf on your system.'), + default => '/var/lib/vdr/reccmds.conf', + type => 'file', + required => gettext("This is required!"), + }, + interval => { + description => gettext('How often recordings are to be updated (in seconds)'), + default => 30 * 60, + type => 'integer', + required => gettext("This is required!"), + }, + fullreading => { + description => gettext('How often recordings are to be completely read in (in hours)'), + default => 24, + type => 'integer', + required => gettext("This is required!"), + }, + videodir => { + description => gettext('Directory, where vdr recordings are stored.'), + default => '/var/lib/video', + type => 'dir', + required => gettext("This is required!"), + }, + previewbinary => { + description => gettext('Location of used program to produce preview images on your system.'), + default => '/usr/bin/mplayer', + type => 'file', + required => gettext("This is required!"), + }, + previewcommand => { + description => gettext('Please choose the used program to produce preview images.'), + type => 'list', + choices => [ + [gettext('Nothing'), 'Nothing'], + ['MPlayer1.0pre5', 'MPlayer1.0pre5'], + ['MPlayer1.0pre6', 'MPlayer1.0pre6'], + ['vdr2jpeg', 'vdr2jpeg'], + ], + default => 'Nothing', + required => gettext("This is required!"), + }, + previewcount => { + description => gettext('How many preview images produce?'), + default => 3, + type => 'integer', + }, + previewlistthumbs => { + description => gettext('Display list records with thumbnails?'), + default => 'n', + type => 'confirm', + }, + previewimages => { + description => gettext('common directory for preview images'), + default => '/var/cache/xxv/preview', + type => 'dir', + required => gettext('This is required!'), + }, + vfat => { + description => gettext('Set this if your filename encoded for vfat filesystems'), + default => 'y', + type => 'confirm', + }, + }, + Commands => { + rdisplay => { + description => gettext("Display recording 'rid'"), + short => 'rd', + callback => sub{ $obj->display(@_) }, + DenyClass => 'rlist', + }, + rlist => { + description => gettext('List recordings'), + short => 'rl', + callback => sub{ $obj->list(@_) }, + DenyClass => 'rlist', + }, + rsearch => { + description => gettext("Search recordings 'text'"), + short => 'rs', + callback => sub{ $obj->search(@_) }, + DenyClass => 'rlist', + }, + rupdate => { + description => gettext('Update recordings'), + short => 'ru', + callback => sub{ $obj->refresh(@_) }, + Level => 'user', + DenyClass => 'redit', + }, + rdelete => { + description => gettext("Delete recording 'rid'"), + short => 'rr', + callback => sub{ $obj->delete(@_) }, + Level => 'user', + DenyClass => 'redit', + }, + redit => { + description => gettext("Edit recording 'rid'"), + short => 're', + callback => sub{ $obj->redit(@_) }, + Level => 'user', + DenyClass => 'redit', + }, + rconvert => { + description => gettext("Convert recording 'rid'"), + short => 'rc', + callback => sub{ $obj->conv(@_) }, + Level => 'user', + DenyClass => 'redit', + }, + rplay => { + description => gettext("Play recording 'rid' in vdr"), + short => 'rpv', + callback => sub{ $obj->play(@_) }, + Level => 'user', + DenyClass => 'remote', + }, + rcut => { + description => gettext("Cut recording 'rid' in vdr"), + short => 'rcu', + callback => sub{ $obj->cut(@_) }, + Level => 'user', + DenyClass => 'remote', + }, + rsuggest => { + hidden => 'yes',
+ callback => sub{ $obj->suggest(@_) }, + DenyClass => 'rlist', + }, + }, + RegEvent => { + 'deleteRecord' => { + Descr => gettext('Create event entries, if a record deleted.'), + + # You have this choices (harmless is default): + # 'harmless', 'interesting', 'veryinteresting', 'important', 'veryimportant' + Level => 'important', + + # Search for a spezial Event. + # I.e.: Search for an LogEvent with match + # "Sub=>text" = subroutine =~ /text/ + # "Msg=>text" = logmessage =~ /text/ + # "Mod=>text" = modname =~ /text/ + SearchForEvent => { + Sub => 'RECORDS', + Msg => 'delr', + }, + # Search for a Match and extract the information + # of the RecordId + # ... + Match => { + RecordId => qr/delr\s+(\d+)/s, + }, + Actions => [ + q|sub{ my $args = shift; + my $event = shift; + my $record = getDataById($args->{RecordId}, 'RECORDS', 'RecordId'); + my $epg = main::getModule('EPG')->getId($record->{eventid}, 'title, subtitle, description'); + + + my $title = sprintf(gettext("Record deleted: %s"), $epg->{title}); + my $description = ""; + $description .= sprintf(gettext("Subtitle: %s\n"), + $epg->{subtitle}) if($epg->{subtitle}); + $description .= sprintf(gettext("Description: %s\n"), + $epg->{description}) if($epg->{description}); + + main::getModule('REPORT')->news($title, $description, "display", $record->{eventid}, "important"); + } + |, + ], + + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # define framerate PAL 25, NTSC 30
+ $self->{framerate} = 25;
+ + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + unless($obj->{dbh}) { + panic("Session to database is'nt connected"); + return 0; + } + + # remove old table, if updated rows + tableUpdated($obj->{dbh},'RECORDS',10,1); + + # Look for table or create this table + my $version = main::getVersion; + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS RECORDS ( + eventid bigint unsigned NOT NULL, + RecordId int(11) unsigned not NULL, + RecordMD5 varchar(32) NOT NULL, + Path text NOT NULL, + Prio tinyint NOT NULL, + Lifetime tinyint NOT NULL, + State tinyint NOT NULL, + Marks text, + Type enum('TV', 'RADIO', 'UNKNOWN') default 'TV', + addtime timestamp, + PRIMARY KEY (eventid), + UNIQUE KEY (eventid) + ) COMMENT = '$version' + |); + + $obj->{JOBS} = []; + $obj->{after_updated} = []; + $obj->{countReading} = 0; + + main::after(sub{ + $obj->{svdrp} = main::getModule('SVDRP'); + unless($obj->{svdrp}) { + panic ("Can't get modul SVDRP"); + return 0; + } + + # Interval to read recordings and put to DB + Event->timer( + interval => $obj->{interval}, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ + $obj->readData(); + $obj->{countReading} += 1;
+ }, + ); + $obj->readData(); + $obj->{countReading} += 1;
+ return 1; + }, "RECORDS: Store records in database ...", 20);
+ + 1; +} + +# ------------------ +sub dot1000 { +# ------------------ + my $t = reverse shift; + $t =~ s/(\d{3})(?=\d)(?!\d*\.)/$1./g; + return scalar reverse $t; +} + +# ------------------
+sub parseData {
+# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $vdata = shift || return error('Problem to read Data!');
+ my ($event, $hash, $id, $date, $hour, $minute, $state, $duration, $title, $day, $month, $year); + my $dataHash = {}; + + foreach my $record (@{$vdata}) { + if($record =~ /\s+\d+´\s+/) { # VDR is patched with recording length patch + # 250-1 01.11 15:14* 50´ Discovery~Die Rose von Kerrymore Spielfilm D/2000 + ($id, $date, $hour, $minute, $state, $duration, $title) + = $record =~ /^250[\-|\s](\d+)\s+([\d|\.]+)\s+(\d+)\:(\d+)(.?)\s*(\d*).*?\s+(.+)/si; + } else { # Vanilla VDR + # 250-1 01.11 15:14* Discovery~Die Rose von Kerrymore Spielfilm D/2000 + ($id, $date, $hour, $minute, $state, $title) + = $record =~ /^250[\-|\s](\d+)\s+([\d|\.]+)\s+(\d+)\:(\d+)(.?).*?\s+(.+)/si; + } + + unless($id) { + error sprintf("Can't parse svdrp data : '%s'",$record); + next; + } + + # Split date + ($day,$month,$year) = $date =~ /^(\d+)\.(\d+)\.(\d+)$/; + + $year += 100 + if($year < 70); # Adjust year, 0-69 => 100-169 (2000-2069) + $year += 1900 + if($year < 1900); # Adjust year, 70-99 => 1977-1999 ... 2000-2069 + + $event->{id} = $id; + $event->{state} = $state eq '*' ? 1 : 0; + $event->{starttime} = timelocal(0,$minute,$hour,$day,$month-1, $year); + $event->{title} = $title; + + $hash = sprintf("%s~%s",$title,$event->{starttime}); + %{$dataHash->{$hash}} = %{$event}; + } + return ($dataHash); +} + +# ------------------
+sub scandirectory {
# ------------------
+ my $obj = shift || return error ('No Object!');
+ + find( + { + wanted => sub{ + if(-r $File::Find::name) { + push(@{$obj->{FILES}},[$File::Find::name,$obj->converttitle($File::Find::name)]) + if($File::Find::name =~ /\.rec\/\d{3}.vdr$/sig); # Lookup for *.rec/001.vdr + } else { + lg "Permissions deny, can't read : $File::Find::name"; + } + }, + follow => 1, + follow_skip => 2, + }, + $obj->{videodir} + ); +} + +# ------------------ +sub readData { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $waiter = shift; + my $forceUpdate = shift; + + # Read recording over SVDRP + my $lstr = $obj->{svdrp}->command('lstr'); + my $vdata = [ grep(/^250/, @$lstr) ]; + + unless(scalar @$vdata) { + # Delete old Records + $obj->{dbh}->do('DELETE FROM RECORDS'); + + my $msg = gettext('No recordings available!'); + $console->err($msg) + if(ref $console); + return error($msg); + } + + # Get state from used harddrive (/video) + my $stat = $obj->{svdrp}->command('stat disk'); + my ($total, $totalUnit, $free, $freeUnit, $percent); + my $totalDuration = 0; + + if($stat->[1] and $stat->[1] =~ /^250/s) { + #250 473807MB 98028MB 79% + ($total, $totalUnit, $free, $freeUnit, $percent) + = $stat->[1] =~ /^250[\-|\s](\d+)(\S+)\s+(\d+)(\S+)\s+(\S+)/s; + + $obj->{CapacityMessage} = sprintf(gettext("Used %s, Total %s%s, Free %s%s"),$percent, dot1000($total), $totalUnit, dot1000($free), $freeUnit); + $obj->{CapacityPercent} = int($percent); + + } else { + error("Can't get disc state : ".join("\n", @$stat)); + $obj->{CapacityMessage} = gettext("Unknown disc capacity!"); + $obj->{CapacityPercent} = 0; + + } + + my @merkIds; + my $insertedData = 0;
+ my $updatedState = 0;
+ my $l = 0; + my $err = []; + + my $vdrData = $obj->parseData($vdata); + + # Adjust waiter max value now. + $waiter->max(scalar keys %$vdrData) + if(ref $console && ref $waiter); + + $obj->{FILES} = undef; + + my $db_data;
+ if($forceUpdate || $obj->{countReading} % ( $obj->{fullreading} * 3600 / $obj->{interval} ) == 0) {
+ # Once at day, make full scan + $obj->{dbh}->do('DELETE FROM RECORDS'); + } else { + # read database for compare with vdr data
+ my $sql = qq|select r.eventid as eventid, r.RecordId as id, + UNIX_TIMESTAMP(e.starttime) as starttime, + e.duration as duration, r.State as state, + CONCAT_WS('~',e.title,e.subtitle) as title, + CONCAT_WS('~',e.title,e.subtitle,UNIX_TIMESTAMP(e.starttime)) as hash, + UNIX_TIMESTAMP(e.addtime) as addtime, + r.Path as path, + r.Type as type, + r.Marks as marks, + r.RecordMD5 + from RECORDS as r,OLDEPG as e + where r.eventid = e.eventid |; + $db_data = $obj->{dbh}->selectall_hashref($sql, 'hash'); + + lg sprintf( 'Compare recording database with data from vdr : %d / %d', + scalar keys %$db_data,scalar keys %$vdrData );
+ } + + # Compare this Hashes
+ foreach my $h (keys %{$vdrData}) {
+ my $event = $vdrData->{$h};
+ + # Exists in DB ... update
+ if($db_data && exists $db_data->{$h}) {
+ + $waiter->next(++$l,undef, sprintf(gettext("Update recording '%s'"), + $db_data->{$h}->{title})) + if(ref $waiter);
+ + # Compare fields
+ foreach my $field (qw/id state/) {
+ if($db_data->{$h}->{$field} != $event->{$field}) {
+ + $obj->_updateState($db_data->{$h}, $event);
+ + $updatedState++; + last;
+ }
+ }
+ + # Update Duration and maybe preview images, if recordings added during timer run + if(($db_data->{$h}->{starttime} + $db_data->{$h}->{duration} + 60) > $db_data->{$h}->{addtime}) { + my $duration = $obj->_recordinglength($db_data->{$h}->{path}); + if($duration != $db_data->{$h}->{duration}) { + + unless($console) { + # set addtime only if called from EVENT::TIMER + # avoid generating preview image during user actions + # it's should speedup reading recordings + $db_data->{$h}->{addtime} = time; + + # Make Preview and remove older Preview images + my $command = $obj->videoPreview( $db_data->{$h}->{eventid}, $db_data->{$h}, 1); + push(@{$obj->{JOBS}}, $command) + if($command && not grep(/\Q$command/g,@{$obj->{JOBS}})); + } + # Update duration at database entry + $db_data->{$h}->{duration} = $duration; + + $obj->_updateEvent($db_data->{$h}); + + $updatedState++; + } + } + $totalDuration += $db_data->{$h}->{duration}; + + push(@merkIds,$db_data->{$h}->{eventid}); + + # delete updated rows from hash
+ delete $db_data->{$h}; +
+ } else { + $waiter->next(++$l,undef, sprintf(gettext("Analyze recording '%s'"), + $event->{title})) + if(ref $waiter); + + # Read VideoDir only at first call + if(not defined $obj->{FILES}) { + $obj->{FILES} = []; + $obj->scandirectory(); + } + + my $anahash = $obj->analyze($event); + if(ref $anahash eq 'HASH') { + $totalDuration += $anahash->{Duration}; + + if($obj->insert($anahash)) { + push(@merkIds,$anahash->{eventid}); + $insertedData++;
+ } else { + push(@{$err},$anahash->{title}); + } + } else { + push(@{$err},$event->{title}); + }
+ }
+ }
+
+ if($db_data && scalar keys %$db_data > 0) { + my @todel; + foreach my $t (keys %{$db_data}) {
+ push(@todel,$db_data->{$t}->{RecordMD5}); + } + + my $sql = sprintf('DELETE FROM RECORDS WHERE RecordMD5 IN (%s)', join(',' => ('?') x @todel)); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@todel) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + }
+
+ debug sprintf 'Finish .. %d recordings inserted, %d recordings updated, %d recordings removed', + $insertedData, $updatedState, $db_data ? scalar keys %$db_data : 0;
+ + $obj->{CapacityTotal} = $totalDuration; + $obj->{CapacityPercent} = (100.0 / $total) * ($total - $free) + if($total && $totalUnit eq $freeUnit); + $obj->{CapacityFree} = ($totalDuration * 100.0 / $obj->{CapacityPercent}) + - $obj->{CapacityTotal}; + + # Previews im fork erzeugen + if(scalar @{$obj->{JOBS}}) { + #Changes made after the fork() won't be visible in the parent process + my @jobs = @{$obj->{JOBS}}; + $obj->{JOBS} = []; + + defined(my $child = fork()) or return error sprintf("Can't fork : %s",$!); + if($child == 0) { + $obj->{dbh}->{InactiveDestroy} = 1; + + while(scalar @jobs > 0) { + my $command = shift (@jobs); + lg sprintf('Call cmd "%s" now', + $command, + ); + my $erg = system("nice -n 19 $command"); + } + exit 0; + } + } + + # alte PreviewDirs loeschen + foreach my $dir (glob(sprintf('%s/*_shot', $obj->{previewimages}))) { + my $oldEventNumber = (split('/', $dir))[-1]; + unless(grep(sprintf('%lu_shot',$_) eq $oldEventNumber, @merkIds)) { + deleteDir($dir); + } + } + + # Delete all old EPG entrys without the RecordIds which old as one day. + if(scalar @merkIds) { + my $sql = sprintf('DELETE FROM OLDEPG where (UNIX_TIMESTAMP(starttime) + duration) < (UNIX_TIMESTAMP() - 86400) and eventid not in (%s)', join(',' => ('?') x @merkIds)); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@merkIds) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } + + $obj->updated() if($insertedData); + + # last call of waiter + $waiter->end() if(ref $waiter); + + if(ref $console) { + $console->start() if(ref $waiter); + if(scalar @{$err} == 0) { + $console->message(sprintf(gettext("Write %d recordings in database."), scalar @merkIds)); + } else { + unshift(@{$err}, sprintf(gettext("Write only %d recordings in database. Can\'t assign %d recordings."), scalar @merkIds , scalar @{$err})); + lg join("\n", @$err); + $console->err($err); + } + + $console->redirect({url => '?cmd=rlist', wait => 1}) + if($console->typ eq 'HTML'); + } + return 1; +} + +# Routine um Callbacks zu registrieren und +# diese nach dem Aktualisieren der Aufnahmen zu starten +# ------------------ +sub updated { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $cb = shift || 0; + my $log = shift || 0; + + if($cb) { + push(@{$obj->{after_updated}}, [$cb, $log]); + } else { + foreach my $CB (@{$obj->{after_updated}}) { + next unless(ref $CB eq 'ARRAY'); + lg $CB->[1] + if($CB->[1]); + &{$CB->[0]}() + if(ref $CB->[0] eq 'CODE'); + } + } +} + +# ------------------ +sub refresh { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + + my $waiter; + if(ref $console) { + if($console->typ eq 'HTML') { + $waiter = $console->wait(gettext("Get informations from recordings ..."),0,1000,'no'); + } else { + $console->msg(gettext("Get informations from recordings ...")); + } + } + + return $obj->readData($watcher,$console,$waiter,1); +} + +# ------------------ +sub insert { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $attr = shift || return 0; + + my $sth = $obj->{dbh}->prepare( + qq| + REPLACE INTO RECORDS + (eventid, RecordId, RecordMD5, Path, Prio, Lifetime, State, Marks, Type ) + VALUES (?,?,md5(?),?,?,?,?,?,?) + |); + + $attr->{Marks} = "" + if(not $attr->{Marks}); + + return $sth->execute( + $attr->{eventid}, + $attr->{RecordId}, + $attr->{Path}, + $attr->{Path}, + $attr->{Prio}, + $attr->{Lifetime}, + $attr->{State}, + $attr->{Marks}, + $attr->{Type}, + ); +} + +# ------------------ +sub _updateEvent { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $event = shift || return undef; + + my $sth = $obj->{dbh}->prepare('UPDATE OLDEPG SET duration=?, starttime=FROM_UNIXTIME(?), addtime=FROM_UNIXTIME(?) where eventid=?'); + if(!$sth->execute($event->{duration},$event->{starttime},$event->{addtime},$event->{eventid})) { + error sprintf("Can't update Event!: '%s' !",$event->{eventid}); + return undef; + } + return $event; +} + +# ------------------
+sub _updateState {
# ------------------
+ my $obj = shift || return error ('No Object!');
+ my $oldattr = shift || return error ('Missing data');
+ my $attr = shift || return error ('No data to replace!');
+ + my $sth = $obj->{dbh}->prepare('UPDATE RECORDS SET RecordId=?, State=?, addtime=FROM_UNIXTIME(?) where RecordMD5=?'); + return $sth->execute($attr->{id},$attr->{state},time,$oldattr->{RecordMD5}); +} + +# ------------------ +sub analyze { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $recattr = shift || return error ('No data to analyze!');
+ + lg sprintf('Analyze record "%s" from system', + $recattr->{title}, + ); + + my $info = $obj->videoInfo($recattr->{title}, $recattr->{starttime}); + unless($info && ref $info eq 'HASH') { + error sprintf("Can't find recording '%s' with id : '%s' !",$recattr->{title}, $recattr->{id}); + return 0; + } + + my @t = split('~', $recattr->{title}); + my $title = $recattr->{title}; + my $subtitle; + if(scalar @t > 1) { # Splitt genre~title | subtitle + my @p = split('/', $info->{path}); + $subtitle = delete $t[-1] + if(scalar @p > 3 && $p[-2] ne '_'); + $subtitle = undef if(defined $subtitle and $subtitle eq ' '); + $title = join('~',@t); + } + + my $event = $obj->SearchEpgId( $recattr->{starttime}, $info->{duration}, $title, $subtitle, $info->{channel} ); + if($event) { + my $id = $event->{eventid}; + $event->{addtime} = time; + $event->{duration} = int($info->{duration}); + $event->{starttime} = $recattr->{starttime}; + $event = $obj->_updateEvent($event); + unless($event) { + return 0; + } + } else { + # Sollte kein Event gefunden werden so muss dieser in OLDEPG mit + # den vorhandenen Daten (lstr nummer) eingetragen werden und eine PseudoEventId (min(eventid)-1) + # erfunden werden ;) + $event = $obj->createOldEventId($recattr->{id}, $recattr->{starttime}, $info->{duration}, $title, $subtitle, $info); + unless($event) { + error sprintf("Can't create Event!: '%s' !",$recattr->{id}); + return 0; + } + } + + # Make Preview + my $command = $obj->videoPreview( $event->{eventid}, $info ); + push(@{$obj->{JOBS}}, $command) + if($command && not grep(/\Q$command/g,@{$obj->{JOBS}})); + + my $ret = { + title => $recattr->{title}, + RecordId => $recattr->{id}, + Duration => $info->{duration}, + Start => $recattr->{starttime}, + Path => $info->{path}, + Prio => $info->{Prio}, + Lifetime => $info->{Lifetime}, + eventid => $event->{eventid}, + Type => $info->{type} || 'UNKNOWN', + State => $recattr->{state} + }; + $ret->{Marks} = join(',', @{$info->{marks}}) + if(ref $info->{marks} eq 'ARRAY'); + return $ret; +} + +# ------------------ +sub videoInfo { +# ------------------ + my $obj = shift || return error ('No object!' ); + my $title = shift || return error ('No title!' ); + my $starttime = shift || return error ('No title!' ); + + lg sprintf('Get videoInfo from record "%s"', $title ); + + my $month=sprintf("%02d",(localtime($starttime))[4]+1); + my $day=sprintf("%02d",(localtime($starttime))[3]); + my $hour=sprintf("%02d",(localtime($starttime))[2]); + my $minute=sprintf("%02d",(localtime($starttime))[1]); + + my @files; + + $title =~ s/([\)\(\-\?\+\*\[\]\{\}])/\\$1/g; # Replace regex groupsymbols "),(,-,?,+,*,[,],{,}" + $title =~ s/([\/])/\./g; # Replace splash + + foreach my $f (@{$obj->{FILES}}) + { + push (@files, $f->[0]) + if(grep(/\~$title.*?\d{4}\-$month\-$day\.$hour[\:|\.]$minute.+?\d{3}\.vdr/,$f->[1])); + } + + unless(scalar @files) { + error sprintf("Can't assign recording with title: '%s' (%s/%s %s:%s)", $title,$month,$day,$hour,$minute); + return 0; + } + + my $status = {}; + + # Dateigröße von index.vdr für Aufnahmedauer ermitteln + if($files[0] && -e $files[0]) { + + my $path = dirname($files[0]); + + #Splitt 2005-01-16.04:35.88.99.rec + my ($year, $month, $day, $hour, $minute, $prio, $lifetime) + = (basename($path)) =~ /^(\d+)\-(\d+)\-(\d+)\.(\d+)[\:|\.](\d+)\.(\d+)\.(\d+)\.rec/si; +# if($year && $month && $day && $hour && $minute && $year >= 1970 && $year < 2038 ) { +# @{$status->{mtime}} = localtime(timelocal(0,int($minute),int($hour),$day,$month-1,$year-1900)); +# } else { +# my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, +# $atime,$mtime,$ctime,$blksize,$blocks) = stat $file; +# @{$status->{mtime}} = localtime $mtime; +# } + $status->{Prio} = $prio; + $status->{Lifetime} = $lifetime; + + $status->{duration} = $obj->_recordinglength($path); + + # Schnittmarken ermitteln + my $marks = sprintf("%s/marks.vdr", $path); + if(-r $marks) { + my $data = load_file($marks) + or error sprintf("I can't read file '%s'",$marks); + if($data) { + foreach my $zeile (split("\n", $data)) { + # 0:35:07.09 moved from [0:35:13.24 Logo start] by checkBlackFrameOnMark + my ($mark) = $zeile =~ /^(\d+\:\d+\:\d+\.\d+)/sg; + push(@{$status->{marks}}, $mark) + if(defined $mark); + } + } + } + + # Summary ermitteln + my $file = sprintf("%s/info.vdr", $path); + $file = sprintf("%s/summary.vdr", $path ) if(main::getVdrVersion() < 10325); + + $status->{type} = 'UNKNOWN'; + if(-r $file) { + my $text = load_file($file); + + # Neue Vdr Version 1.3.25! + if(main::getVdrVersion() >= 10325) { + my $cmod = main::getModule('CHANNELS'); + foreach my $zeile (split(/[\r\n]/, $text)) { + if($zeile =~ /^D\s+(.+)/s) { + $status->{summary} = $1; + $status->{summary} =~ s/\|/\r\n/g; # pipe used from vdr as linebreak + $status->{summary} =~ s/^\s+//; # no leading white space + $status->{summary} =~ s/\s+$//; # no trailing white space + } + elsif($zeile =~ /^C\s+(.+)$/s) { + $status->{channel} = $1; + $status->{type} = $cmod->getChannelType($status->{channel}); + } + elsif($zeile =~ /^T\s+(.+)$/s) { + $status->{title} = $1; + } + elsif($zeile =~ /^S\s+(.+)$/s) { + $status->{subtitle} = $1; + } + elsif($zeile =~ /^X\s+1\s+(.+)$/s) { + $status->{video} = $1; + } + elsif($zeile =~ /^X\s+2\s+(.+)$/s) { + $status->{audio} .= "\n" if($status->{audio}); + $status->{audio} .= $1; + } + } + } else { + $status->{summary} = $text; + } + } + + $status->{path} = $path; + } + + return $status; +} + +# ------------------ +sub videoPreview { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $eventid = shift || return error ('No eventid!'); + my $info = shift || return error ('No InfoHash!'); + my $rebuild = shift || 0; + + if ($obj->{previewcommand} eq 'Nothing') { + return 0; + } + if($info->{type} and $info->{type} eq 'RADIO') { + return 0; + } + + # Videodir + my $vdir = $info->{path}; + if(! -d $vdir ) { + error sprintf("Missing path ! %s",$!); + return 0; + } + + # Save dir + my $count = $obj->{previewcount}; + my $outdir = sprintf('%s/%lu_shot', $obj->{previewimages}, $eventid); + + # Stop here if enough files present + my @images = glob("$outdir/*.jpg"); + return 0 + if(scalar @images >= $count && !$rebuild); + + deleteDir($outdir) if(scalar @images && $rebuild); + + # or stop if two log's present, use two logs avoid to early run on current live recording + my $log = sprintf('%s/preview_1st.log', $outdir); + if(-e $log) { + $log = sprintf('%s/preview_2nd.log', $outdir); + if(-e $log) { + return 0; + } + } + + # Mplayer + unless(-x $obj->{previewbinary}) { + error("I can't find executable file as usable preview command !"); + return 0; + } + + unless(-d $outdir) { + if(!mkpath($outdir)) { + error sprintf("Can't mkpath '%s' : %s",$outdir,$!); + return 0; + } + } + + my $tmod = main::getModule('TIMERS'); + my $startseconds = ($tmod->{prevminutes} * 60) * 2; + my $endseconds = ($tmod->{afterminutes} * 60) * 2; + my $stepseconds = ($info->{duration} - ($startseconds + $endseconds)) / $count; + # reduced interval on short movies + if($stepseconds <= 0 or ($startseconds + ($count * $stepseconds)) > $info->{duration}) { + $stepseconds = $info->{duration} / ( $count + 2 ) ; + $startseconds = $stepseconds; + } + + my @files; + my @frames; + if ($obj->{previewcommand} eq 'vdr2jpeg') { + + my $m = ref $info->{marks} eq 'ARRAY' ? scalar(@{$info->{marks}}) : 0; + if($m > 1 && $info->{duration}) { + my $total = $info->{duration} * $obj->{framerate}; + my $limit = $count * 4; + my $x = 2; + my $y = 1; + while (scalar @frames < $count && $x < $limit) { + my $f = int($total / $x * $y); # 1/2, 1/3, 2/3, 1/4, 2/4, 3/4, 1/5, 2/5, 3/5 ... + for (my $n = 0;$n < $m; $n += 2 ) { + my $fin = $obj->_mark2frames(@{$info->{marks}}[$n]); + my $fout = $total; + $fout = $obj->_mark2frames(@{$info->{marks}}[$n+1]) if($n+1 < $m); + + if ($f >= $fin && $f <= $fout + && 0 == (grep {$f == $_;} @frames) + ) { + push(@frames, $f); + last; + } + } + ++$y; + if($y >= $x) { $x += 2; $y = 1; } + } + } + + my $s = int($startseconds * $obj->{framerate}); + while (scalar @frames < $count) { + push(@frames, $s); + $s += int( $stepseconds * $obj->{framerate} ); + } + } else { + @files = glob("$vdir/[0-9][0-9][0-9].vdr"); + foreach (@files) { s/(\")/\\$1/g; } + } + + $vdir =~ s/(\")/\\$1/g; + + my $scalex = 180; + my $mversions = { + 'MPlayer1.0pre5' => sprintf("%s -noautosub -noconsolecontrols -nosound -nolirc -nojoystick -quiet -vo jpeg -jpeg outdir=\"%s\" -ni -ss %d -sstep %d -vf scale -zoom -xy %d -frames %d \"%s\" >> \"%s\" 2>&1", + $obj->{previewbinary}, $outdir, $startseconds / 5, $stepseconds / 5, $scalex, $count, join("\" \"",@files), $log), + 'MPlayer1.0pre6' => sprintf("%s -noautosub -noconsolecontrols -nosound -nolirc -nojoystick -quiet -vo jpeg:outdir=\"%s\" -ni -ss %d -sstep %d -vf scale -zoom -xy %d -frames %d \"%s\" >> \"%s\" 2>&1", + $obj->{previewbinary}, $outdir, $startseconds / 5, $stepseconds / 5, $scalex, $count, join("\" \"",@files), $log), + 'vdr2jpeg' => sprintf("%s -r \"%s\" -f %s -x %d -o \"%s\" >> \"%s\" 2>&1", + $obj->{previewbinary}, $vdir, join(" -f ", @frames), $scalex, $outdir, $log), + }; + return $mversions->{$obj->{previewcommand}}; +} + + +sub _mark2frames{ + my $self = shift; + my $mark = shift; + my($h, $m, $s, $f) = split /[:.]/, $mark; + my $frame = (3600 * $h + 60 * $m + $s) * $self->{framerate} + $f ; + return $frame; +}; + +# ------------------ +sub SearchEpgId { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $start = shift || return error ('No Start!' ); + my $dur = shift || return; + my $title = shift || return error ('No Title!' ); + my $subtitle = shift; + my $channel = shift; + + my $sth; + my $bis = int($start + $dur); + if($subtitle && $channel && $channel ne "") { + $sth = $obj->{dbh}->prepare( +qq|SELECT * FROM OLDEPG WHERE + UNIX_TIMESTAMP(starttime) >= ? + AND UNIX_TIMESTAMP(starttime)+duration <= ? + AND title = ? + AND subtitle = ? + AND channel_id = ?|); + $sth->execute($start,$bis,$title,$subtitle,$channel) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } elsif($subtitle) { + $sth = $obj->{dbh}->prepare( +qq|SELECT * FROM OLDEPG WHERE + UNIX_TIMESTAMP(starttime) >= ? + AND UNIX_TIMESTAMP(starttime)+duration <= ? + AND title = ? + AND subtitle = ?|); + $sth->execute($start,$bis,$title,$subtitle) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } else { + $sth = $obj->{dbh}->prepare( +qq|SELECT * FROM OLDEPG WHERE + UNIX_TIMESTAMP(starttime) >= ? + AND UNIX_TIMESTAMP(starttime)+duration <= ? + AND title = ?|); + $sth->execute($start,$bis,$title) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } + return 0 if(!$sth); + + my $erg = $sth->fetchrow_hashref(); + return $erg + if($erg->{eventid} + and ( # check for equal subtitle + (not $subtitle and not $erg->{subtitle}) + or (($subtitle and $erg->{subtitle}) and ($subtitle eq $erg->{subtitle})) + ) + ); +} + +# ------------------ +sub createOldEventId { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || return error ('No Id!' ); + my $start = shift || return error ('No Starttime!' ); + my $duration = shift || 0; + my $title = shift || return error ('No Title!' ); + my $subtitle = shift; + my $info = shift; + +#warn($title); + my $attr = { + title => $title, + subtitle => $subtitle, + description => $info->{summary} || "", + channel => $info->{channel} || "<undef>", + duration => $duration, + starttime => $start, + video => $info->{video} || "", + audio => $info->{audio} || "", + addtime => time + }; + + $attr->{eventid} = $obj->{dbh}->selectrow_arrayref('select max(eventid)+1 from OLDEPG')->[0]; + $attr->{eventid} = 1000000000 if(not defined $attr->{eventid} or $attr->{eventid} < 1000000000 ); + + # dumper($attr); + + lg sprintf('Create OldEventId from event "%s" - "%s"', + $title, + $subtitle ? $subtitle : '', + ); + + my $sth = $obj->{dbh}->prepare('REPLACE INTO OLDEPG(eventid, title, subtitle, description, channel_id, duration, tableid, starttime, video, audio, addtime) VALUES (?,?,?,?,?,?,?,FROM_UNIXTIME(?),?,?,FROM_UNIXTIME(?))'); + $sth->execute( + $attr->{eventid}, + $attr->{title}, + $attr->{subtitle}, + $attr->{description}, + $attr->{channel}, + int($attr->{duration}), + $attr->{tableid}, + $attr->{starttime}, + $attr->{video}, + $attr->{audio}, + $attr->{addtime} + ); + + return $attr; +} + +# ------------------ +sub display { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $recordid = shift || return $console->err(gettext("No RecordID to display the recording! Please use rdisplay 'rid'")); + + my $start = "e.starttime"; + my $stopp = "FROM_UNIXTIME(UNIX_TIMESTAMP(e.starttime) + e.duration)"; + + $start = "UNIX_TIMESTAMP(e.starttime)" if($console->typ eq "HTML"); + $stopp = "UNIX_TIMESTAMP(e.starttime) + e.duration" if($console->typ eq "HTML"); + + my $sql = qq| +select + r.RecordMD5 as RecordId, + r.eventid, + e.Duration, + r.Marks, + r.Prio, + r.Lifetime, + $start as StartTime, + $stopp as StopTime, + e.title as Title, + e.subtitle as SubTitle, + e.description as Description, + r.State as New, + r.Type as Type, + e.channel_id +from + RECORDS as r,OLDEPG as e +where + r.eventid = e.eventid + and RecordMD5 = ? +|; + + my $fields = fields($obj->{dbh}, $sql); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($recordid) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchrow_hashref(); + + $obj->_loadreccmds; + + my $param = { + previews => $obj->getPreviewFiles($erg->{eventid}), + reccmds => [@{$obj->{reccmds}}], + }; + + my $cmod = main::getModule('CHANNELS'); + $erg->{Channel} = $cmod->ChannelToName($erg->{channel_id}) + if($erg->{channel_id} && $erg->{channel_id} ne "<undef>"); + delete $erg->{channel_id}; + + $console->table($erg, $param); +} + +# ------------------ +sub play { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $recordid = shift || return $console->err(gettext("No RecordID to play the recording! Please use rplay 'rid'")); + + my $sql = qq|SELECT RecordID FROM RECORDS WHERE RecordMD5 = ?|; + my $sth = $obj->{dbh}->prepare($sql);
+ my $rec; + if(!$sth->execute($recordid) + || !($rec = $sth->fetchrow_hashref())) { + return $console->err(sprintf(gettext("RecordID '%s' does not exist in the database!"),$recordid)); + } + + my $cmd = sprintf('PLAY %d begin', $rec->{RecordID}); + return $obj->{svdrp}->scommand($watcher, $console, $cmd); +} + +# ------------------ +sub cut { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $recordid = shift || return $console->err(gettext("No RecordID to play the recording! Please use rplay 'rid'")); + + my $sql = qq|SELECT RecordID FROM RECORDS WHERE RecordMD5 = ?|; + my $sth = $obj->{dbh}->prepare($sql);
+ my $rec; + if(!$sth->execute($recordid) + || !($rec = $sth->fetchrow_hashref())) { + return $console->err(sprintf(gettext("RecordID '%s' does not exist in the database!"),$recordid)); + } + + my $cmd = sprintf('EDIT %d', $rec->{RecordID}); + return $obj->{svdrp}->scommand($watcher, $console, $cmd); +} + +# ------------------ +sub list { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $text = shift || ""; + my $params = shift; + + my $deep = 1; + my $folder = scalar (my @a = split('/',$obj->{videodir})) + 1; + + my $select = "e.eventid = r.eventid"; + if($text) { + $deep = scalar (my @c = split('~',$text)); + $folder += $deep; + $deep += 1; + + $text =~ s/\'/\\\'/sg; + $text =~ s/%/\\%/sg; + $select .= qq| +AND ( + SUBSTRING_INDEX(CONCAT_WS('~',e.title,e.subtitle), '~', $deep) LIKE '$text' + OR + SUBSTRING_INDEX(CONCAT_WS('~',e.title,e.subtitle), '~', $deep) LIKE '$text~%' +) +|; + + } + + my %f = ( + 'Id' => umlaute(gettext('Service')), + 'Title' => umlaute(gettext('Title')), + 'Subtitle' => umlaute(gettext('Subtitle')), + 'Duration' => umlaute(gettext('Duration')), + ); + + my $start = "e.starttime"; + $start = "UNIX_TIMESTAMP(e.starttime)" if($console->typ eq "HTML"); + + my $sql = qq| +SELECT + r.RecordMD5 as $f{'Id'}, + r.eventid as __EventId, + e.title as $f{'Title'}, + e.subtitle as $f{'Subtitle'}, + SUM(e.duration) as $f{'Duration'}, + $start as __RecordStart, + SUM(State) as __New, + r.Type as __Type, + COUNT(*) as __Group, + SUBSTRING_INDEX(CONCAT_WS('~',e.title,e.subtitle), '~', $deep) as __fulltitle, + IF(COUNT(*)>1,0,1) as __IsRecording, + e.description as __description +FROM + RECORDS as r, + OLDEPG as e +WHERE + $select +GROUP BY + SUBSTRING_INDEX(r.Path, '/', IF(Length(e.subtitle)<=0, $folder + 1, $folder)) +|; + + my $fields = fields($obj->{dbh}, $sql); + + my $sortby = "__fulltitle"; + $sortby = '__RecordStart' + if($text); + + $sortby = $params->{sortby} + if(exists $params->{sortby} && grep(/^$params->{sortby}$/i,@{$fields})); + $sql .= "order by __IsRecording asc, $sortby"; + if(exists $params->{desc} && $params->{desc} == 1) { + $sql .= " desc"; } + else { + $sql .= " asc"; } + + my $erg = $obj->{dbh}->selectall_arrayref($sql); + unshift(@$erg, $fields); + + my $param = { + sortable => 1, + usage => $obj->{CapacityMessage}, + used => $obj->{CapacityPercent}, + total => $obj->{CapacityTotal}, + free => $obj->{CapacityFree}, + previewcommand => $obj->{previewlistthumbs}, + getPreview => sub{ return $obj->getPreviewFiles(@_) }, + }; + return $console->table($erg, $param); +} + +# ------------------ +sub search { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $text = shift || return $obj->list($watcher,$console); + my $params = shift; + + my $search = buildsearch("e.title,e.subtitle,e.description",$text); + + my %f = ( + 'Id' => umlaute(gettext('Service')), + 'Title' => umlaute(gettext('Title')), + 'Subtitle' => umlaute(gettext('Subtitle')), + 'Duration' => umlaute(gettext('Duration')), + ); + + my $start = "e.starttime"; + $start = "UNIX_TIMESTAMP(e.starttime)" if($console->typ eq "HTML"); + + my $sql = qq| +SELECT + r.RecordMD5 as $f{'Id'}, + r.eventid as __EventId, + e.title as $f{'Title'}, + e.subtitle as $f{'Subtitle'}, + e.duration as $f{'Duration'}, + $start as __RecordStart , + r.State as __New, + r.Type as __Type, + 0 as __Group, + CONCAT_WS('~',e.title,e.subtitle) as __fulltitle, + 1 as __IsRecording, + e.description as __description +FROM + RECORDS as r, + OLDEPG as e +WHERE + e.eventid = r.eventid + AND ( $search ) +|; + + my $fields = fields($obj->{dbh}, $sql); + + my $sortby = "e.starttime"; + $sortby = $params->{sortby} + if(exists $params->{sortby} && grep(/^$params->{sortby}$/i,@{$fields})); + $sql .= "order by $sortby"; + if(exists $params->{desc} && $params->{desc} == 1) { + $sql .= " desc"; } + else { + $sql .= " asc"; } + + my $erg = $obj->{dbh}->selectall_arrayref($sql); + unshift(@$erg, $fields); + + my $param = { + sortable => 1, + usage => $obj->{CapacityMessage}, + used => $obj->{CapacityPercent}, + total => $obj->{CapacityTotal}, + free => $obj->{CapacityFree}, + previewcommand => $obj->{previewcommand}, + getPreview => sub{ return $obj->getPreviewFiles(@_) }, + }; + return $console->table($erg, $param); +} + +# ------------------ +sub delete { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $record = shift || return $console->err(gettext("No Recording ID to delete! Please use rdelete 'id'")); + my $answer = shift || 0; + + my @rcs = split(/_/, $record); + my @todelete; + my %rec; + + foreach my $item (@rcs) { + if($item =~ /^all\:(\w+)/i) { + my $ids = $obj->getGroupIds($1); + for(@$ids) { + $rec{$_} = 1; + } + } else { + $rec{$item} = 1; + } + } + my @recordings = keys %rec; + + my $sql = sprintf("SELECT r.RecordId,CONCAT_WS('~',e.title,e.subtitle),r.RecordMD5 FROM RECORDS as r,OLDEPG as e WHERE e.eventid = r.eventid and r.RecordMD5 IN (%s) ORDER BY r.RecordId desc", join(',' => ('?') x @recordings)); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@recordings) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $data = $sth->fetchall_arrayref(); # Query as array to hold ordering ! + + foreach my $recording (@$data) { + # Make hash for better reading + my $r = { + Id => $recording->[0], + Title => $recording->[1] + }; + + if(ref $console and $console->{TYP} eq 'CONSOLE') { + $console->table($r); + my $confirm = $console->confirm({ + typ => 'confirm', + def => 'y', + msg => gettext('Are you sure to delete this recording?'), + }, $answer); + next if(! $answer eq 'y'); + } + + debug sprintf('Call delete recording with title "%s", id: %d%s', + $r->{Title}, + $r->{Id}, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + + $obj->{svdrp}->queue_cmds(sprintf("delr %s",$r->{Id})); + push(@todelete,$r->{Title}); # Remember title + + # Remove recordings from request, if found in database + my $i = 0; + for my $x (@recordings) { + if ( $x eq $recording->[2] ) { # Remove known MD5 from user request + splice @recordings, $i, 1; + } else { + $i++; + } + } + } + + $console->err(sprintf(gettext("Recording with number '%s' does not exist in the database!"), + join('\',\'',@recordings))) if(ref $console and scalar @recordings); + + if($obj->{svdrp}->queue_cmds('COUNT')) { + + my $msg = sprintf(gettext("Recording '%s' to delete"),join('\',\'',@todelete)); + + my $erg = $obj->{svdrp}->queue_cmds("CALL"); # Aufrufen der Kommandos + + my $waiter; + if($obj->{svdrp}->err) { + $console->err($erg) if(ref $console); + } else { + if(ref $console) { + if($console->typ eq 'HTML') { + $waiter = $console->wait($msg,0,1000,'no'); + }else { + $console->msg($msg); + } + } + } + sleep(1); + + $obj->readData($watcher,$console,$waiter); + + } else { + $console->err(gettext("No recording to delete!")); + } + + return 1; +} + + +sub is_empty_dir { + my $dir = shift; + local (*DIR); + return unless opendir DIR, $dir; + while (defined($_ = readdir DIR)) { + next if /^\.\.?$/; + closedir DIR; + return 0; + } + closedir DIR; + return 1; +} + +# ------------------ +sub redit { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $recordid = shift || return $console->err(gettext("No RecordID to edit!")); + my $data = shift || 0; + + my $rec; + if($recordid) { + my $sql = qq| +SELECT + CONCAT_WS('~',e.title,e.subtitle) as title, + e.eventid as EventId, + r.Path, + r.Prio, + r.Lifetime +FROM + RECORDS as r, + OLDEPG as e +WHERE + e.eventid = r.eventid + AND ( r.RecordMD5 = ? ) +|; + my $sth = $obj->{dbh}->prepare($sql);
+ $sth->execute($recordid) + or return $console->err(sprintf(gettext("RecordID '%s' does not exist in the database!"),$recordid)); + $rec = $sth->fetchrow_hashref(); + } + + my $file = sprintf("%s/info.vdr", $rec->{Path}); + + my $desc; + my $channel; + my $video; + my $audio; + + if(-r $file) { + my $text = load_file($file) + or $console->err(sprintf(gettext("Can't open file '%s' : %s"),$file,$!)); + + foreach my $zeile (split(/[\r\n]/, $text)) { + if($zeile =~ /^D\s+(.+)/s) { + $desc = $1; + $desc =~ s/\|/\r\n/g; # pipe used from vdr as linebreak + $desc =~ s/^\s+//; # no leading white space + $desc =~ s/\s+$//; # no trailing white space + } + elsif($zeile =~ /^C\s+(.+)$/s) { + $channel = $1; + } + elsif($zeile =~ /^X\s+1\s+(.+)$/s) { + $video = $1; + } + elsif($zeile =~ /^X\s+2\s+(.+)$/s) { + $audio .= "\n" if($audio); + $audio .= $1; + } + } + } + + my $marksfile = sprintf('%s/%s', $rec->{Path}, 'marks.vdr'); + my $marks = (-r $marksfile ? load_file($marksfile) : ''); + + $rec->{title} =~s#~+#~#g; + $rec->{title} =~s#^~##g; + $rec->{title} =~s#~$##g; + + my $mod = main::getModule('CHANNELS'); + + my $questions = [ + 'title' => { + msg => gettext('Title of recording'), + def => $rec->{title}, + req => gettext("This is required!"), + }, + 'lifetime' => { + typ => 'integer', + msg => gettext('Lifetime (0 .. 99)'), + def => int($rec->{Lifetime}), + check => sub{ + my $value = shift || 0; + if($value >= 0 and $value < 100) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + req => gettext("This is required!"), + }, + 'priority' => { + typ => 'integer', + msg => gettext('Priority (0 .. 99)'), + def => int($rec->{Prio}), + check => sub{ + my $value = shift || 0; + if($value >= 0 and $value < 100) { + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + req => gettext("This is required!"), + }, + 'channel' => { + typ => 'list', + def => $mod->ChannelToPos($channel), + choices => sub { + my $erg = $mod->ChannelArray('Name'); + unshift(@$erg, gettext("Undefined")); + return $erg; + }, + msg => gettext('Channel'), + check => sub{ + my $value = shift || return; + + if(my $ch = $mod->PosToChannel($value) || $mod->NameToChannel($value) ) { + return $ch; + } elsif( ! $mod->NameToChannel($value)) { + return undef, sprintf(gettext("This channel '%s' does not exist!"),$value); + } else { + return undef, gettext("This is required!"); + } + }, + }, + 'summary' => { + msg => gettext("Summary"), + def => $desc || '', + }, + 'video' => { + msg => gettext('Video'), + def => $video, + }, + 'audio' => { + msg => gettext('Audio'), + def => $audio, + }, + 'marks' => { + param => {type => 'text'}, + msg => gettext("Marks"), + def => $marks || '', + }, + ]; + + $data = $console->question(gettext("Edit recording"), $questions, $data); + + if(ref $data eq 'HASH') { + my $touchVDR = 0; + my $dropEPGEntry = 0; + my $ChangeRecordingData = 0; + + debug sprintf('Record "%s" is changed%s', + $rec->{title}, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + if($data->{summary} ne $desc + or $data->{channel} ne $channel + or $data->{video} ne $video + or $data->{audio} ne $audio) { + my $out; + $data->{summary} =~ s/\r\n/\|/g; # pipe used from vdr as linebreak + $data->{summary} =~ s/\n/\|/g; # pipe used from vdr as linebreak + $data->{summary} =~ s/^\s+//; # no leading white space + $data->{summary} =~ s/\s+$//; # no trailing white space + if(-r $file) { + my $text = load_file($file) + or $console->err(sprintf(gettext("Can't open file '%s' : %s"),$file,$!)); + foreach my $zeile (split(/[\r\n]/, $text)) { + $zeile =~ s/^\s+//; + $zeile =~ s/\s+$//; + if($zeile =~ /^D\s+(.+)/s) { + if(defined $data->{summary} && $data->{summary}) { + $out .= "D ". $data->{summary} . "\n"; + undef $data->{summary}; + } + } + elsif($zeile =~ /^C\s+(.+)$/s) { + if(defined $data->{channel} && $data->{channel}) { + $data->{channel} =~ s/^\s+//; + $data->{channel} =~ s/\s+$//; + $out .= "C ". $data->{channel} . "\n" if($data->{channel}); + undef $data->{channel}; + } + } + elsif($zeile =~ /^X\s+1\s+(.+)$/s) { + if(defined $data->{video} && $data->{video}) { + $data->{video} =~ s/^\s+//; + $data->{video} =~ s/\s+$//; + $out .= "X 1 ". $data->{video} . "\n" if($data->{video}); + undef $data->{video}; + } + } + elsif($zeile =~ /^X\s+2\s+(.+)$/s) { + if(defined $data->{audio} && $data->{audio}) { + foreach my $line (split(/[\r\n]/, $data->{audio})) { + $line =~ s/^\s+//; + $line =~ s/\s+$//; + next unless($line); + $out .= "X 2 ". $line . "\n"; + } + undef $data->{audio}; + } + } else { + $out .= $zeile . "\n" if($zeile); + } + } + } + if(defined $data->{channel} && $data->{channel}) { + $data->{channel} =~ s/^\s+//; + $data->{channel} =~ s/\s+$//; + $out .= "C ". $data->{channel} . "\n" if($data->{channel}); + } + if(defined $data->{summary} && $data->{summary}) { + $out .= "D ". $data->{summary} . "\n"; + } + if(defined $data->{video} && $data->{video}) { + $data->{video} =~ s/^\s+//; + $data->{video} =~ s/\s+$//; + $out .= "X 1 ". $data->{video} . "\n" if($data->{video}); + } + if(defined $data->{audio} && $data->{audio}) { + foreach my $line (split(/[\r\n]/, $data->{audio})) { + $line =~ s/^\s+//; + $line =~ s/\s+$//; + $out .= "X 2 ". $line . "\n" if($line); + } + } + + save_file($file, $out) + or return $console->err(sprintf(gettext("Can't write file '%s' : %s"),$file,$!)); + $dropEPGEntry = 1; + } + + if($data->{marks} ne $marks) { + save_file($marksfile, $data->{marks}) + or return $console->err(sprintf(gettext("Can't write file '%s' : %s"),$marksfile,$!)); + $ChangeRecordingData = 1; + } + + + if($data->{lifetime} ne $rec->{Lifetime} + or $data->{priority} ne $rec->{Prio}) { + + my @options = split('\.', $rec->{Path}); + + $options[-2] = sprintf("%02d",$data->{lifetime}) + if($data->{lifetime} ne $rec->{Lifetime}); + + $options[-3] = sprintf("%02d",$data->{priority}) + if($data->{priority} ne $rec->{Prio}); + + my $newPath = join('.', @options); + + move($rec->{Path}, $newPath) + or return $console->err(sprintf(gettext("Recording: '%s', can't move to '%s' : %s"),$rec->{title},$newPath,$!)); + + $rec->{Path} = $newPath; + $touchVDR = 1; + $ChangeRecordingData = 1; + } + + $data->{title} =~s#~+#~#g; + $data->{title} =~s#^~##g; + $data->{title} =~s#~$##g; + + if($data->{title} ne $rec->{title}) { + + # Rename auf der Platte + my $newPath = sprintf('%s/%s/%s', $obj->{videodir}, $obj->translate($data->{title}),basename($rec->{Path})); + + my $parentnew = dirname($newPath); + unless( -d $parentnew) { + mkpath($parentnew) + or return $console->err(sprintf(gettext("Recording: '%s', can't mkpath: '%s' : %s"),$rec->{title},$parentnew,$!)); + } + + move($rec->{Path},$newPath) + or return $console->err(sprintf(gettext("Recording: '%s', can't move to '%s' : %s"),$rec->{title},$data->{title},$!)); + + my $parentold = dirname($rec->{Path}); + if($obj->{videodir} ne $parentold + and -d $parentold + and is_empty_dir($parentold)) { + rmdir($parentold) + or return $console->err(sprintf(gettext("Recording: '%s', can't remove '%s' : %s"),$rec->{title},$parentold,$!)); + } + + $ChangeRecordingData = 1; + $dropEPGEntry = 1; + $touchVDR = 1; + } + + if($dropEPGEntry) { # Delete EpgOld Entrys + my $sth = $obj->{dbh}->prepare('DELETE FROM OLDEPG WHERE eventid = ?'); + $sth->execute($rec->{EventId}) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } + + if($ChangeRecordingData) { + my $sth = $obj->{dbh}->prepare('DELETE FROM RECORDS WHERE RecordMD5 = ?'); + $sth->execute($recordid) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + } + + if($touchVDR) { #Ab 1.3.11 resync with touch /video/.update + touch($obj->{videodir}."/.update"); + } + + my $waiter; + if(ref $console) { + if($console->typ eq 'HTML') { + $waiter = $console->wait(gettext('Recording is edited!'),0,1000,'no'); + }else { + $console->msg(gettext('Recording is edited!')); + } + } + $obj->readData($watcher,$console,$waiter); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 1}) + if(ref $console and $console->typ eq 'HTML'); + } + + return 1; +} + +# ------------------ +# Load Reccmds's +sub _loadreccmds { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + unless($obj->{reccmds}) { + $obj->{reccmds} = []; + if(-r $obj->{commandfile} and my $text = load_file($obj->{commandfile})) { + foreach my $zeile (split(/\n/, $text)) { + if($zeile !~ /^\#/ and $zeile !~ /^$/ and $zeile !~ /true/) { + push(@{$obj->{reccmds}}, $zeile); + } + } + } + } +} + +# ------------------ +sub conv { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $data = shift || 0; + + $obj->_loadreccmds; + + unless(scalar @{$obj->{reccmds}}) { + $console->err(gettext('No reccmds.conf on your System!')); + return 1; + } + + unless($data) { + $console->err(gettext("Please use rconvert 'cmdid_rid'")); + unshift(@{$obj->{reccmds}}, ['Descr.', 'Command']); + $console->table($obj->{reccmds}); + $obj->list($watcher, $console); + } + + my ($cmdid, $recid) = split(/[\s_]/, $data); + my $cmd = (split(':', $obj->{reccmds}->[$cmdid-1]))[-1] || return $console->err(gettext("I can't find this CommandID")); + my $path = $obj->IdToPath($recid) || return $console->err(gettext("I can't find this RecordID")); + + debug sprintf('Call command "%s" on record "%s"%s', + $cmd, + $path, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + my $call = "$cmd \"$path\""; + my $output = `$call`; + if( $? >> 8 > 0) { + $console->message(sprintf(gettext("Sorry! Call %s %s Error output: %s"), $cmd, $path, $output)); + } else { + $console->message(sprintf(gettext("Call %s %s With output: %s"), $cmd, $path, $output)); + } + $console->link({ + text => gettext("Back to recordings list"), + url => "?cmd=rlist", + }) if($console->typ eq 'HTML'); + return 1; +} + +# ------------------ +sub status { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $lastReportTime = shift; + + my $sql = qq| +SELECT + r.RecordId as __Id, + r.eventid as __EventId, + e.title, + e.subtitle, + FROM_UNIXTIME(e.Duration,'%h:%i:%s') as Duration, + e.starttime as __RecordStart +FROM + RECORDS as r, + OLDEPG as e +WHERE + e.eventid = r.eventid + and UNIX_TIMESTAMP(e.starttime) > ? +ORDER BY + e.starttime asc +|; + my $fields = fields($obj->{dbh}, $sql); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($lastReportTime) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_arrayref(); + unshift(@$erg, $fields); + return { + message => sprintf(gettext('%d new recordings since last report time %s'), + (scalar @$erg -1), scalar localtime($lastReportTime)), + table => $erg, + }; +} + + +# ------------------ +sub IdToPath { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || return undef; + + my $sth = $obj->{dbh}->prepare('select Path from RECORDS where RecordMD5 = ?'); + $sth->execute($id) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + return $sth->fetchrow_hashref()->{Path}; +} + +# ------------------ +sub getPreviewFiles { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $id = shift || return error ('No EventID!' ); + + # look for pictures + my $outdir = sprintf('%s/%lu_shot', $obj->{previewimages}, $id); + if(my @previews = glob("$outdir/[0-9]*.jpg")) { + splice(@previews,$obj->{previewcount},scalar(@previews)) + if(scalar(@previews) > $obj->{previewcount}); + map { + $_ =~ s/^$obj->{previewimages}/previewimages/ + } @previews; + return \@previews; + } else { + return undef; + } +} + +# ------------------ +sub getGroupIds { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $recid = shift || return error ('No Record ID!' ); + + my $epgid = getDataById($recid, 'RECORDS', 'RecordMD5'); + if(!$epgid) { + error sprintf("Can't find Record for id %s!", $recid); + return; + } + my $epgdata = main::getModule('EPG')->getId($epgid->{eventid}); + + my $text = $epgdata->{title}; + + my $deep = 1; + my $folder = scalar (my @a = split('/',$obj->{videodir})) + 1; + + my $select = "e.eventid = r.eventid"; + if($text) { + $deep = scalar (my @c = split('~',$text)); + $folder += $deep; + $deep += 1; + + $text =~ s/\'/\\\'/sg; + $text =~ s/%/\\%/sg; + $select .= qq| +AND ( + SUBSTRING_INDEX(CONCAT_WS('~',e.title,e.subtitle), '~', $deep) LIKE '$text' + OR + SUBSTRING_INDEX(CONCAT_WS('~',e.title,e.subtitle), '~', $deep) LIKE '$text~%' +) +|; + + } + + my $sql = qq| +SELECT + r.RecordMD5 +FROM + RECORDS as r, + OLDEPG as e +WHERE + $select +GROUP BY + SUBSTRING_INDEX(r.Path, '/', IF(Length(e.subtitle)<=0, $folder + 1, $folder)) +|; + + my $erg = $obj->{dbh}->selectall_arrayref($sql); + + my $ret = []; + for(@{$erg}) { + push(@$ret, $_->[0]); + } + return $ret; +} + + +# ------------------ +sub translate { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $title = shift || return error ('No Title in translate!'); + my $vfat = shift || $obj->{vfat}; + + if($vfat eq 'y') + { + $title =~ s/([^üäößa-z0-9\&\!\-\s\.\@\~\,\(\)\%\+])/sprintf('#%X', ord($1))/seig; + $title =~ s/[^üäößa-z0-9\!\&\-\#\.\@\~\,\(\)\%\+]/_/sig; + # Windows can't handle '.' at the end of directory names + $title =~ s/(\.$)/\#2E/sig; + $title =~ s/(\.~)/\#2E~/sig; + } else { + $title =~ s/\'/\x01/sg; + $title =~ s/\//\x02/sg; + $title =~ s/ /_/sg; + } + $title =~ s/~/\//sg; + + return $title; +} + +# ------------------ +# Length of recording in seconds, +# return value as integer +sub _recordinglength { +# ------------------ + my $obj = shift || return 0, error ('No Object!' ); + my $path = shift || return 0, error ('Missing path from recording!' ); + + my $f = sprintf("%s/index.vdr", $path); + my $r = sprintf("%s/001.vdr", $path); + + # Pseudo Recording (DIR) + return 0 if(! -r $f and ! -s $r); + + if(-r $f) { + my $bytes = stat($f)->size; + return int(($bytes / 8) / 25); + } else { + error sprintf("Couldn't read : '%s'", $f); + } + return 0; +} + +# ------------------ +sub converttitle { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $title = shift || return error ('No Title in translate!'); + my $vfat = shift || $obj->{vfat}; + + if($vfat eq 'y') { + $title =~ s/\#([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; + $title =~ s/\x03/:/g; # See backward compat.. at recordings.c + } + + $title =~ s/\x01/\'/g; + $title =~ s/\x02/\\/g; + + $title =~ s/_/ /g; + $title =~ s/\//~/g; + + return $title; +} + +# ------------------
+sub suggest {
# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $search = shift; + my $params = shift; + + if($search) {
+ my $sql = qq|
+ SELECT
+ e.title as title
+ FROM + RECORDS as r, + OLDEPG as e + WHERE + e.eventid = r.eventid + AND ( e.title LIKE ? )
+ GROUP BY + title +UNION + SELECT
+ e.subtitle as title
+ FROM + RECORDS as r, + OLDEPG as e + WHERE + e.eventid = r.eventid + AND ( e.subtitle LIKE ? )
+ GROUP BY + title +ORDER BY + title +LIMIT 25
+ |; + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute('%'.$search.'%','%'.$search.'%') + or return error "Can't execute query: $sth->errstr."; + my $result = $sth->fetchall_arrayref();
+ $console->table($result)
+ if(ref $console && $result); + }
+}
+ + +1; diff --git a/lib/XXV/MODULES/REMOTE.pm b/lib/XXV/MODULES/REMOTE.pm new file mode 100644 index 0000000..dab705b --- /dev/null +++ b/lib/XXV/MODULES/REMOTE.pm @@ -0,0 +1,279 @@ +package XXV::MODULES::REMOTE; + +use strict; + +use Tools; +use Locale::gettext; +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'REMOTE', + Prereq => { + # 'Perl::Module' => 'Description', + }, + Description => gettext('This module emulate a remote control.'), + Version => '0.01', + Date => '10.10.2004', + Author => 'xpix', + Level => 'user', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + monitor => { + description => gettext('Grab video framebuffer, as preview on remotecontrol.'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + commands => { + description => gettext('The path to the commands.conf'), + default => '/var/lib/vdr/commands.conf', + type => 'file', + required => gettext('This is required!'), + }, + }, + Commands => { + remote => { + description => gettext("Display ir remote 'cmd'"), + short => 'r', + callback => sub{ $obj->remote(@_) }, + DenyClass => 'remote', + }, + switch => { + description => gettext("Switch to channel 'cid'"), + short => 'sw', + callback => sub{ $obj->switch(@_) }, + DenyClass => 'remote', + }, + command => { + description => gettext("Call the command 'cid'"), + short => 'cmd', + callback => sub{ $obj->command(@_) }, + DenyClass => 'remote', + }, + cmdlist => { + description => gettext("List the commands"), + short => 'cmdl', + callback => sub{ $obj->list(@_) }, + DenyClass => 'remote', + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + main::after(sub{ + $obj->{svdrp} = main::getModule('SVDRP'); + unless($obj->{svdrp}) { + panic ("Can't get modul SVDRP"); + return 0; + } + + $obj->{CMDS} = $obj->parse(); + return 1; + }, "REMOTE: Parse Commandfile ..."); + + return 1; +} + +# ------------------ +sub parse { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return 0 + unless (exists $obj->{commands}); + + if(! -r $obj->{commands}) { + error (sprintf("can't open file '%s' : %s",$obj->{commands},$!)); + return 0; + } + + my $cmds = load_file($obj->{commands}); + + my $c = 0; + my $ret = {}; + foreach my $zeile (split("\n", $cmds)) { + next if($zeile =~ /^\#/); + my ($cmd, $batch) = split('\s*\:\s*', $zeile); + + $ret->{$c++} = { + cmd => $cmd, + bat => $batch, + } if($cmd and $batch); + } + return $ret; +} + +# ------------------ +sub list { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $cmds = $obj->parse(); + + my @list = (['__Id', 'Name', 'Cmd']); + foreach my $id (sort {$a <=> $b} keys %$cmds) { + push(@list, [$id, $cmds->{$id}->{cmd}, $cmds->{$id}->{bat}]); + } + + return $console->table(\@list); +} + +# ------------------ +sub command { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $command = shift || return error ('No Command!'); + my $cmds = $obj->parse(); + + return $console->err(gettext('This cmd id does not exist!')) + unless(exists $cmds->{$command}); + + $console->message(my $msg = sprintf(gettext('Try to start command: %s with cmd: %s'), + $cmds->{$command}->{cmd}, $cmds->{$command}->{bat})); + + lg $msg; + + my $out; + open(README, "$cmds->{$command}->{bat} 2>&1 |") or return error("Can't run program: $!"); + while(<README>) { + $out .= $_; + } + close(README); + return $console->message($out, { + tags => { + first => "<pre>", + last => "</pre>" + } + } ); +} + + +# ------------------ +sub remote { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $command = shift; + + debug sprintf('Call remote with command "%s"%s', + $command, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + unless($command) { + my $mod = main::getModule('GRAB'); + my $params = { + width => $mod->{xsize}, + height => $mod->{ysize}, + monitor => $obj->{monitor} eq "y" ? 1 : 0 + }; + return $console->remote(undef, $params); + } else { + # the svdrp module + my $svdrp = $obj->{svdrp}; + + my $translate = { + '<' => 'Channel-', + '>' => 'Channel+', + '+' => 'Volume+', + '-' => 'Volume-', + '>>' => 'FastFwd', + '<<' => 'FastRew', + 'VolumePlus' => 'Volume+', + 'VolumeMinus' => 'Volume-', + 'Null' => '0', + }; + + $command = $translate->{$command} + if(exists $translate->{$command}); + + # the command + my $cmd = sprintf('hitk %s', $command); + my $erg = $svdrp->command($cmd); + + $console->msg($erg, $svdrp->err) + if(ref $console); + } + return 1; +} + +# ------------------ +sub switch { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $channel = shift || ''; + + lg sprintf('Call switch with channel "%s"%s', + $channel, + ( ref $console && $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + # the svdrp module + my $svdrp = $obj->{svdrp}; + + # the command + my $cmd = sprintf('chan %s', $channel); + my $erg = $svdrp->command($cmd); + + my ($ret) = $erg->[1] =~ /^\d{3}\s*(.+)/s; + + $console->msg($erg, $svdrp->err) + if(ref $console); + $console->redirect({url => $console->{browser}->{Referer}, wait => 1}) + if(ref $console and $console->typ eq 'HTML'); + + + return $ret; +} + +1; diff --git a/lib/XXV/MODULES/REPORT.pm b/lib/XXV/MODULES/REPORT.pm new file mode 100644 index 0000000..b859c95 --- /dev/null +++ b/lib/XXV/MODULES/REPORT.pm @@ -0,0 +1,288 @@ +package XXV::MODULES::REPORT; + +use strict; + +use Tools; +use Locale::gettext; + + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'REPORT', + Prereq => { + # 'Perl::Module' => 'Description', + }, + Description => gettext('This module read in every module the status information and display this. Also this module send this informations e.g. as mail report.'), + Version => '0.01', + Date => '19.04.2005', + Author => 'xpix', + Level => 'user', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + interval => { + description => gettext('Time in hours to send the report.'), + default => 6, + type => 'integer', + required => gettext('This is required!'), + }, + host => { + description => gettext('Used host of referred link inside reports.'), + default => main::getModule('STATUS')->name, + type => 'host', + }, + }, + Commands => { + report => { + description => gettext("Display the report screen 'modname'"), + short => 'rp', + callback => sub{ $obj->report(@_) }, + }, + request => { + description => gettext("Display the actual news site 'typ'"), + short => 'req', + callback => sub{ $obj->request(@_) }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # the big Config + $self->{CONFIG} = $attr{'-config'}; + + # the dbh handle + $self->{dbh} = delete $attr{'-dbh'}; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{LastReportTime} = time; + + # Interval to send report + Event->timer( + interval => $self->{interval}*3600, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ + $self->report(); + $self->{LastReportTime} = time; + }, + ); + + # The Initprocess + my $erg = $self->init or return error('Problem to initialize module'); + + # Initiat after load modules ... + main::after(sub{ + my $start = main::getStartTime; + $self->news( + sprintf(gettext('Restart the xxv system at: %s!'), datum($start,'voll')), + undef, + undef, + undef, + 'important', + ); + return 1; + }, "Send restart Message to News channel ..."); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + # Load the NEWS Plugins ... + my @mods = glob($obj->{paths}->{NEWSMODS}.'/*.pm'); + + # Try to use the news plugins + foreach my $module (reverse @mods) { + my $moduleName = 'XXV::OUTPUT::NEWS::'.(split('\.',(split('/', $module))[-1]))[0]; + + # make an object for the module + eval "use $moduleName"; + error $@ if $@; + my $mod = $moduleName->new( + -config => $obj->{CONFIG}, + -dbh => $obj->{dbh}, + -paths => $obj->{paths}, + -host => $obj->{host}, + ); + + unless($mod) { + error('Problem to load Module %s!',$moduleName); + next; + } + + $obj->{NEWSMODS}->{$moduleName} = $mod; + + main::addModule($moduleName, $obj->{NEWSMODS}->{$moduleName}); + + debug sprintf("Load NEWS Module %s = %s\n", + $moduleName, + (ref $obj->{NEWSMODS}->{$moduleName}) + ? $obj->{NEWSMODS}->{$moduleName}->{MOD}->{Version} + : 'Problem!'); + } + + return 1; +} + + +# ------------------ +sub report { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $modulename = shift || ''; + + my $mods = main::getModules(); + my $cfg = main::getModule('CONFIG')->{config}; + + # Look for status entry in modCfg and call his + my $result = {}; + foreach my $modName (sort keys %{$mods}) { + my $modCfg = $mods->{$modName}->{MOD}; + next if($modulename and uc($modulename) ne $modCfg->{Name}); + next if(exists $mods->{$modName}->{active} and $cfg->{$modCfg->{Name}}->{active} eq 'n'); + if(exists $modCfg->{Status} and ref $modCfg->{Status} eq 'CODE') { + $result->{$modCfg->{Name}} = $modCfg->{Status}($watcher, $console, $obj->{LastReportTime}); + } + } + + $console->table($result, {hide_HeadLine => 1, hide_HeadRow => 1, maxwidth => 80}) + if(ref $console); + + return 1; +} + +# ------------------ +sub news { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $title = shift || return error ('No Title!' ); + my $text = shift || ''; + my $cmd = shift || ''; + my $id = shift || ''; + my $levname = shift || 'harmless'; # Level for how important is this news? + + # convert Levelname to integer + my $lev = $obj->scala($levname) + || return error('Problem to analyze Level!'); + + my $url = sprintf("http://%s:%s/", $obj->{host}, main::getModule('HTTPD')->{Port}); + $url = sprintf("%s?cmd=%s&data=%s", $url, $cmd, $id) + if($cmd && $id); + + my $news = { + AddDate => time, + Title => $title, + Text => $text, + Cmd => $cmd, + Id => $id, + Url => $url, + Level => $lev, + LevelName => $levname, + }; + + # Send to all activated News modules + foreach my $modName (sort keys %{$obj->{NEWSMODS}}) { + + # Active? + next if($obj->{NEWSMODS}->{$modName}->{active} ne 'y'); + + # Level correct? + next if(exists $obj->{NEWSMODS}->{$modName}->{level} + and $obj->{NEWSMODS}->{$modName}->{level} >= $lev); + + # Do to send (first read and then send) + $obj->{NEWSMODS}->{$modName}->read($news); + } + +} + +# ------------------ +sub request { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!' ); + my $console = shift || return error ('No Console!' ); + # To this time you can set on + # cmd=request&data=rss&ver=2 or + # cmd=request&data=mail + # ... + my $typ = shift || return error ('No Typ!' ); + my $params = shift || {}; + + my ($mod) = grep(/${typ}$/i, keys %{$obj->{NEWSMODS}}); + + return $console->err(sprintf(gettext("Sorry, but this type '%s' does not exist on this system!"), $typ)) + unless($mod); + + return $console->err(gettext("Sorry, but this module is not active!")) + unless($obj->{NEWSMODS}->{$mod}->{active} eq 'y'); + + $console->{noFooter} = 1; + + return $console->out( + $obj->{NEWSMODS}->{$mod}->req($params), + $obj->{NEWSMODS}->{$mod}->{TYP} + ); +} + + +# ------------------ +sub scala { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $typ = shift || return 10; + + $obj->{SCALA} = { + 'harmless' => 10, + 'interesting' => 30, + 'veryinteresting'=> 50, + 'important' => 70, + 'veryimportant' => 100, + } unless(exists $obj->{SCALA}); + + if($typ and exists $obj->{SCALA}->{$typ}) { + return $obj->{SCALA}->{$typ}; + } else { + return error("Level %s does not exist! Please use %s", $typ, join(',', keys %{$obj->{SCALA}})); + } +} + + +1; diff --git a/lib/XXV/MODULES/ROBOT.pm b/lib/XXV/MODULES/ROBOT.pm new file mode 100644 index 0000000..d39e0ec --- /dev/null +++ b/lib/XXV/MODULES/ROBOT.pm @@ -0,0 +1,180 @@ +package XXV::MODULES::ROBOT; +use strict; + +use Tools; +use Locale::gettext; + +$SIG{CHLD} = 'IGNORE'; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'ROBOT', + Prereq => { +# 'WWW::Mechanize' => 'Handy web browsing in a Perl object ', + }, + Description => gettext('This module register and run robots to fetch data from internet.'), + Version => '0.01', + Date => '06.09.2004', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + }, + Commands => { + robot => { + description => gettext("Start a robots 'rname'"), + short => 'ro', + callback => sub{ $obj->start(@_) }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + return $self; +} + +# ------------------ +sub saveRobot { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $rname = shift || return error ('No robot Name!' ); + my $rsub = shift || return error ('No Robot sub!' ); + + return error("$rname is not a Code Reference!'") + unless(ref $rsub eq 'CODE'); + + $obj->clean( $rname ); + $obj->{robots}->{$rname} = $rsub; + return $obj->{robots}->{$rname}; +} + +# ------------------ +sub register { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $rname = shift || return error ('No robot Name!' ); + my @args = @_; + + return error("$rname is not a Robot!'") + unless(ref $obj->{robots}->{$rname} eq 'CODE'); + + push(@{$obj->{jobs}->{$rname}}, [@args]); +} + +# ------------------ +sub start { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $rname = shift || return error ('No Robot Name to start!'); + my $watcher = shift; + my $console = shift; + my $endcb = shift; + + lg sprintf('Start Robots ....'); + + unless(exists $obj->{jobs}->{$rname}) { + return error("No Robot with name $rname is registered!"); + } + + # fork and forget + defined(my $child = fork()) or die "Can't fork: $!"; + if($child == 0) { + $obj->{dbh}->{InactiveDestroy} = 1; + # create a new browser + my $count = 0; + foreach my $args (@{$obj->{jobs}->{$rname}}) { + my ($result, $error); + lg sprintf('robot callback %s started (%d)....', $rname, $count); + eval { + ($result, $error) = &{$obj->{robots}->{$rname}}(@$args); + }; + $error = $@ if($@); + if($result) { + lg sprintf("robot callback %s successfully ended!", $rname); + } else { + error sprintf("robot callback %s failed! : %s ", $rname, $error); + } + $count++; + } + &$endcb() + if(ref $endcb eq 'CODE'); + exit(0); + } +} + +# ------------------ +sub clean { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $rname = shift || return error ('No Robot Name to clean!'); + delete $obj->{jobs}->{$rname}; +} + + +# ------------------ +sub result { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $rname = shift || return error ('No robot Name!' ); + + return $obj->{result}->{$rname}; + +} + +# ------------------ +sub status { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $rname = shift; + + return 1 unless(ref $console); + + if($rname) { + $console->table($obj->{result}->{$rname}); + } else { + $console->table($obj->{result}); + } +} + + + +1; diff --git a/lib/XXV/MODULES/SHARE.pm b/lib/XXV/MODULES/SHARE.pm new file mode 100644 index 0000000..3b5d06c --- /dev/null +++ b/lib/XXV/MODULES/SHARE.pm @@ -0,0 +1,280 @@ +package XXV::MODULES::SHARE; +use strict; + +use Tools; +use Locale::gettext; +use vars qw($AUTOLOAD); + + +$SIG{CHLD} = 'IGNORE'; + +# ------------------ +sub AUTOLOAD { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $cmd = (split('::', $AUTOLOAD))[-1]; + return if($cmd eq 'DESTROY'); + + # Den Hash per Hand nachpflegen + # bis zum nächsten Refresh ... + if($cmd eq 'setEventLevel' and exists $obj->{EventLevels} and ref $obj->{EventLevels} eq 'HASH') { + $obj->{EventLevels}->{$_[0]}->{Level} = $_[1]; + } + + if($obj->{SOAP} && $obj->{active} eq 'y') { + my $erg = $obj->CmdToSoap($obj->{SOAP}, $cmd, $obj->{SessionId}, @_); + return $erg; + } +} + + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'SHARE', + Prereq => { + 'SOAP::Lite' => 'Client and server side SOAP implementation.', + }, + Description => gettext('This module send and read shared data from SOAP Server.'), + Version => '0.03', + Date => '30.06.2006', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'n', + type => 'confirm', + required => gettext('This is required!'), + }, + uri => { + description => gettext('The uri identifies the class on the server. The url (with port) for the XXV-SOAP-Server Address.'), + default => 'http://xpix.dyndns.org:81/XXV/Server', + type => 'url', + required => gettext('This is required!'), + }, + proxy => { + description => gettext('The proxy identifies the CGI script that provides access to the class, Is simply the address of the server to contact that provides the methods.'), + default => 'http://xpix.dyndns.org:81/', + type => 'url', + required => gettext('This is required!'), + }, + interval => { + description => gettext('How often shared data are to be updated (in seconds).'), + default => 3600, + type => 'integer', + required => gettext('This is required!'), + }, + }, + Commands => { + topten => { + description => gettext("Display the TopTen list of timers."), + short => 't10', + callback => sub{ $obj->TopTen(@_) }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # The Initprocess + $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + $obj->{SessionId} = $obj->generateUniqueId + unless($obj->{SessionId}); + + main::after(sub{ + + $obj->{SOAP} = $obj->ConnectToSOAP($obj->{SessionId}); + + unless($obj->{SOAP}) { + error("Can't connect to SOAP server %s!", $obj->{uri}); + return 0; + } else { + $obj->getSoapData(); + Event->timer( + interval => $obj->{interval}, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ $obj->getSoapData() }, + ); + } + return 1; + }, "SHARE: Connect To SOAP Server ...",4) if($obj->{active} eq 'y'); + + return 1; +} + +# ------------------ +sub getSoapData { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return unless($obj->{SOAP} and $obj->{active} eq 'y'); + lg 'Start interval share to get for Levels!'; + $obj->{EventLevels} = $obj->getEventLevels(); + lg 'Start interval share to get for TopTen!'; + $obj->{TopTen} = $obj->getTopTen(1000); +} + + +# ------------------ +sub generateUniqueId { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $sessionId; + for(my $i=0 ; $i< 16 ;) + { + my $j = chr(int(rand(127))); + + if($j =~ /[a-zA-Z0-9]/) + { + $sessionId .=$j; + $i++; + } + } + return $sessionId; +} + +# ------------------ +sub ConnectToSOAP { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $sid = shift || $obj->{SessionId} || return error ('No SesionID!' ); + my $uri = shift || $obj->{uri}; + my $prx = shift || $obj->{proxy}; + + return undef + if($obj->{active} ne 'y'); + + my $soap = SOAP::Lite + ->uri($uri) + ->proxy($prx, timeout => 5) + ->on_fault(sub{}); + + my $usrkey; + if($soap) { + $usrkey = $obj->CmdToSoap($soap,'getUsrKey',$obj->{SessionId}) or error "Can't get user key"; + error "Response contain wrong answer" if($usrkey ne $obj->{SessionId}); + } + + return $soap + if($usrkey eq $obj->{SessionId}); + + return undef; +} + +# ------------------ +sub getEventLevel { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $eid = shift || return; + + return unless($obj->{EventLevels}); + + return $obj->{EventLevels}->{$eid}->{Level} + if(exists $obj->{EventLevels}->{$eid}); +} + +# ------------------ +sub TopTen { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $anzahl = shift || 10; + + $obj->{TopTen} = $obj->getTopTen(1000) + unless($obj->{TopTen}); + + my $data = $obj->{TopTen}; + + my $epg = main::getModule('EPG'); + my $tim = main::getModule('TIMERS'); + my $can = main::getModule('CHANNELS'); + + my @fields = ('eventid','title','subtitle','description','channel_id','starttime','video','audio'); + my @query = @fields; + + @query = ('eventid','title','subtitle','description','channel_id','UNIX_TIMESTAMP(starttime) as starttime','video','audio') + if($console->typ eq 'HTML'); + + + my $out = []; + foreach my $entry (@$data) { + my $edata = $epg->getId( $entry->[0], join(", ", @query) ); + next unless(keys %$edata); + push(@$out, [ @fields, 'Rank', '__Level', '__Count' ]) + unless(scalar @$out); + my @val = map { $edata->{$_} } @fields; + push(@$out, [ @val, $entry->[3], $entry->[1],$entry->[2] ]); + last if(scalar @$out > $anzahl); + } + + return $console->table($out, { + channels => $can->ChannelHash('Id'), + timers => $tim->getEpgIds + }); +} + +# ------------------ +sub CmdToSoap { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $soap = shift || return error ('No SOAP!' ); + my $cmd = shift || return error ('No Command!' ); + my @arg = @_; + + lg(sprintf("CmdToSoap : %s - %s",$cmd, join(", ",@arg))); + + $obj->{CAN}->{$cmd} = $soap->can($cmd) + unless(exists $obj->{CAN}->{$cmd}); + + my $res = eval "\$soap->$cmd(\@arg)"; + $@ ? return error('SyntaxError: $@') : + defined($res) && $res->fault ? + return error('Fault %s-%s', $res->faultcode, $res->faultstring) : + !$soap->transport->is_success ? + return error('Transport Error: %s', $soap->transport->status) : + return $res->result; +} + +1; diff --git a/lib/XXV/MODULES/STATUS.pm b/lib/XXV/MODULES/STATUS.pm new file mode 100644 index 0000000..f566855 --- /dev/null +++ b/lib/XXV/MODULES/STATUS.pm @@ -0,0 +1,771 @@ +package XXV::MODULES::STATUS; +use strict; + +use Tools; +use Socket; +use Sys::Hostname; +use Locale::gettext; +use File::Basename; +use File::Find; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'STATUS', + Prereq => { + # 'Perl::Module' => 'Description', + }, + Description => gettext('This module analyze your system and print the result.'), + Version => '0.45', + Date => '06.09.2005', + Author => 'xpix', + Level => 'user', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + whoBinary => { + description => sprintf(gettext("Path of command '%s'"),'who'), + default => "/usr/bin/who", + type => "file", + required => gettext('This is required!'), + }, + wcBinary => { + description => sprintf(gettext("Path of command '%s'"),'wc'), + default => "/usr/bin/wc", + required => gettext('This is required!'), + type => "file", + }, + dfBinary => { + description => sprintf(gettext("Path of command '%s'"),'df'), + default => "/bin/df", + required => gettext('This is required!'), + type => "file", + }, + interval => { + description => gettext('Interval in seconds to remember data'), + default => 60, + type => "integer", + }, + history => { + description => gettext('How long to remember the historical data in hours'), + default => 3, + type => "integer", + }, + font => { + description => gettext('True type font to draw image text.'), + default => 'Vera.ttf', + type => 'list', + choices => $obj->findttf, + }, + graphic => { + description => gettext('Show collected data as diagram?'), + default => 'y', + type => 'confirm', + }, + }, + Commands => { + all => { + description => gettext('Display all relevant informations about this system'), + short => 'sa', + callback => sub{ + my ($watcher, $console) = @_; + $console->setCall('vitals'); + $obj->vitals(@_); + + $console->setCall('filesys'); + $obj->filesys(@_); + + $console->setCall('memory'); + $obj->memory(@_); + + $console->setCall('network'); + $obj->network(@_); + + $console->setCall('hardware'); + $obj->hardware(@_); + }, + }, + vitals => { + description => gettext('Display the vitals informations'), + short => 'sv', + callback => sub{ $obj->vitals(@_) }, + }, + network => { + description => gettext('Display the network informations'), + short => 'sn', + callback => sub{ $obj->network(@_) }, + }, + hardware => { + description => gettext('Display the hardware informations'), + short => 'sh', + callback => sub{ $obj->hardware(@_) }, + }, + memory => { + description => gettext('Display the memory informations'), + short => 'sm', + callback => sub{ $obj->memory(@_) }, + }, + filesys => { + description => gettext('Display the file system informations'), + short => 'sf', + callback => sub{ $obj->filesys(@_) }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # Interval to read timers and put to DB + Event->timer( + interval => $self->{interval}, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ + $self->remember(); + }, + ) if($self->{active} eq 'y'); + + $self->{LastWarning} = 0; + + return $self; +} + +# ------------------ +sub remember { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $longsteps = int(($obj->{history} * 60 * 60) / $obj->{interval}); + + $obj->watchDog($obj->mounts()); + + my $data = { + timestamp => time, + load => $obj->load('clear'), + util => $obj->util('clear'), + users => $obj->users('clear'), + usage => $obj->mounts('clear'), + memory => $obj->meminfo('clear'), + network => $obj->netDevs('clear'), + + }; + push(@{$obj->{rememberstack}}, $data); + + if(scalar @{$obj->{rememberstack}} >= $longsteps) { + shift @{$obj->{rememberstack}}; + } +} + + +# ------------------ +sub vitals { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my $output = { + name => $obj->name(), + IP => $obj->IP(), + kernel => $obj->kernel(), + uptime => $obj->uptime(), + users => $obj->users(), + load => $obj->load(), + util => $obj->util(), + }; + + my $param = { + headingText => gettext('Vitals'), + stack => $obj->{rememberstack}, + history => $obj->{history} * 60 * 60, + interval => $obj->{interval}, + font => sprintf("%s/%s",$obj->{paths}->{FONTPATH},$obj->{font}), + }; + return $console->table($output,$param); +} + +# ------------------ +sub network { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my $interfaces = $obj->netDevs(); + my $param = { + headingText => gettext('Network'), + stack => $obj->{rememberstack}, + history => $obj->{history} * 60 * 60, + interval => $obj->{interval}, + font => sprintf("%s/%s",$obj->{paths}->{FONTPATH},$obj->{font}), + }; + return $console->table($interfaces,$param); +} + +# ------------------ +sub hardware { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my ($number, $model, $speed, $cache, $bogomips) = $obj->CPU(); + my $pci = $obj->pci(); + my $ide = $obj->ide(); + my $scsi = $obj->scsi(); + + my $output = { + Processors => $number, + Model => $model, + ChipSpeed => $speed, + CacheSize => $cache, + SystemBogomips => $bogomips, + }; + $console->table($output, {headingText => gettext('CPU'), hide_HeadRow => 1}); + $console->table($pci, {headingText => gettext('PCI'), drawRowLine => 1, hide_HeadRow => 1}) + if($pci); + $console->table($ide, {headingText => gettext('IDE')}) + if($ide && scalar @{$ide} > 1); + $console->table($scsi, {headingText => gettext('SCSI')}) + if($scsi && scalar @{$scsi} > 1); +} + +# ------------------ +sub memory { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my $ret = $obj->meminfo(); + my $param = { + headingText => gettext('Memory'), + stack => $obj->{rememberstack}, + history => $obj->{history} * 60 * 60, + interval => $obj->{interval}, + font => sprintf("%s/%s",$obj->{paths}->{FONTPATH},$obj->{font}), + }; + return $console->table($ret,$param); +} + +# ------------------ +sub filesys { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my $ret = $obj->mounts(); + my $param = { + headingText => gettext('Filesystems'), + usage => $ret, + font => sprintf("%s/%s",$obj->{paths}->{FONTPATH},$obj->{font}), + graphic => ($obj->{graphic} eq 'y' ? 1 : 0), + }; + return $console->table($ret,$param); +} + + +############################################################################# +# Helper Functions +############################################################################# + + +# Takes Celcius temperatures and converts to Farenheit + +sub tempConvert { + my $obj = shift || return error ('No Object!' ); + my $celcius = $_[0]; + + my $result = (( $celcius * 9) / 5 ) + 32; + + $result = sprintf("%.1f", $result); + + $result .= "° F"; + + return $result; + +} + +# Get the system's name + +sub name { + my $obj = shift || return error ('No Object!' ); + + my $result = hostname(); + return $result; + +} + +# Get the system's IP address + +sub IP { + my $obj = shift || return error ('No Object!' ); + + my $result = inet_ntoa(scalar(gethostbyname($obj->name())) || scalar(gethostbyname('localhost'))); + return $result; + +} + +# Get the system's kernel version + +sub kernel { + my $obj = shift || return error ('No Object!' ); + + my $result = load_file("/proc/sys/kernel/osrelease"); + $result =~ s/\n//sig; + return $result; + +} + +# Get the system's uptime + +sub uptime { + my $obj = shift || return error ('No Object!' ); + + my $buffer = load_file('/proc/uptime'); + + my @list = split / /, $buffer; + my $ticks = sprintf("%.0u", $list[0]); + my $mins = $ticks / 60; + $mins = sprintf("%.0u", $mins); + my $hours = $mins / 60; + $hours = sprintf("%.0u", $hours); + my $days = ($hours / 24); + $days = sprintf("%.0u", $days); + $hours = $hours - ($days * 24); + $hours = sprintf("%.0u", $hours); + $mins = $mins - ($days * 60 * 24) - ($hours * 60); + + my $result = ''; + if ( $days == 1 ) { + $result .= "${days} ".gettext("day"); + } + elsif ( $days == 0 ) { + $result .= ''; + } + else { + $result .= "${days} ".gettext("days"); + } + + if ( $days > 0 && ( $hours > 0 || $mins > 0 )) { + $result .= ", "; + } + + if ( $hours == 1 ) { + $result .= "${hours} ".gettext("hour"); + } + elsif ( $hours == 0) { + $result .= ''; + } + else { + $result .= "${hours} ".gettext("hours"); + } + + if ( $hours > 0 && $mins > 0 ) { + $result .= ", "; + } + + if ( $mins == 1 ) { + $result .= "${mins} ".gettext("minute"); + } + elsif ($mins == 0 ) { + $result .= ''; + } + else { + $result .= "${mins} ".gettext("minutes"); + } + + return $result; + +} + +# Get information on network devices in the system +sub netDevs { + my $obj = shift || return error ('No Object!' ); + my $clr = shift || 0; + my $buffer = load_file('/proc/net/dev'); + + my $interfaces = [[qw/Interface RxBytes RxPackets RxErrs RxDrop TxBytes TxPackets TxErrs TxDrop/]]; + $interfaces = [] if($clr); + + foreach my $line (split(/\n/, $buffer)) { + my @data = split(/[:|\s]+/, $line); + next unless($data[2] =~ /^\d+$/); + unless($clr) { + $data[2] = convert($data[2]); + $data[10] = convert($data[10]); + } + push(@$interfaces, [@data[1..5], @data[10..13]]); + } + + return $interfaces; +} + +# Get the current memory info +sub meminfo { + my $obj = shift || return error ('No Object!' ); + my $clr = shift || 0; + + my $ret = {}; + my $buffer = load_file "/proc/meminfo"; + foreach my $zeile (split('\n', $buffer)) { + next unless($zeile =~ /kB/); + my ($name, $value) = split(':\s+', $zeile); + $value =~ s/ kB//sig; + + $value = convert($value * 1024) + unless($clr); + + $ret->{$name} = $value; + } + return $ret; +} + +# Get current cpu info + +sub CPU { + my $obj = shift || return error ('No Object!' ); + + my $buffer = load_file('/proc/cpuinfo'); + + my @rows = split /\n/, $buffer; + my $number = scalar grep /processor\s+:/, @rows; + my @modelList = grep /model name\s+:/, @rows; + my @speedList = grep /cpu MHz\s+:/, @rows; + my @cacheList = grep /cache size\s+:/, @rows; + my @bogomipsList = grep /bogomips\s+:/, @rows; + + my ($crap, $model) = split /:/, $modelList[0], 2; + $model =~ s/\s+//; + + ($crap, my $speed) = split /:/, $speedList[0], 2; + $speed = sprintf("%.0u", $speed); + $speed .= " MHz"; + + ($crap, my $bogomips) = split /:/, $bogomipsList[0], 2; + $bogomips = sprintf("%.0u", $bogomips); + + my $cache = ''; + + ($crap, $cache) = split /:/, $cacheList[0], 2; + if ($cache eq '') { + $cache = gettext("No on-chip cache."); + } + + return ($number, $model, $speed, $cache, $bogomips); + +} + +# Get CPU usage info and return a percentage + +sub util { + my $obj = shift || return error ('No Object!' ); + + open(STAT, "/proc/stat") or return error "Can't open /proc/stat\n"; + my $buffer = <STAT>; + close(STAT); + + my ($name, $user, $nice, $system, $idle) = split /\s+/, $buffer; + my $usage = $user + $nice + $system; + my $total = $user + $nice + $system + $idle; + + #Wait 1 second for cpu time to accumulate for comparison + #More than 1 second delays the script too much, and sleep won't + #take an argument < 1 + sleep(1); + + open (STAT, "/proc/stat") or return error "Can't open /proc/stat\n"; + $buffer = <STAT>; + close(STAT); + + my ($newName, $newUser, $newNice, $newSystem, $newIdle) = split /\s+/, $buffer; + my $newUsage = $newUser + $newNice + $newSystem; + my $newTotal = $newUser + $newNice + $newSystem + $newIdle; + + my $deltaUsage = $newUsage - $usage; + my $deltaTotal = $newTotal - $total; + + my $percent = 0; + + $percent = ($deltaUsage / $deltaTotal) * 100 + if($deltaTotal != 0); + + $percent = sprintf("%.1f", $percent); + + return($percent); + +} + +# Get the number of current users logged in + +sub users { + my $obj = shift || return error ('No Object!' ); + + my $result = `$obj->{whoBinary} | $obj->{wcBinary} -l` + or return error "Can't execute $obj->{whoBinary} or $obj->{wcBinary}\n"; + $result =~ s/\n//g; + return $result; + +} + +# Get the list of PCI devices + +sub pci { + my $obj = shift || return error ('No Object!' ); + + return 0 + if(! -r "/proc/pci"); + + my $buffer = load_file("/proc/pci"); + my $ret; + foreach my $zeile (split(/\n/, $buffer)) { + if($zeile =~ /(bridge|controller|interface)\:\s+(.+)/i) { + $ret->{ucfirst($1)} .= "$2\n"; + } + } + return $ret; +} + +# Get the list of IDE devices + +sub ide { + my $obj = shift || return error ('No Object!' ); + + my @ideModelList; + my @ideCapacityList; + my $count = 0; + + my @dirList = glob ("/proc/ide/*"); + my $ret = [[qw/Device Model Capacity Cache/]]; + foreach my $device (@dirList) { + next unless($device =~ /ide\/hd/); + + my $model = load_file("${device}/model"); + $model =~ s/\n//g; + + my $cap = 0; + $cap = load_file("${device}/capacity") + if(-e "${device}/capacity"); + my $cache = 0; + $cache = load_file("${device}/cache") + if(-e "${device}/cache"); + push(@$ret, + [ + $device, + $model, + convert($cap * 512), + convert($cache * 1024), + ] + ); + } + + return $ret; +} + +# Get the list of SCSI devices + +sub scsi { + my $obj = shift || return error ('No Object!' ); + + my $ret = [[qw/Device Vendor Model Type/]]; + my $file = "/proc/scsi/scsi"; + + if ( -r $file){ + my ( $host, $channel, $id, $lun, $vendor, $model, $type ) ; + my $dev_no = 'a'; + my $cd_no = '0'; + my $st_no = '0'; + open(F,$file) + or return error "Can't open $file : $!\n";; + while(<F>) { + if(/Host: (\S+) Channel: (\d+) Id: (\d+) Lun: (\d+)/) { + $host = $1, $channel = $2, $id = $3, $lun = $4; + } + if(/Vendor: (.+)\s+Model: (.+)\s+Rev:/) { + $vendor = $1, $model = $2; + $vendor =~ s/^\s+//g; + $vendor =~ s/\s+$//g; + $model =~ s/^\s+//g; + $model =~ s/\s+$//g; + + $_ = <F>; + if(/Type:(.+)\s+ANSI/) { + $type = $1; + $type =~ s/^\s+//g; + $type =~ s/\s+$//g; + } + + my $device; + if($type eq 'Direct-Access') { # Disk + $device = "/dev/sd$dev_no"; + $dev_no++; + } elsif($type eq 'CD-ROM') { + $device = "/dev/scd$cd_no"; + $cd_no++; + } elsif($type eq 'Sequential-Access') { # Streamer + $device = "/dev/st$st_no"; + $st_no++; + } + + push(@$ret, + [ + "$device (ch: $channel, lun: $lun, scsi: $id)", + $vendor, + $model, + $type, + ] + ) if($device); + } + } + close(F); + } + return $ret; +} + +# Get the current load averages + +sub load { + my $obj = shift || return error ('No Object!' ); + my $clr = shift || 0; + + my $buffer = load_file("/proc/loadavg"); + my @list = split(' ', $buffer); + my $c = 5; + my $ret; + + return \@list if($clr); + + foreach my $entry (@list[0..2]) { + $ret .= sprintf("%s last %d min\n", $entry, $c); + $c += 5; + } + + return $ret; + +} + +# Get the status of currently mounted filesystems +sub mounts{ + my $obj = shift || return error ('No Object!' ); + my $clr = shift || 0; + + my $df = `$obj->{dfBinary} -TP -x cdfs -x iso9660 -x udf` + or return error "Can't execute $obj->{dfBinary} $!\n"; + my $ret = [[qw/FS Typ Space Used Free Cap. Mount/]]; + + foreach my $zeile (split('\n', $df)) { + my @data = split('\s+', $zeile); + next if($data[2] !~ /^\d+$/); + + $data[0] =~ s/[\-\s]/_/sg; + + if($clr) { + push(@$ret, $data[5]); + } else { + map {$_ = convert($_ * 1024)} @data[2..4]; + push(@$ret, \@data); + } + } + return $ret; +} + +# ------------------ +sub videoMounts { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $videodir = shift || return error ('No Video dir!'); + my $mounts = $obj->mounts; + + my $ret = []; + + for (@$mounts) { + push(@$ret, $_) + if($_->[0] =~ /^$videodir/i); + } + + $ret = $mounts unless(scalar @$ret); + + return $ret; +} + +# ------------------ +sub findttf +# ------------------ +{ + my $obj = shift || return error ('No Object!' ); + my $found; + find({ wanted => sub{ + if($File::Find::name =~ /\.ttf$/sig) { + my $l = basename($File::Find::name); + push(@{$found},[$l,$l]); + } + }, + follow => 1, + follow_skip => 2, + }, + $obj->{paths}->{FONTPATH} + ); + error "Can't find useful font at : $obj->{paths}->{FONTPATH}" + if(scalar $found == 0); + return $found; +} + +# ------------------ +sub watchDog { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $mou = shift || return error ('No Data!' ); + + # Not all 15 seconds a panic message ;) + return if($obj->{LastWarning}+900 > time); + + foreach my $m (@$mou) { + next unless($m->[0] =~ /^\//); + if(int($m->[5]) >= 98 ) { + my $rm = main::getModule('REPORT'); + $rm->news( + sprintf(gettext("PANIC! Only %s%% space left on device %s"),(100 - int($m->[5])),$m->[0]), + sprintf(gettext("Device has space %s from %s used!"), $m->[3], $m->[2]), + 'sa', + undef, + 'important' + ); + $obj->{LastWarning} = time; + } + } +} + + +1; diff --git a/lib/XXV/MODULES/STREAM.pm b/lib/XXV/MODULES/STREAM.pm new file mode 100644 index 0000000..aa80c22 --- /dev/null +++ b/lib/XXV/MODULES/STREAM.pm @@ -0,0 +1,179 @@ +package XXV::MODULES::STREAM; +use strict; + +use Tools; +use Locale::gettext; +use File::Basename; +use File::Find; +use File::Path; + +$SIG{CHLD} = 'IGNORE'; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'STREAM', + Prereq => { + # 'Perl::Module' => 'Description', + }, + Description => gettext('This module generate streams from recordings.'), + Version => '0.92', + Date => '2007-01-20', + Author => 'xpix', + Preferences => { + host => { + description => gettext('Used host of referred link inside playlist.'), + default => 'localhost', + type => 'host', + required => gettext('This is required!'), + }, + netvideo => { + description => gettext('Path from remote video directory (SambaDir).'), + default => '\\\\vdr\\video', + type => 'string', + }, + mimetyp => { + description => gettext('Used mime-typ to deliver video streams.'), + default => 'video/x-mpegurl', + type => 'string', + }, + }, + Commands => { + playrecord => { + description => gettext("Play the record over samba or nfs."), + short => 'pre', + callback => sub{ $obj->play_record(@_) }, + DenyClass => 'stream', + }, + livestream => { + description => gettext("Stream a channel 'cid'. This required the streamdev plugin!"), + short => 'lst', + callback => sub{ $obj->live_stream(@_) }, + DenyClass => 'stream', + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # The Initprocess + my $erg = $self->init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + 1; +} + + +# ------------------ +sub live_stream { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $channel = shift || return $console->err(gettext("No ChannelID to Stream! Please use livestream 'cid'")); + + debug sprintf('Call live stream with channel "%s"%s', + $channel, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + if($channel && $console->typ eq 'HTML') { + $console->{nocache} = 1; + $console->{nopack} = 1; + $console->{noFooter} = 1; + + my $data; + $data = "#EXTM3U\r\n"; + $data .= sprintf("http://%s:3000/PES/%d", $obj->{host}, $channel); + $data .= "\r\n"; + + my $arg; + $arg->{'attachment'} = sprintf("livestream%d.m3u", $channel); + $arg->{'Content-Length'} = length($data); + + $console->out($data, $obj->{mimetyp}, %{$arg} ); + } else { + $console->err(gettext("Sorry, stream is'nt supported")); + } +} + +# ------------------ +sub play_record { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $recid = shift || return $console->err(gettext("No RecordID to Play! Please use rplay 'rid'")); + + my $rmod = main::getModule('RECORDS'); + my $videopath = $rmod->{videodir}; + my $path = $rmod->IdToPath($recid) + or return $console->err(gettext(sprintf('I can\'t found recid: %s', $recid))); + + debug sprintf('Call play record "%s"%s', + $path, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + my $data; + $data = "#EXTM3U\r\n"; + foreach my $file (glob("$path/???.vdr")) { + $file =~ s/^$videopath//si; + $file =~ s/^[\/|\\]//si; + my $URL = sprintf("%s/%s\r\n", $obj->{netvideo}, $file); + $URL =~s/\//\\/g + if($URL =~ /^\\\\/sig # Samba \\host/xxx/yyy => \\host\xxx\yyy + || $URL =~ /^[a-z]\:[\/|\\]/sig); # Samba x:/xxx/yyy => x:\xxx\yyy + $data .= $URL; + } + + if($data && $console->typ eq 'HTML') { + $console->{nocache} = 1; + $console->{nopack} = 1; + $console->{noFooter} = 1; + + my $arg; + $arg->{'attachment'} = sprintf("playrecord%d.m3u", $recid); + $arg->{'Content-Length'} = length($data); + + $console->out($data, $obj->{mimetyp}, %{$arg} ); + } else { + $console->err(gettext("Sorry, stream is'nt supported")); + } +} +1; diff --git a/lib/XXV/MODULES/SVDRP.pm b/lib/XXV/MODULES/SVDRP.pm new file mode 100644 index 0000000..08ca944 --- /dev/null +++ b/lib/XXV/MODULES/SVDRP.pm @@ -0,0 +1,228 @@ +package XXV::MODULES::SVDRP; + +use Tools; +use Locale::gettext; +use strict; + + +$|++; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'SVDRP', + Prereq => { + 'Net::Telnet' => 'Net::Telnet allows you to make client connections to a TCP port and do network I/O', + }, + Description => gettext('This module a telnet client for sdvrp.'), + Version => '0.93', + Date => '2007-02-21', + Author => 'xpix', + Preferences => { + VdrHost => { + description => gettext('Name of the host that runs vdr'), + default => 'localhost', + type => 'host', + required => gettext('This is required!'), + }, + VdrPort => { + description => gettext('SVDRP-port of the running vdr client'), + default => 2001, + type => 'integer', + required => gettext('This is required!'), + }, + timeout => { + description => gettext('Connection timeout defines after how many seconds an unrequited connection is terminated.'), + default => 60, + type => 'integer', + required => gettext('This is required!'), + }, + }, + Commands => { + sstatus => { + description => gettext('Status from svdrp'), + short => 'ss', + callback => sub{ $obj->status(@_) }, + Level => 'user', + DenyClass => 'remote', + }, + scommand => { + description => gettext('Send a command to svdrp'), + short => 'sc', + callback => sub{ $obj->scommand(@_) }, + Level => 'admin', + DenyClass => 'remote', + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + $self->{COMMANDS} = []; + + return $self; +} + +# ------------------ +sub queue_cmds { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $cmd = shift || 'CALL'; + + if($cmd eq 'CALL') { + my $queue = delete $obj->{COMMANDS}; + $obj->{COMMANDS} = []; + return $obj->command($queue); + } elsif($cmd eq 'COUNT') { + return scalar @{$obj->{COMMANDS}}; + } else { + push(@{$obj->{COMMANDS}}, $cmd); + } +} + +# ------------------ +sub command { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $cmd = shift; + + my $host = $obj->{VdrHost}; + my $port = $obj->{VdrPort}; + + my $data; + my $line; + my @commands = (); + push(@commands, (ref $cmd eq 'ARRAY' ? @$cmd : $cmd)); + + unless(scalar @commands > 0) { + error ('No Commands!'); + return undef; + } + push(@commands, "quit"); + + $obj->{ERROR} = 0; + + # Put Command follow quit and read Output + my $telnet = Net::Telnet->new ( Telnetmode => 0, + Timeout => $obj->{timeout}, + Errmode => 'return'); + + if(!$telnet or !$telnet->open(Host => $host, Port => $port)){ + error sprintf("Couldn't connect to svdrp-socket %s:%s! %s",$host,$port,$telnet ? $telnet->errmsg : $!); + return undef; + } + + # read first line + do { + $line = $telnet->getline; + last unless $line; + chomp($line); + push(@$data, $line); + } while($line =~ /^\d\d\d\-/); + + unless(scalar @$data){ + error sprintf("Couldn't read data from svdrp-socket %s:%s! %s",$host,$port,$telnet ? $telnet->errmsg : $!); + return undef; + } + + main::getVdrVersion($1) + if($data->[0] =~ /SVDRP\s+VideoDiskRecorder\s+(\d\.\d\.\d+)[\;|\-]/); + + # send commando queue + foreach my $command (@commands) { + $telnet->buffer_empty; #clear buffer + # send command + if(!$telnet->print($command)) { + error sprintf("Couldn't send svdrp-command '%s' to %s:%s! %s",$command,$host,$port,$telnet ? $telnet->errmsg : $!); + return undef; + } + # read response + do { + $line = $telnet->getline; + last unless $line; + chomp($line); + + if($line =~ /^(\d{3})\s+(.+)/ && (int($1) >= 500)) { + my $msg = sprintf("Error at command '%s' to %s:%s! %s", $command,$host,$port, $2); + error($msg); + $obj->{ERROR} .= $msg . "\n"; + } + + push(@$data, $line); + } while($line =~ /^\d\d\d\-/); + } + + # close socket + $telnet->close(); + + foreach my $command (@commands) { + event(sprintf('Call command "%s" on svdrp %s.', $command, $obj->{ERROR} ? " failed" : "successful")) + if($command ne "quit"); + } + return \@$data; +} + +# ------------------ +sub status { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return; + + my $erg = $obj->command('stat disk'); + $console->msg($erg, $obj->err) + if(ref $console); +} + +# ------------------ +sub scommand { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $text = shift || return $console->err(gettext("No Command! Please use scommand 'cmd'")); + + my $erg = $obj->command($text); + $console->msg($erg, $obj->err); +} + + +# ------------------ +sub err { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{ERROR}; +} + +1; diff --git a/lib/XXV/MODULES/TELNET.pm b/lib/XXV/MODULES/TELNET.pm new file mode 100644 index 0000000..f29b2bb --- /dev/null +++ b/lib/XXV/MODULES/TELNET.pm @@ -0,0 +1,326 @@ +package XXV::MODULES::TELNET; + +use strict; + +use XXV::OUTPUT::Console; +use Tools; +use Locale::gettext; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'TELNET', + Prereq => { + 'IO::Socket::INET' => 'Object interface for AF_INET domain sockets ', + 'Module::Reload' => 'Reload %INC files when updated on disk ', + }, + Description => gettext('This module is a multisession telnet server.'), + Version => '0.01', + Date => '18.08.2004', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + Clients => { + description => gettext('Maximum number from simultaneous connections to the same time'), + default => 5, + type => 'integer', + required => gettext('This is required!'), + }, + Port => { + description => gettext('Number of port to listen for telnet clients'), + default => 8081, + type => 'integer', + required => gettext('This is required!'), + }, + Interface => { + description => gettext('Local interface to bind service'), + default => '0.0.0.0', + type => 'host', + required => gettext('This is required!'), + }, + }, + Commands => { + help => { + description => gettext("This will display all commands or the helptext from the 'module name'"), + short => 'h', + callback => sub{ + return $obj->usage(@_); + }, + }, + quit => { + description => gettext("This will exit the telnet session"), + short => 'q', + callback => sub{ + my ($w, $c, $l) = @_; + lg "Telnet session closed.\n"; + $c->message(gettext("Session closed.")); + $obj->{LOGOUT} = 1; + }, + }, + bye => { + description => gettext("This will exit the xxv system."), + short => 'x', + callback => sub{ + my ($w, $c, $l) = @_; + my $answer; + my $questions = [ + 'really' => { + typ => 'confirm', + msg => gettext("Are you sure to exit the xxv system?"), + def => 'n'} + ]; + $answer = $c->question(gettext("This will exit the xxv system."),$questions,$answer); + if($answer->{really} eq 'y') { + $w->w->fd->close; + $w->w->cancel; + lg "Closed session and exit.\n"; + main::quit; + } + }, + Level => 'admin' + }, + reload => { + description => gettext("This will reload all Modules."), + short => 'rel', + callback => sub{ + my ($w, $c, $l) = @_; + $Module::Reload::Debug = 2; + Module::Reload->check; + $c->message(gettext("Modules reloaded.")); + }, + Level => 'admin' + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + $self->init or return error('Problem to initialize module'); + + return $self; +} + + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + # globals + my $channels; + + my $prompt = "XXV> "; + + # make socket + my $socket = IO::Socket::INET->new( + Listen => $obj->{Clients}, + LocalPort => $obj->{Port}, + LocalAddr => $obj->{Interface}, + Reuse => 1 + ) or return error("Can't create Socket: $!"); + + # install an initial watcher + Event->io( + fd => $socket, + prio => -1, # -1 very hard ... 6 very low + cb => sub { + my $watch = shift; + + # make "channel" number + my $channel=++$channels; + + # accept client + my $client=$socket->accept; + panic "Can't connect telnet to new client.\n" and return unless $client; + $client->autoflush; + + my $console = XXV::OUTPUT::Console->new( + -handle => $client, + -dbh => $obj->{dbh}, + -paths => $obj->{paths}, + ); + + # install a communicator + Event->io( + fd => $client, + prio => -1, # -1 very hard ... 6 very low + cb => sub { + my $watcher = shift; + + # read new line and report it + my $handle=$watcher->w->fd; + + my $line=<$handle>; + if(!$line or (defined $obj->{LOGOUT} && $obj->{LOGOUT} == 1 )) { + undef $obj->{LOGOUT}; + $watcher->w->cancel; + $handle->close(); + undef $watcher; + return 1; + } + $line =~ s/[\r|\n]//sig + if(defined $line); + + $obj->handleInput($watcher, $console, $line); + if(defined $obj->{LOGOUT} && $obj->{LOGOUT} == 1) { + undef $obj->{LOGOUT}; + $watcher->w->cancel; + $handle->close(); + undef $watcher; + return 1; + } + + # Prompt + $client->print($prompt) if($client->opened); + }, + ); + + # welcome + $client->print(sprintf(gettext("Welcome to xxv system version: %s.\r\nThis is session %s.\r\n"),$obj->{MOD}->{Version},$channel)); + + my $userMod = main::getModule('USER'); + unless(exists $console->{USER} or $userMod->{active} ne 'y') { + # Login + my $data; + if($userMod->_checkIp($client)) { + $console->message(gettext("Welcome to xxv system.")); + $data->{Name} = 'no'; + $data->{Password} = 'no'; + } else { + $data = $console->login(gettext("Welcome to xxv system. Please Login:")); + } + my $user = $userMod->check($client, $data->{Name}, $data->{Password}); + if(exists $user->{Name}) { + $console->{USER} = $user; + } else { + $console->err(gettext("Sorry, but permission denied!")); + $client->close; + return 1; + } + } + + $client->print($prompt); + + }, + ) if($obj->{active} eq 'y'); + + return 1; + +} + +# ------------------ +sub usage { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $modulename = shift || 0; + my $hint = shift || ''; + my $user = shift || $console->{USER}; + + my $u = main::getModule('USER'); + unless($user) { + my $loginObj = $obj; + $loginObj = main::getModule('HTTPD') + if ($console->{TYP} eq 'HTML') ; + $loginObj = main::getModule('WAPD') + if ($console->{TYP} eq 'WML') ; + $user = $loginObj->{USER}; + } + + my $ret; + push(@$ret, sprintf(gettext("%sThis is the xxv %s server.\nPlease use the following commands:\n"), + ($hint ? "$hint\n\n" : ''), $console->typ)); + + my $mods = main::getModules(); + my @realModName; + + # Search for command and display the Description + foreach my $modName (sort keys %{$mods}) { + my $modCfg = $mods->{$modName}->{MOD}; + push(@realModName, $mods->{$modName}->{MOD}->{Name}); + next if($modulename and uc($modulename) ne $modCfg->{Name}); + foreach my $cmdName (sort keys %{$modCfg->{Commands}}) { + push(@$ret, + [ + (split('::', $modName))[-1], + $modCfg->{Commands}->{$cmdName}->{short}, + $cmdName, + $modCfg->{Commands}->{$cmdName}->{description}, + ] + ) if(! $modCfg->{Commands}->{$cmdName}->{hidden} and ($u->{active} ne 'y') || $u->allowCommand($modCfg, $cmdName, $user, "1")); + } + } + + $console->menu( + $ret, + { + periods => $mods->{'XXV::MODULES::EPG'}->{periods}, + CHANNELS => $mods->{'XXV::MODULES::CHANNELS'}->ChannelArray('Name'), + CONFIGS => [ sort @realModName ], + }, + ); +} + +# ------------------ +sub handleInput { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $line = shift || return; + my $user = shift || $console->{USER}; + + my ($ucmd, $udata) = ($1, $2) if($line =~ /(\S+)\s*(.*)/sig); + + # Test the command on exists, permissions and so on + my $u = main::getModule('USER'); + my ($cmdobj, $cmdname, $shorterr, $err) = $u->checkCommand($console, $ucmd); + $console->{call} = $cmdname; + if($cmdobj and not $shorterr) { + $cmdobj->{callback}($watcher, $console, $udata); + } elsif($shorterr eq 'noperm' or $shorterr eq 'noactive') { + return $console->err($err); + } else { + return $obj->usage($watcher, $console, undef, $err); + } +} + +1; diff --git a/lib/XXV/MODULES/TIMERS.pm b/lib/XXV/MODULES/TIMERS.pm new file mode 100644 index 0000000..b20f67d --- /dev/null +++ b/lib/XXV/MODULES/TIMERS.pm @@ -0,0 +1,1721 @@ +package XXV::MODULES::TIMERS; + +use strict; +use Tools; +use POSIX ":sys_wait_h", qw(strftime mktime); +use Locale::gettext; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'TIMERS', + Prereq => { + # 'Perl::Module' => 'Description', + }, + Description => gettext('This module parse the timers.conf and save this in the database.'), + Version => '0.92', + Date => '2007-01-28', + Author => 'xpix', + Status => sub{ $obj->status(@_) }, + Preferences => { + interval => { + description => gettext('How often timers are to be updated (in seconds)'), + default => 30 * 60, + type => 'integer', + required => gettext("This is required!"), + }, + prevminutes => { + description => gettext('Buffer time in minutes before the scheduled end of the recorded program.'), + default => 5, + type => 'integer', + }, + afterminutes => { + description => gettext('Buffer time in minutes after the scheduled end of the recorded program.'), + default => 5, + type => 'integer', + }, + Priority => { + description => gettext('Defining the priority of this timer and of recordings created by this timer.'), + default => 50, + type => 'integer', + }, + Lifetime => { + description => gettext('The guaranteed lifetime (in days) of a recording created by this timer'), + default => 50, + type => 'integer', + }, + DVBCards => { + description => gettext('How much DVB cards in your system?'), + default => 1, + type => 'integer', + }, + deactive => { + description => gettext('Delete inactive timers after his end time?'), + default => 'n', + type => 'confirm', + }, + usevpstime => { + description => gettext('Use VPS start time?'), + default => 'n', + type => 'confirm', + }, + adjust => { + description => gettext('Timers adjust, if EPG entry were changed?'), + default => 'y', + type => 'confirm', + }, + }, + Commands => { + tlist => { + description => gettext("List timers 'tid'"), + short => 'tl', + callback => sub{ $obj->list(@_) }, + DenyClass => 'tlist', + }, + tsearch => { + description => gettext("Search timers 'text'"), + short => 'ts', + callback => sub{ $obj->list(@_) }, + DenyClass => 'tlist', + }, + tupdate => { + description => gettext("Read timers and write into database"), + short => 'tu', + callback => sub{ $obj->readData(@_)}, + Level => 'user', + DenyClass => 'tedit', + }, + tnew => { + description => gettext("Create timer 'eid'"), + short => 'tn', + callback => sub{ $obj->newTimer(@_) }, + Level => 'user', + DenyClass => 'tedit', + }, + tedit => { + description => gettext("Edit timer 'tid'"), + short => 'te', + callback => sub{ $obj->editTimer(@_) }, + Level => 'user', + DenyClass => 'tedit', + }, + tdelete => { + description => gettext("Delete timer 'tid'"), + short => 'td', + callback => sub{ $obj->deleteTimer(@_) }, + Level => 'user', + DenyClass => 'tedit', + }, + ttoggle => { + description => gettext("Activate/Deactive timer 'tid'"), + short => 'tt', + callback => sub{ $obj->toggleTimer(@_) }, + Level => 'user', + DenyClass => 'tedit', + }, + tsuggest => { + hidden => 'yes',
+ callback => sub{ $obj->suggest(@_) }, + DenyClass => 'tlist', + }, + }, + RegEvent => { + 'newTimerfromUser' => { + Descr => gettext('Create event entries, if a new timer created by user.'), + + # You have this choices (harmless is default): + # 'harmless', 'interesting', 'veryinteresting', 'important', 'veryimportant' + Level => 'interesting', + + # Search for a spezial Event. + # I.e.: Search for an LogEvent with match + # "Sub=>text" = subroutine =~ /text/ + # "Msg=>text" = logmessage =~ /text/ + # "Mod=>text" = modname =~ /text/ + SearchForEvent => { + Msg => 'New timer', + }, + # Search for a Match and extract the information + # of the id + # ... + Match => { + TimerId => qr/id\:\s+\"(\d+)\"/s, + }, + Actions => [ + q|sub{ my $args = shift; + my $event = shift; + my $timer = getDataById($args->{TimerId}, 'TIMERS', 'Id'); + return if($timer->{AutotimerId}); + my $desc = getDataById($timer->{eventid}, 'EPG', 'eventid') if($timer->{eventid}); + my $title = sprintf(gettext("New timer found: %s"),$timer->{File}); + my $description = sprintf(gettext("At: %s to %s\nDescription: %s"), + $timer->{NextStartTime}, + fmttime($timer->{Stop}), + $desc && $desc->{description} ? $desc->{description} : '' + ); + + main::getModule('REPORT')->news($title, $description, "display", $timer->{eventid}, $event->{Level}); + } + |, + q|sub{ my $args = shift; + my $event = shift; + my $timer = getDataById($args->{TimerId}, 'TIMERS', 'Id'); + my $soap = main::getModule('SHARE'); + my $level = 1; + if($timer->{AutotimerId}) { + $level = (($timer->{Priority} <= 50 or $timer->{Lifetime} < 33) ? 2 : 3); + } else { + $level = (($timer->{Priority} <= 50 or $timer->{Lifetime} < 33) ? 4 : 5); + } + + if($timer->{eventid}) { + my $event = main::getModule('EPG')->getId($timer->{eventid}, 'UNIX_TIMESTAMP(starttime) + duration as STOPTIME'); + $soap->setEventLevel($timer->{eventid}, $level, $event->{STOPTIME}); + } + }|, + ], + + }, + 'deleteTimer' => { + Descr => gettext('Create event entries, if timer deleted by user.'), + Level => 'interesting', + SearchForEvent => { + Msg => 'delt', + }, + Match => { + TimerId => qr/delt\s+(\d+)/s, + }, + Actions => [ + q|sub{ my $args = shift; + my $event = shift; + my $timer = getDataById($args->{TimerId}, 'TIMERS', 'Id'); + my $title = sprintf(gettext("Timer deleted: %s"),$timer->{File}); + my $desc = getDataById($timer->{eventid}, 'EPG', 'eventid') if($timer->{eventid}); + my $description = sprintf(gettext("At: %s to %s\nDescription: %s"), + $timer->{NextStartTime}, + fmttime($timer->{Stop}), + $desc && $desc->{description} ? $desc->{description} : '' + ); + + main::getModule('REPORT')->news($title, $description, "display", $timer->{eventid}, $event->{Level}); + } + |, + q|sub{ my $args = shift; + my $event = shift; + my $timer = getDataById($args->{TimerId}, 'TIMERS', 'Id'); + my $soap = main::getModule('SHARE'); + my $level = 1; + + if($timer->{eventid}) { + my $event = main::getModule('EPG')->getId($timer->{eventid}, 'UNIX_TIMESTAMP(starttime) + duration as STOPTIME'); + $soap->setEventLevel($timer->{eventid}, $level, $event->{STOPTIME}); + } + }|, + ], + }, + 'toggleTimer' => { + Descr => gettext('Create event entries, if timer toggled by user.'), + Level => 'interesting', + SearchForEvent => { + Msg => 'modt', + }, + Match => { + TimerId => qr/modt\s+(\d+)\s(on|off)/s, + Type => qr/modt\s+\d+\s+(on|off)/s, + }, + Actions => [ + q|sub{ my $args = shift; + my $event = shift; + my $timer = getDataById($args->{TimerId}, 'TIMERS', 'Id'); + my $title = sprintf(gettext("Timer toggled: %s to %s"),$timer->{File},$args->{Type}); + my $description = sprintf(gettext("Description: %s\nAt: %s to %s"), + $timer->{Summary}, + $timer->{NextStartTime}, + fmttime($timer->{Stop}) + ); + + main::getModule('REPORT')->news($title, $description, "display", $timer->{eventid}, $event->{Level}); + } + |, + q|sub{ my $args = shift; + my $event = shift; + my $timer = getDataById($args->{TimerId}, 'TIMERS', 'Id'); + my $soap = main::getModule('SHARE'); + my $level = ($args->{Type} eq 'off' ? 1 : 2); + if($timer->{AutotimerId} and $args->{Type} eq 'on') { + $level = (($timer->{Priority} <= 50 or $timer->{Lifetime} < 33) ? 2 : 3); + } elsif($args->{Type} eq 'on') { + $level = (($timer->{Priority} <= 50 or $timer->{Lifetime} < 33) ? 4 : 5); + } + + if($timer->{eventid}) { + my $event = main::getModule('EPG')->getId($timer->{eventid}, 'UNIX_TIMESTAMP(starttime) + duration as STOPTIME'); + $soap->setEventLevel($timer->{eventid}, $level, $event->{STOPTIME}); + } + }|, + ], + }, + 'updateTimer' => { + Descr => gettext('Create event entries, if timer updated.'), + Level => 'harmless', + SearchForEvent => { + Msg => 'Reread', + }, + Match => { + HighId => qr/Reread\s+(\d+)\s+timers/s, + }, + Actions => [ + q|sub{ my $args = shift; + my $event = shift; + my $soap = main::getModule('SHARE'); + my $epg = main::getModule('EPG'); + for (my $i = 1; $i<=$args->{HighId}; $i++) { + my $timer = getDataById($i, 'TIMERS', 'Id'); + + my $level = 1; + if($timer->{AutotimerId} and ($timer->{Status} & 1)) { + $level = (($timer->{Priority} <= 50 or $timer->{Lifetime} < 33) ? 2 : 3); + } elsif($timer->{Status} & 1) { + $level = (($timer->{Priority} <= 50 or $timer->{Lifetime} < 33) ? 4 : 5); + } + + if($timer->{eventid}) { + my $event = $epg->getId($timer->{eventid}, 'UNIX_TIMESTAMP(starttime) + duration as STOPTIME'); + $soap->setEventLevel($timer->{eventid}, $level, $event->{STOPTIME}); + } + } + }|, + ], + }, + }, + }; + return $args; +} + +# ------------------ +sub status { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $lastReportTime = shift || 0; + + my $total = 0; + { + my $sth = $obj->{dbh}->prepare("select count(*) as count from TIMERS"); + if(!$sth->execute()) + { + error sprintf("Can't execute query: %s.",$sth->errstr); + } else { + my $erg = $sth->fetchrow_hashref(); + $total = $erg->{count} if($erg && $erg->{count});
+ } + } + + return { + message => sprintf(gettext('%d Timers exists.'), $total), + }; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return 0, panic("Session to database is'nt connected") + unless($obj->{dbh}); + + # remove old table, if updated rows + tableUpdated($obj->{dbh},'TIMERS',19,1); + + # Look for table or create this table + my $version = main::getVersion; + $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS TIMERS ( + Id int(11) unsigned NOT NULL, + Status char(1) default 1, + ChannelID varchar(100) NOT NULL default '', + Day varchar(20) default '-------', + Start int(11) unsigned, + Stop int(11) unsigned, + Priority tinyint(2), + Lifetime tinyint(2), + File text, + Summary text default '', + NextStartTime datetime, + NextStopTime datetime, + Collision varchar(100) default '0', + eventid bigint unsigned default '0', + eventstarttime datetime, + eventduration int unsigned default '0', + AutotimerId int(11) unsigned default '0', + addtime timestamp, + Checked char(1) default 0, + PRIMARY KEY (Id) + ) COMMENT = '$version' + |); + + $obj->{newTimerFormat} = 0; + $obj->{after_updated} = []; + + main::after(sub{ + $obj->{svdrp} = main::getModule('SVDRP'); + unless($obj->{svdrp}) { + panic ("Can't get modul SVDRP"); + return 0; + } + + $obj->readData(); + + # Interval to read timers and put to DB + Event->timer( + interval => $obj->{interval}, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ + $obj->readData(); + } + ); + return 1; + }, "TIMERS: Store timers in database ...", 10); + + + return 1; +} + +# ------------------ +sub saveTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error('No Data to Save!'); + my $timerid = shift || 0; + + my $status = ($data->{Activ} eq 'y' ? 1 : 0); + $status |= ($data->{VPS} eq 'y' ? 4 : 0); + + $data->{File} =~ s/:/|/g; + $data->{File} =~ s/(\r|\n)//sig; + + my $erg = $obj->{svdrp}->command( + sprintf("%s %s:%s:%s:%s:%s:%s:%s:%s:%s", + $timerid ? "modt $timerid" : "newt", + $status, + $data->{ChannelID}, + $data->{Day}, + $data->{Start}, + $data->{Stop}, + int($data->{Priority}), + int($data->{Lifetime}), + $data->{File}, + ($data->{Summary} || '') + ) + ); + + # Save shortly this timer in DB if this only a new timer (at) + # Very Important for Autotimer! + my $pos = $1 if($erg->[1] =~ /^250\s+(\d+)/); + if(! $timerid and $pos) { + $obj->insert([ + $status, + $data->{ChannelID}, + $data->{Day}, + $data->{Start}, + $data->{Stop}, + int($data->{Priority}), + int($data->{Lifetime}), + $data->{File}, + ($data->{Summary} || '') + ], $pos); + } + + event('Save timer "%s" with TimerId: "%d"', $data->{File}, $pos); + + return $erg; +} + +# ------------------ +sub newTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $epgid = shift || 0; + my $epg = shift || 0; + + + if($epgid and not ref $epg) { + my $sth = $obj->{dbh}->prepare( +qq| +SELECT + eventid, + channel_id, + description as Summary, + CONCAT_WS('~', title, subtitle) as File, + DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(starttime) - ? ), '%d') as Day, + DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(starttime) - ? ), '%H%i') as Start, + DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(starttime) + duration + ? ), '%H%i') as Stop, + DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(vpstime)), '%H%i') as VpsStart, + DATE_FORMAT(FROM_UNIXTIME(UNIX_TIMESTAMP(vpstime) + duration), '%H%i') as VpsStop +FROM + EPG +WHERE + eventid = ? +|); + $sth->execute($obj->{prevminutes} * 60, $obj->{prevminutes} * 60, $obj->{afterminutes} * 60, $epgid) + or return $console->err(sprintf(gettext("Event ID '%s' does not exist in the database!"),$epgid)); + $epg = $sth->fetchrow_hashref(); + } + if(not ref $epg) { + my $t = time; + $epg = { + channel_id => '', + File => '', + Summary => '', + Day => $obj->{newTimerFormat}?my_strftime("%Y-%m-%d",$t):my_strftime("%d",$t), + Start => my_strftime("%H%M",$t), + Stop => my_strftime("%H%M",$t) + }; + } + + $epg->{Status} = '1' + if(not defined $epg->{Status}); + $epg->{Priority} = $obj->{Priority} + if(not defined $epg->{Priority}); + $epg->{Lifetime} = $obj->{Lifetime} + if(not defined $epg->{Lifetime}); + if(main::getVdrVersion() >= 10344) { + $epg->{desc} = $epg->{Summary}; + $epg->{Summary} = "" + } + if($epg->{VpsStart} && $obj->{usevpstime} eq 'y') { + $epg->{Status} |= 4; + $epg->{Start} = $epg->{VpsStart}; + $epg->{Stop} = $epg->{VpsStop}; + } + + $obj->editTimer($watcher, $console, 0, $epg); +} + +# ------------------ +sub editTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $timerid = shift || 0; # If timerid the edittimer + my $data = shift || 0; # Data for defaults + + my $timerData; + if($timerid and not ref $data) { + my $sth = $obj->{dbh}->prepare( +qq| +SELECT + Id, + ChannelID as channel_id, + File, + Summary, + Start, + Stop, + Day, + Priority, + Lifetime, + Status +FROM + TIMERS +WHERE + Id = ? +|); + $sth->execute($timerid) + or return $console->err(sprintf(gettext("Timer ID '%s' does not exist in the database!"),$timerid)); + $timerData = $sth->fetchrow_hashref(); + } elsif (ref $data eq 'HASH') { + $timerData = $data; + } + + $timerData->{Summary} =~ s/(\r|\n)//sig + if(defined $timerData->{Summary}); + + my $mod = main::getModule('CHANNELS'); + my $con = $console->typ eq "CONSOLE"; + + my $questions = [ + 'Id' => { + typ => 'hidden', + def => $timerData->{Id} || 0, + }, + 'Activ' => { + typ => 'confirm', + def => (defined $timerData->{Status} and ($timerData->{Status} & 1) ? 'y' : 'n'), + msg => gettext('Switch this timer on?'), + }, + 'VPS' => { + typ => 'confirm', + def => (defined $timerData->{Status} and ($timerData->{Status} & 4) ? 'y' : 'n'), + msg => gettext('VPS for this timer on?'), + }, + 'ChannelID' => { + typ => 'list', + def => $con ? $mod->ChannelToPos($timerData->{channel_id}) : $timerData->{channel_id}, + choices => $con ? $mod->ChannelArray('Name') : $mod->ChannelIDArray('Name'), + msg => gettext('Which channel should recorded?'), + req => gettext("This is required!"), + check => sub{ + my $value = shift || return; + + if(my $name = $mod->ChannelToName($value)) { + $timerData->{Channel} = $value; + return $value; + } elsif(my $ch = $mod->PosToChannel($value) || $mod->NameToChannel($value) ) { + $timerData->{Channel} = $value; + return $ch; + } elsif( ! $mod->NameToChannel($value)) { + return undef, sprintf(gettext("This channel '%s' does not exist!"),$value); + } else { + return undef, gettext("This is required!"); + } + }, + }, + 'Day' => { + typ => $con ? 'string' : 'date', + def => $timerData->{Day}, + msg => gettext("Please enter a day (1 to 31) or the weekday in format 'MDMDFSS'."), + req => gettext("This is required!"), + check => sub{ + my $value = shift || return; + if(($value =~ /^\d+$/ and int($value) <= 31 and int($value) > 0) # 13 + or ($obj->{newTimerFormat} and $value =~ /^\d{4}\-\d{2}-\d{2}$/sig) # 2005-03-13 + or $value =~ /^\S{7}\@\d{4}\-\d{2}-\d{2}$/sig # MTWTFSS@2005-03-13 + or $value =~ /^\S{7}\@\d{2}$/sig # MTWTFSS@13 + or $value =~ /^\S{7}$/) { # MTWTFSS + return $value; + } else { + return undef, gettext('No right day or corrupt format!'); + } + }, + }, + 'Start' => { + typ => 'string', + def => sub{ + return fmttime($timerData->{Start}); + }, + msg => gettext("Starttime in format 'HH:MM'"), + check => sub{ + my $value = shift; + $value = fmttime($value) if($value =~ /^\d+$/sig); + return undef, gettext('No right time!') if($value !~ /^\d+:\d+$/sig); + my @v = split(':', $value); + $value = sprintf('%02d%02d',$v[0],$v[1]); + if(int($value) < 2400 and int($value) >= 0) { + return sprintf('%04d',$value); + } else { + return undef, gettext('No right time!'); + } + }, + }, + 'Stop' => { + typ => 'string', + def => sub{ + return fmttime($timerData->{Stop} || 0 ); + }, + msg => gettext("Endtime in format 'HH:MM'"), + check => sub{ + my $value = shift; + $value = fmttime($value) if($value =~ /^\d+$/sig); + return undef, gettext('No right time!') if($value !~ /^\d+:\d+$/sig); + my @v = split(':', $value); + $value = sprintf('%02d%02d',$v[0],$v[1]); + if(int($value) < 2400 and int($value) >= 0) { + return sprintf('%04d',$value); + } else { + return undef, gettext('No right time!'); + } + }, + }, + 'Priority' => { + typ => 'integer', + msg => sprintf(gettext('Priority (0 .. %d)'),$console->{USER}->{MaxPriority} ? $console->{USER}->{MaxPriority} : 99 ), + def => int($timerData->{Priority}), + check => sub{ + my $value = shift || 0; + if($value =~ /^\d+$/sig and $value >= 0 and $value < 100) { + if($console->{USER}->{MaxPriority} and $value > $console->{USER}->{MaxPriority}) { + return undef, sprintf(gettext('Sorry, but maximum priority is limited on %d!'), $console->{USER}->{MaxPriority}); + } + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'Lifetime' => { + typ => 'integer', + msg => sprintf(gettext('Lifetime (0 .. %d)'),$console->{USER}->{MaxLifeTime} ? $console->{USER}->{MaxLifeTime} : 99 ), + def => int($timerData->{Lifetime}), + check => sub{ + my $value = shift || 0; + if($value =~ /^\d+$/sig and $value >= 0 and $value < 100) { + if($console->{USER}->{MaxLifeTime} and $value > $console->{USER}->{MaxLifeTime}) { + return undef, sprintf(gettext('Sorry, but maximum lifetime is limited on %d!'), $console->{USER}->{MaxLifeTime}); + } + return int($value); + } else { + return undef, gettext('No right Value!'); + } + }, + }, + 'File' => { + msg => gettext('Title of recording'), + def => $timerData->{File}, + req => gettext("This is required!"), + }, + ]; + + my $Summary = $timerData->{Summary}; + $Summary =~s/\#~AT\[(\d+)\]//g; + + if(main::getVdrVersion() >= 10344){ + if($timerData->{Id} || $timerData->{desc}) { + my $desc = $timerData->{desc} || $obj->getEpgDesc($timerData->{Id}); + if($desc) { + push(@$questions, + 'Description' => { + msg => gettext('Description'), + typ => 'string', + def => $desc, + readonly => 1 + }); + } + } + + push(@$questions, + 'Summary' => { + typ => 'hidden', + def => $Summary, + }); + } else { + push(@$questions, + 'Summary' => { + msg => gettext('Additional description'), + def => $Summary, + check => sub{ + my $value = shift || return; + $value =~ s/(\r|\n)//sig; + return $value; + }, + }); + } + # Ask Questions + my $datasave = $console->question(($timerid ? gettext('Edit timer') + : gettext('New timer')), $questions, $data); + + if(ref $datasave eq 'HASH') { + my $erg = $obj->saveTimer($datasave, $timerid); + + my $error; + foreach my $zeile (@$erg) { + if($zeile =~ /^(\d{3})\s+(.+)/) { + $error = $2 if(int($1) >= 500); + } + } + + unless($error) { + debug sprintf('%s timer with title "%s" is saved%s', + ($timerid ? 'Changed' : 'New'), + $data->{File}, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ ); + $console->message($erg); + } else { + error sprintf('%s timer with title "%s" does\'nt saved : %s', + ($timerid ? 'Changed' : 'New'), + $data->{File}, + $error + ); + $console->err($erg); + } + $obj->readData($watcher,$console); + $console->redirect({url => $console->{browser}->{Referer}, wait => 2}) + if($console->typ eq 'HTML'); + } +} + +# ------------------ +sub deleteTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + my $timerid = shift || return $console->err(gettext("No Timer ID to delete! Please use tdelete 'tid'")); # If timerid the edittimer + my $answer = shift || 0; + + my @timers = reverse sort{ $a <=> $b } split(/[^0-9]/, $timerid); + + my $sql = sprintf('SELECT Id,File,ChannelID,NextStartTime,IF(NOW() between NextStartTime and NextStopTime,1,0) as Running FROM TIMERS where Id in (%s)', join(',' => ('?') x @timers)); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@timers) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $data = $sth->fetchall_hashref('Id'); + + my $mod = main::getModule('CHANNELS') or return; + foreach my $tid (@timers) { + unless(exists $data->{$tid}) { + $console->err(sprintf(gettext("Timer with number '%s' does not exist in the database!"), $tid)); + next; + } + + if(ref $console and $console->{TYP} eq 'CONSOLE') { + $data->{$tid}->{ChannelID} = $mod->ChannelToName($data->{$tid}->{ChannelID}); + + $console->table($data->{$tid}); + my $confirm = $console->confirm({ + typ => 'confirm', + def => 'y', + msg => gettext('Are you sure to delete this timer?'), + }, $answer); + next if(!$answer eq 'y'); + } + + debug sprintf('Delete timer with title "%s"%s', + $data->{$tid}->{File}, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ ); + + $obj->{svdrp}->queue_cmds(sprintf("modt %d off", $tid)) + if($data->{$tid}->{Running}); + $obj->{svdrp}->queue_cmds(sprintf("delt %d", $tid)); + } + + if($obj->{svdrp}->queue_cmds('COUNT')) { + my $erg = $obj->{svdrp}->queue_cmds("CALL"); # Aufrufen der Kommandos + $console->msg($erg, $obj->{svdrp}->err) + if(ref $console); + + sleep(1); + + $obj->readData($watcher,$console); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 1}) + if(ref $console and $console->typ eq 'HTML'); + } else { + $console->err(gettext("No timer to delete!")); + } + + return 1; +} + +# ------------------ +sub toggleTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $timerid = shift || return $console->err(gettext("No Timer ID to toggle! Please use ttoggle 'id'")); # If timerid the edittimer + + my @timers = reverse sort{ $a <=> $b } split(/[^0-9]/, $timerid); + + my $sql = sprintf('SELECT Id,File,Status,NextStartTime, NextStopTime FROM TIMERS where Id in (%s)', join(',' => ('?') x @timers)); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@timers) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $data = $sth->fetchall_hashref('Id'); + my $ref; + + for my $timer (@timers) { + + unless(exists $data->{$timer}) { + $console->err(sprintf(gettext("Timer with number '%s' does not exist in the database!"), $timer)); + next; + } + + # Build query for all timers with possible collisions + $ref .= " or '$data->{$timer}->{NextStartTime}' between NextStartTime and NextStopTime" + . " or '$data->{$timer}->{NextStopTime}' between NextStartTime and NextStopTime"; + + + my $status = (($data->{$timer}->{Status} & 1) ? 'off' : 'on'); + + debug sprintf('Timer with title "%s" is %s%s', + $data->{$timer}->{File}, + ($status eq 'on' ? 'activated' : 'deactivated'), + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" )
+ ); + + $obj->{svdrp}->queue_cmds("modt $data->{$timer}->{Id} $status"); # Sammeln der Kommandos + } + + if($obj->{svdrp}->queue_cmds('COUNT')) { + + my $erg = $obj->{svdrp}->queue_cmds("CALL"); # Aufrufen der Kommandos + $console->msg($erg, $obj->{svdrp}->err) + if(ref $console and $console->typ ne 'AJAX'); + + $obj->readData($watcher, $console); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 1}) + if(ref $console and $console->typ eq 'HTML'); + + if(ref $console and $console->typ eq 'AJAX') { + # { "data" : [ [ ID, ON, RUN, CONFLICT ], .... ] } + # { "data" : [ [ 5, 1, 0, 0 ], .... ] } + my $sql = sprintf('select Id, Status & 1 as Active, IF(NOW() between NextStartTime and NextStopTime,1,0) as Running, Collision from TIMERS where Id in (%s) %s', + join(',' => ('?') x @timers),$ref); + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute(@timers) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $erg = $sth->fetchall_arrayref(); + $console->table($erg); + } + + return 1; + } else { + $console->err(gettext('No timer to toggle!')); + return undef; + } +} + + +# ------------------ +sub insert { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return; + my $pos = shift || return; + my $checked = shift || 0; + + # import only status which used from vdr and thereby exclude eventid from vdradmin + $data->[0] &= 15; + + # change pos to channelid, because change to telnet reader + $data->[1] = $obj->{channels}->{$data->[1]}->{Id} + if(index($data->[1], '-') < 0); + + # POS + unshift(@$data, $pos); + $data->[8] =~ s/\|/\:/g; + + # NextTime + my $nexttime = $obj->getNextTime( $data->[3], $data->[4], $data->[5] ) + or return error(sprintf("Can't get time form this data: %s", join(' ', @$data))); + push(@$data, $nexttime->{start}, $nexttime->{stop}); + + # insert placeholder + push(@$data, 0); # eventid + push(@$data, 0); # eventstarttime + push(@$data, 0); # eventduration + + # AutotimerId + my $atxt = (split('~', $data->[9]))[-1]; + my $aid = $1 if(defined $atxt and $atxt =~ /AT\[(\d+)\]/); + push(@$data, $aid || 0); + + # checked + push(@$data, $checked); + + # Search for event at EPG + my $e = $obj->_getNextEpgId( { + Id => $data->[0], + ChannelID => $data->[2], + File => $data->[8], + NextStartTime => $data->[10], + NextStopTime => $data->[11], + }); + if($e and exists $e->{eventid}) { + $data->[12] = $e->{eventid}; + $data->[13] = $e->{starttime}; + $data->[14] = $e->{duration}; + } + + my $sth = $obj->{dbh}->prepare('REPLACE INTO TIMERS VALUES (?,?,?,?,?,?,?,?,?,?,FROM_UNIXTIME(?), FROM_UNIXTIME(?),0,?,?,?,?,NOW(),?)'); + $sth->execute( @$data ); +} + + +# Read from svdrp (better for future development) +# ------------------ +sub readData { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift; + my $console = shift; + + # Search for old and deactivated Timers and delete this + $obj->getOldDeactivTimer() + if($obj->{deactive} eq 'y'); + + # Search for correct times + $obj->getCheckTimer() + if($obj->{adjust} eq 'y'); + + my $oldTimers = &getDataByTable('TIMERS'); + + $obj->{dbh}->do('DELETE FROM TIMERS'); + + # read from svdrp, because the + # vdr edit the timers.conf to lazy ;) + $obj->{channels} = main::getModule('CHANNELS')->ChannelHash('POS'); + my $tlist = $obj->{svdrp}->command('lstt'); + + my $c = 0; + foreach my $line (@$tlist) { + next if(! $line or $line =~ /^22/); + $line =~ s/^\d+[- ]+\d+\s//sig; + $c++; + my @data = split(':', $line, 9); + + $obj->insert(\@data, $c, 1) + if(scalar @data > 2); + } + + # Search for overlapping Timers + my $overlapping = $obj->getOverlappingTimer(); + + # Get timers by Autotimer + my $aids = getDataByFields('AUTOTIMER', 'Id'); + $obj->getTimersByAutotimer($aids); + + # Get new timers by User + if($oldTimers) { + my $timers = $obj->getNewTimers($oldTimers); + foreach my $timerdata (@$timers) { + event('New timer "%s" with id: "%d"', $timerdata->{File}, $timerdata->{Id}); + } + $obj->updated() if(scalar @$timers); + } + + $obj->{REGISTER}++; + if(scalar keys %$oldTimers != $c or $obj->{REGISTER} == 2) { + # Event to signal we are finish to read + event(sprintf('Reread %d timers and written to DB!', $c)); + } + + $console->message(sprintf(gettext("Write %d timers in database."), $c), {overlapping => $overlapping}) + if(ref $console and $console->typ ne 'AJAX'); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 1}) + if(ref $console and $console->typ eq 'HTML'); + + return 1; +} + +# Routine um Callbacks zu registrieren und +# diese nach dem Aktualisieren der Timer zu starten +# ------------------ +sub updated { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $cb = shift || 0; + my $log = shift || 0; + + if($cb) { + push(@{$obj->{after_updated}}, [$cb, $log]); + } else { + foreach my $CB (@{$obj->{after_updated}}) { + next unless(ref $CB eq 'ARRAY'); + lg $CB->[1] + if($CB->[1]); + &{$CB->[0]}() + if(ref $CB->[0] eq 'CODE'); + } + } +} +# ------------------ +sub list { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $text = shift || ''; + + my $in = ''; + if($text and $text =~ /^[0-9,_ ]+$/ ) { + my @timers = split(/[^0-9]/, $text); + $in = sprintf("and t.Id in ( %s )",join(',',@timers)); + } elsif($text) { + $in = sprintf('and ( %s )', buildsearch("t.File,t.Summary",$text)); + } + my %f = ( + 'Id' => umlaute(gettext('Sv')), + 'Status' => umlaute(gettext('Status')), + 'Prg' => umlaute(gettext('Prg')), + 'Channel' => umlaute(gettext('Channel')), + 'Start' => umlaute(gettext('Start')), + 'Stop' => umlaute(gettext('Stop')), + 'File' => umlaute(gettext('File')), + 'Priority' => umlaute(gettext('Priority')), + ); + + my $sql = qq| +SELECT + t.Id as $f{'Id'}, + t.Status as $f{'Status'}, + c.Name as $f{'Channel'}, + c.Pos as __Pos, + t.Day as $f{'Prg'}, + DATE_FORMAT(t.NextStartTime, '%H:%i') as $f{'Start'}, + DATE_FORMAT(t.NextStopTime, '%H:%i') as $f{'Stop'}, + t.File as $f{'File'}, + t.Priority as $f{'Priority'}, + UNIX_TIMESTAMP(t.NextStartTime) as __Day, + t.Collision as __Collision, + t.eventid as __eventid, + t.AutotimerId as __AutotimerId, + UNIX_TIMESTAMP(t.NextStopTime) - UNIX_TIMESTAMP(t.NextStartTime) as __Duration, + e.description as __description +FROM + TIMERS as t, + CHANNELS as c, + EPG as e +WHERE + t.ChannelID = c.Id + and (t.eventid = e.eventid) + $in + +UNION + +SELECT + t.Id as $f{'Id'}, + t.Status as $f{'Status'}, + c.Name as $f{'Channel'}, + c.Pos as __Pos, + t.Day as $f{'Prg'}, + DATE_FORMAT(t.NextStartTime, '%H:%i') as $f{'Start'}, + DATE_FORMAT(t.NextStopTime, '%H:%i') as $f{'Stop'}, + t.File as $f{'File'}, + t.Priority as $f{'Priority'}, + UNIX_TIMESTAMP(t.NextStartTime) as __Day, + t.Collision as __Collision, + t.eventid as __eventid, + t.AutotimerId as __AutotimerId, + UNIX_TIMESTAMP(t.NextStopTime) - UNIX_TIMESTAMP(t.NextStartTime) as __Duration, + "" as __description +FROM + TIMERS as t, + CHANNELS as c +WHERE + t.ChannelID = c.Id + and (t.eventid = 0) + $in + +ORDER BY + __Day +|; + + my $fields = fields($obj->{dbh}, $sql); + + my $erg = $obj->{dbh}->selectall_arrayref($sql); + unshift(@$erg, $fields); + $console->table($erg, { + runningTimer => $obj->getRunningTimer, + cards => $obj->{DVBCards}, + capacity => main::getModule('RECORDS')->{CapacityFree}, + }); +} + +# ------------------ +sub getTimerById { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $tid = shift || return error ('No TimerId!' ); + + my $sql = qq| +SELECT + t.Id, + t.Status, + c.Name as Channel, + c.Pos as __Pos, + t.Day as Prg, + t.Start, + t.Stop, + t.File, + t.Priority, + UNIX_TIMESTAMP(t.NextStartTime) as Day, + t.Collision as Collision, + t.eventid as eventid, + t.AutotimerId as AutotimerId +FROM + TIMERS as t, + CHANNELS as c +WHERE + t.ChannelID = c.Id + and t.Id = ? +|; + + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($tid) + or return error(sprintf("Timer ID '%s' does not exist in the database!",$tid)); + return $sth->fetchrow_hashref(); +} + + +# ------------------ +sub getRunningTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $rowname = shift || 'Id'; + my $sql = "select $rowname from TIMERS where NOW() between NextStartTime and NextStopTime AND (Status & 1)"; + my $erg = $obj->{dbh}->selectall_hashref($sql, $rowname); + return $erg; +} + +# ------------------ +sub getNewTimers { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $oldTimers = shift || return; + + my $ret = []; + foreach my $timerid (keys %$oldTimers) { + if(! $oldTimers->{$timerid}->{Checked}) { + push(@$ret, $oldTimers->{$timerid}); + } + } + return $ret; +} + +# ------------------ +sub getOldDeactivTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $sql = "select Id from TIMERS where not (Status & 1) and UNIX_TIMESTAMP(NextStopTime) > UNIX_TIMESTAMP() + (60*60*24*28)"; + my $erg = $obj->{dbh}->selectall_hashref($sql, 'Id'); + + foreach my $t (reverse sort {$a <=> $b} keys %$erg) { + $obj->{svdrp}->queue_cmds("delt $t"); + } + $obj->{svdrp}->queue_cmds("CALL") + if($obj->{svdrp}->queue_cmds("COUNT")); + return $erg; +} + +# ------------------ +sub getCheckTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $sql = qq| +SELECT t.Id as Id, t.Status as Status,t.ChannelID as ChannelID, + t.Priority as Priority, t.Lifetime as Lifetime, + t.File as File, t.Summary as Summary, + t.Start as TimerStart,t.Stop as TimerStop, + + UNIX_TIMESTAMP(e.starttime) as starttime, + UNIX_TIMESTAMP(e.starttime) + e.duration as stoptime, + UNIX_TIMESTAMP(e.vpstime) as vpsstart, + UNIX_TIMESTAMP(e.vpstime) + e.duration as vpsstop, + + ABS(UNIX_TIMESTAMP(t.eventstarttime) - UNIX_TIMESTAMP(NextStartTime)) as lead, + ABS(UNIX_TIMESTAMP(NextStopTime)-(UNIX_TIMESTAMP(t.eventstarttime) + t.eventduration)) as lag + + FROM TIMERS as t, EPG as e + WHERE (Status & 1) + AND e.eventid > 0 + AND t.eventid = e.eventid + AND ((e.starttime != t.eventstarttime) OR (e.duration != t.eventduration)) + AND SUBSTRING_INDEX( t.File , '~', 1 ) LIKE CONCAT('%', e.title ,'%') +|; + my $erg = $obj->{dbh}->selectall_hashref($sql, 'Id'); + + foreach my $t (keys %$erg) { + my %tt; + +# dumper($erg->{$t}); + + # Adjust start and stop times + my $start; + my $stop; + + if(($erg->{$t}->{Status} & 4) # Use VPS Time if used + and $erg->{$t}->{vpsstart} + and $erg->{$t}->{vpsstop}) { + $start = $erg->{$t}->{vpsstart}; + $stop = $erg->{$t}->{vpsstop}; + } else { + $start = $erg->{$t}->{starttime} - $erg->{$t}->{lead}; + $stop = $erg->{$t}->{stoptime} + $erg->{$t}->{lag}; + } + + # Format parameterhash for saveTimer + my $tt = { + Activ => (($erg->{$t}->{Status} & 1) ? 'y' : 'n'), + VPS => (($erg->{$t}->{Status} & 4) ? 'y' : 'n'), + ChannelID => $erg->{$t}->{ChannelID}, + File => $erg->{$t}->{File}, + Summary => $erg->{$t}->{Summary}, + Day => $obj->{newTimerFormat}?my_strftime("%Y-%m-%d",$start):my_strftime("%d",$start), + Start => my_strftime("%H%M",$start), + Stop => my_strftime("%H%M",$stop), + Priority => $erg->{$t}->{Priority}, + Lifetime => $erg->{$t}->{Lifetime} + }; + + my $timer = $erg->{$t}->{Id}; + + debug sprintf("Adjust timer %d (%s) at %s : from %s - %s to %s - %s", + $timer, + $tt->{File}, + $tt->{Day}, + fmttime($erg->{$t}->{TimerStart}), fmttime($erg->{$t}->{TimerStop}), + fmttime($tt->{Start}),fmttime($tt->{Stop})); + + $obj->saveTimer($tt, $timer); + } + return $erg; +} + +# ------------------ +sub getEpgIds { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $sql = "select Id, Status & 1 as Status, eventid from TIMERS where eventid > 0"; + my $erg = $obj->{dbh}->selectall_hashref($sql, 'eventid'); + return $erg; +} + +# ------------------ +sub getEpgDesc { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $tid = shift || return error ('No TimerId!' ); + + my $sql = qq| +select + description from TIMERS as t, EPG as e +where + e.eventid > 0 and + t.eventid = e.eventid and + t.id = ? +|; + + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($tid) + or return error(sprintf("Timer ID '%s' does not exist in the database!",$tid)); + my $erg = $sth->fetchrow_hashref(); + return $erg ? $erg->{description} : ''; +} + +# ------------------ +sub getOverlappingTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $sql = qq| +select + TIMERS.Id, + TIMERS.Priority, + TIMERS.NextStartTime, + TIMERS.NextStopTime, + CHANNELS.TID as transponderid, + LEFT(CHANNELS.Source,1) as source +from TIMERS, + CHANNELS +where TIMERS.ChannelID = CHANNELS.Id +|; + my $erg = $obj->{dbh}->selectall_hashref($sql, 'Id'); + my $return; + + my $sth = $obj->{dbh}->prepare("UPDATE TIMERS SET Collision = ? WHERE Id = ?"); + foreach my $tid (keys %$erg) { + my $result = $obj->checkOverlapping($erg->{$tid}); + if(ref $result eq 'ARRAY' and scalar @$result) { + my $col = join(',',@$result); + $sth->execute($col,$tid); + $return->{"timer_$tid"} = $col; + } + + + } + return $return; +} + +# ------------------ +sub checkOverlapping { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + + my $NextStartTime = $data->{NextStartTime}; + my $NextStopTime = $data->{NextStopTime}; + my $transponder = $data->{transponderid}; + my $source = $data->{source}; + my $Priority = $data->{Priority} || $obj->{Priority}; + my $tid = $data->{Id} || 0; + + my $sql = qq| +SELECT + t.Id, + t.Priority, + c.TID +FROM + TIMERS as t, CHANNELS as c +WHERE + ((? between t.NextStartTime AND t.NextStopTime) + OR (? between t.NextStartTime AND t.NextStopTime) + OR (t.NextStartTime between ? AND ?) + OR (t.NextStopTime between ? AND ?)) + AND t.Id != ? + AND (t.Status & 1) + AND t.ChannelID = c.Id + AND c.TID != ? + AND LEFT(c.Source,1) = ? +ORDER BY + t.Priority desc +|; + my $sth = $obj->{dbh}->prepare($sql); + $sth->execute($NextStartTime,$NextStopTime, + $NextStartTime,$NextStopTime, + $NextStartTime,$NextStopTime, + $tid,$transponder,$source) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $result = $sth->fetchall_arrayref(); + + if(scalar @{$result}) { + my $coltext = []; + foreach my $probant (@{$result}) { + + if(defined $probant->[0]) { + + # current timer has higher Priority + last + if($Priority > $probant->[1]); + + + # Store conflict line at line + my $col = sprintf('%d:%d', + $probant->[0], + $probant->[1]); + + # insert double transponder, on same line + my $n = 0; + foreach my $trans (@{$result}) { + + if(defined $trans->[0] + && $probant->[0] != $trans->[0] + && $probant->[2] == $trans->[2]) { + + $col .= sprintf('|%d:%d', + $trans->[0], + $trans->[1]); + + undef @{$result}[$n]->[0]; + } + ++$n; + } + # Add line + push(@$coltext,$col); + } + } + if(scalar(@$coltext) > $obj->{DVBCards} - 1) { + return $coltext; + } + } +} + +# ------------------ +sub getNextTimer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $erg = $obj->{svdrp}->command('NEXT abs'); + my @eerg = grep(/^250/, @$erg); + if(scalar @eerg and my ($errcode, $nextTimer, $zeit) = split(/\s+/, $eerg[0])) { + return if( + ! $nextTimer + or $zeit < time + or (ref $obj->{NextTimerEvent} and $obj->{NextTimerEvent}->at == $zeit) + ); + + my $timer = $obj->getTimerById($nextTimer); + + $obj->{NextTimerEvent} = Event->timer( + at => $zeit, + data => $timer, + hard => 1, + repeat => 0, + prio => 2, # -1 very hard ... 6 very low + cb => sub{ + my $event = shift; + my $watcher = $event->w; + my $data = $watcher->data; + + my $reportmod = main::getModule('REPORT'); + $reportmod->news( + sprintf(gettext("Timer %d with title '%s' is start to recording!"), $data->{Id}, $data->{File}), + sprintf(gettext("on channel: %s until %s"), $data->{Channel}, fmttime($data->{Stop})), + 'tedit', + $data->{Id}, + 'harmless' + ); + $watcher->cancel; + }, + ); + } +} + +# Find EPG to selected timer +# ------------------ +sub _getNextEpgId { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $timer = shift || return error ('No Hash!' ); + + my $e; + my @file = split('~', $timer->{File}); + + if(scalar @file >= 2) { # title and subtitle defined + my $sth = $obj->{dbh}->prepare(qq| + SELECT eventid,starttime,duration from EPG + WHERE + channel_id = ? + AND ((UNIX_TIMESTAMP(starttime) + (duration/2)) between ? and ? ) + AND (title like ? or title like ? ) + ORDER BY ABS(( ? )-UNIX_TIMESTAMP(starttime)) LIMIT 1 + |); + if(!$sth->execute($timer->{ChannelID}, + $timer->{NextStartTime}, + $timer->{NextStopTime}, + '%'.$file[-2].'%', + '%'.$file[-1].'%', + $timer->{NextStartTime})) { + lg sprintf("Can't find epg event for timer with id %d - %s", $timer->{Id} , $timer->{File} ); + return 0; + }
+ $e = $sth->fetchrow_hashref(); + + } else { + my $sth = $obj->{dbh}->prepare(qq| + SELECT eventid,starttime,duration from EPG + WHERE + channel_id = ? + AND ((UNIX_TIMESTAMP(starttime) + (duration/2)) between ? and ? ) + AND (title like ? ) + ORDER BY ABS(( ? )-UNIX_TIMESTAMP(starttime)) LIMIT 1 + |); + if(!$sth->execute($timer->{ChannelID}, + $timer->{NextStartTime}, + $timer->{NextStopTime}, + '%'.$timer->{File}.'%', + $timer->{NextStartTime})) { + lg sprintf("Can't find epg event for timer with id %d - %s", $timer->{Id} , $timer->{File} ); + return 0; + }
+ $e = $sth->fetchrow_hashref(); + } + + + lg sprintf("Can't find epg event for timer with id %d - %s", $timer->{Id} , $timer->{File} ) + if(not exists $e->{eventid}); + return $e; +} + +# The following subroutines is stolen from vdradmind and vdradmin-0.97-am +# Thanks on Cooper and Thomas for this great work! +# $obj->getNextTime('MDMDFSS', 1300, 1200) +# ------------------ +sub getNextTime { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $dor = shift || return error ('No Day!' ); + my $start = shift || return error ('No Starttime!' ); + my $stop = shift || return error ('No Stoptime!' ); + + $start = sprintf('%04d', $start); + $stop = sprintf('%04d', $stop); + + my ($startsse, $stopsse); + if(length($dor) == 7) { # repeating timer => MTWTFSS + $startsse = my_mktime(substr($start, 2, 2), substr($start, 0, 2), + my_strftime("%d"), (my_strftime("%m") - 1), my_strftime("%Y")); + $stopsse = my_mktime(substr($stop, 2, 2), substr($stop, 0, 2), + my_strftime("%d"), (my_strftime("%m") - 1), my_strftime("%Y")); + $stopsse += 86400 if($stopsse < $startsse); + + my $weekday = ((localtime(time))[6] + 6) % 7; + my $perrec = join("", substr($dor, $weekday), substr($dor, 0, $weekday)); + $perrec =~ m/^-+/g; + + my $off = (pos $perrec || 0) * 86400; + if($off == 0 && $stopsse < time) { + #$weekday = ($weekday + 1) % 7; + $perrec = join("", substr($dor, ($weekday + 1) % 7), substr($dor, 0, ($weekday + 1) % 7)); + $perrec =~ m/^-+/g; + $off = ((pos $perrec || 0) + 1) * 86400; + } + $startsse += $off; + $stopsse += $off; + } elsif(length($dor) == 18) { # first-day timer => MTWTFSS@2005-03-13 + $dor =~ /.{7}\@(\d{4})-(\d{2})-(\d{2})/; + $startsse = my_mktime(substr($start, 2, 2), + substr($start, 0, 2), $3, ($2 - 1), $1); + # 31 + 1 = ?? + $stopsse = my_mktime(substr($stop, 2, 2), + substr($stop, 0, 2), $stop > $start ? $3 : $3 + 1, + ($2 - 1), $1); + } else { # regular timer + if ($dor =~ /(\d{4})-(\d{2})-(\d{2})/) { # vdr >= 1.3.23 => 2005-03-13 + $startsse = my_mktime(substr($start, 2, 2), + substr($start, 0, 2), $3, ($2 - 1), $1); + + $stopsse = my_mktime(substr($stop, 2, 2), + substr($stop, 0, 2), $stop > $start ? $3 : $3 + 1, ($2 - 1), $1); + $obj->{newTimerFormat} = 1; + } + else { # vdr < 1.3.23 => 13 + $startsse = my_mktime(substr($start, 2, 2), + substr($start, 0, 2), $dor, (my_strftime("%m") - 1), + my_strftime("%Y")); + + $stopsse = my_mktime(substr($stop, 2, 2), + substr($stop, 0, 2), $stop > $start ? $dor : $dor + 1, + (my_strftime("%m") - 1), my_strftime("%Y")); + + # move timers which have expired one month into the future + if(length($dor) != 7 && $stopsse < time) { + $startsse = my_mktime(substr($start, 2, 2), + substr($start, 0, 2), $dor, (my_strftime("%m") % 12), + (my_strftime("%Y") + (my_strftime("%m") == 12 ? 1 : 0))); + + $stopsse = my_mktime(substr($stop, 2, 2), + substr($stop, 0, 2), $stop > $start ? $dor : $dor + 1, + (my_strftime("%m") % 12), + (my_strftime("%Y") + (my_strftime("%m") == 12 ? 1 : 0))); + } + } + } + + my $ret = { + start => $startsse, + stop => $stopsse, + }; + return $ret; +} + +# ------------------ +# Name: getTimersByAutotimer +# Descr: Routine group Autotimer to Timers. +# Usage: $hash = $obj->getTimersByAutotimer([$aid, $aid, $aid, ...]); +# ------------------ +sub getTimersByAutotimer { + my $obj = shift || return error ('No Object!' ); + my $aids = shift || return $obj->{AIDS}; + + $obj->{AIDS} = {}; + for my $aid (@$aids) { + $obj->{AIDS}->{$aid} = { + allTimer => [], + activeTimer => [], + deactiveTimer => [], + }; + my $erg = getDataBySearch('TIMERS', sprintf('AutotimerId = %d', $aid)); + map { + my $type = ($_->[1] ? 'activeTimer' : 'deactiveTimer'); + push(@{$obj->{AIDS}->{$aid}->{$type}}, $_->[0]); + push(@{$obj->{AIDS}->{$aid}->{allTimer}}, $_->[0]); + } @$erg; + } + return $obj->{AIDS}; +} + +# ------------------ +# Name: getRootDirs +# Descr: Get first root dir's. +# Usage: $hash = $obj->getRootDirs([$count]); +# ------------------ +sub getRootDirs { + my $obj = shift || return error ('No Object!' ); + my $count = shift || 1; + my $sql = "select distinct SUBSTRING_INDEX(File,'~',$count) from TIMERS;"; + my $erg = $obj->{dbh}->selectall_arrayref($sql); + my @ret; + for(@$erg) { + push(@ret, $_->[0]); + } + return \@ret; +} + +sub my_mktime { + my $sec = 0; + my $min = shift; + my $hour = shift; + my $mday = shift; + my $mon = shift; + my $year = shift() - 1900; + + return mktime($sec, $min, $hour, $mday, $mon, $year, 0, 0, -1); +} + +sub my_strftime { + my $format = shift; + my $time = shift || time; + return(strftime($format, localtime($time))); +} + +# ------------------
+sub suggest {
# ------------------
+ my $obj = shift || return error ('No Object!' );
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $search = shift; + my $params = shift; + + if($search) { + my $sql = qq| + SELECT
+ File
+ FROM + TIMERS + WHERE + ( File LIKE ? )
+ GROUP BY + File + ORDER BY + File + LIMIT 25 + |;
+ my $sth = $obj->{dbh}->prepare($sql); + $sth->execute('%'.$search.'%') + or return error sprintf("Can't execute query: %s.",$sth->errstr); + my $result = $sth->fetchall_arrayref();
+ $console->table($result)
+ if(ref $console && $result); + } +}
+
+1;
+ + +1; diff --git a/lib/XXV/MODULES/USER.pm b/lib/XXV/MODULES/USER.pm new file mode 100644 index 0000000..852cfd9 --- /dev/null +++ b/lib/XXV/MODULES/USER.pm @@ -0,0 +1,919 @@ +package XXV::MODULES::USER; + +use strict; + +use Tools; +use Locale::gettext; +use File::Path; + + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'USER', + Prereq => { + 'Net::IP::Match::Regexp qw( create_iprange_regexp match_ip )' + => 'Efficiently match IPv4 addresses against IPv4 ranges via regexp ', + }, + Description => +gettext("This module managed a Useradministration Interface. +for use you can set a Level to the hole Modul with +a parameter 'Level' in the main root or you can set +the same parameter in a function."), + Version => '0.94', + Date => '2007-06-24', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Switch the Userauthentification on or off'), + default => 'y', + type => 'confirm', + }, + withAuth => { + description => gettext('IP addresses with user authentification'), + default => '', + type => 'string', + check => sub{ + my $value = shift || return; + my @ips = split(/\s*,\s*/, $value); + for (@ips) { + return undef, sprintf(gettext('Your IP number (%s) is wrong! You need a IP with range (xxx.xxx.xxx.xxx/xx)'), $_) + unless ($_ =~ /\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\/\d+/); + } + return $value; + }, + }, + noAuth => { + description => gettext('IP addresses without user authentification'), + default => '', + type => 'string', + check => sub{ + my $value = shift || return; + my @ips = split(/\s*,\s*/, $value); + for (@ips) { + return undef, sprintf(gettext('Your IP number (%s) is wrong! You need a IP with range (xxx.xxx.xxx.xxx/xx)'), $_) + unless ($_ =~ /\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}\/\d+/); + } + return $value; + }, + }, + tempimages => { + description => gettext('common directory for temporary images'), + default => '/var/cache/xxv/temp', + type => 'dir', + required => gettext('This is required!'), + }, + }, + Commands => { + unew => { + description => gettext('Create a new account for user'), + short => 'un', + callback => sub{ $obj->create(@_) }, + Level => 'admin', + }, + udelete => { + description => gettext("Delete a account of user 'uid'"), + short => 'ud', + callback => sub{ $obj->delete(@_) }, + Level => 'admin', + }, + uedit => { + description => gettext("Edit a account of user 'uid'"), + short => 'ue', + callback => sub{ $obj->edit(@_) }, + Level => 'admin', + }, + uprefs => { + description => gettext("Change the own preferences"), + short => 'up', + callback => sub{ $obj->userprefs(@_) }, + Level => 'user', + }, + ulist => { + description => gettext("List the accounts of users"), + short => 'ul', + callback => sub{ $obj->list(@_) }, + Level => 'admin', + }, + logout => { + description => gettext("Logout from the current Session"), + short => 'exit', + callback => sub{ + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + if($obj->{active} eq 'y') { + $console->message(gettext("Session closed.")); + $console->redirect({url => '?', parent => 'top', wait => 2}) + if($console->typ eq 'HTML'); + + my $ConsoleMod; + my $delayed = 0; + if($console->typ eq 'HTML' || $console->typ eq 'AJAX') { + $ConsoleMod = main::getModule('HTTPD'); + $delayed = 1; + } elsif ($console->typ eq 'WML') { + $ConsoleMod = main::getModule('WAPD'); + $delayed = 1; + } elsif ($console->typ eq 'CONSOLE') { + $ConsoleMod = main::getModule('TELNET'); + }; + + if($delayed) { + # Close session delayed, give browser my time load depends files like style.css + Event->timer( + after => 1, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ + $obj->logout; + delete $console->{USER} if($console->{USER}); + $ConsoleMod->{LOGOUT} = 1 if($ConsoleMod); + }, + ); + } else { + $obj->logout; + delete $console->{USER} if($console->{USER}); + $ConsoleMod->{LOGOUT} = 1 if($ConsoleMod); + } + } + }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + my $erg = $self->_init or return error('Problem to initialize module'); + + return $self; +} + +# ------------------ +sub _init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return 0, panic("Session to database is'nt connected") + unless($obj->{dbh}); + + # don't remove old table, if updated rows => warn only + tableUpdated($obj->{dbh},'USER',9,0); + + # Look for table or create this table + my $version = main::getVersion; + my $erg = $obj->{dbh}->do(qq| + CREATE TABLE IF NOT EXISTS USER ( + Id int(11) unsigned auto_increment NOT NULL, + Name varchar(100) NOT NULL default '', + Password varchar(100) NOT NULL, + Level set('admin', 'user', 'guest' ) NOT NULL, + Prefs varchar(100) default '', + UserPrefs varchar(100) default '', + Deny set('tlist', 'alist', 'rlist', 'mlist', 'tedit', 'aedit', 'redit', 'remote', 'stream', 'cedit', 'media'), + MaxLifeTime tinyint(2) default '0', + MaxPriority tinyint(2) default '0', + PRIMARY KEY (Id) + ) COMMENT = '$version' + |); + + # The Table is empty? Make a default User ... + unless($obj->{dbh}->selectrow_arrayref('select count(*) from USER')->[0]) { + $obj->_insert({ + Name => 'xxv', + Password => 'xxv', + Level => 'admin', + }); + } +} + + +# ------------------ +# Name: create +# Descr: Save a new User in the Usertable. +# Usage: my $ok = $obj->create($watcher, $console, 0, {name => 'user', ...}); +# ------------------ +sub create { + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $data = shift || 0; + + $obj->edit($watcher, $console, $id, $data); + +} + +# ------------------ +sub userprefs { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || $obj->{USER}->{Id}; + my $data = shift || 0; + + my $user; + if($id and not ref $data) { + my $sth = $obj->{dbh}->prepare('select * from USER where Id = ?'); + $sth->execute($id) + or return $console->err(sprintf(gettext("Account for user with ID '%s' does not exist in the database!"),$id)); + $user = $sth->fetchrow_hashref(); + } + + my $questions = [ + 'Id' => { + typ => 'hidden', + def => $user->{Id} || 0, + }, + 'Password' => { + typ => 'password', + msg => gettext("Password for this account"), + req => gettext('This is required!'), + def => '', + check => sub{ + my $value = shift || return; + # If no password given the + # take the old password as default + if($console->typ eq 'HTML') { + if($value->[0] and $value->[0] ne $value->[1]) { + return undef, gettext("Field with 1st and 2nd password must be equal to confirm!"); + } else { + return $value->[0]; + } + } + else { + return $value; + } + }, + }, + 'UserPrefs' => { + def => $user->{UserPrefs} || '', + msg => gettext("Personality preferences for this User: ModName::Param=value, "), + typ => 'string', + check => sub{ + my $value = shift || return; + foreach my $pref (split(',', $value)) { + my ($modname, $parameter, $value) = $pref =~ /(\S+)::(\S+)\=(.+)/sg; + if(my $mod = main::getModule($modname)) { + unless(exists $mod->{$parameter}) { + return undef, sprintf(gettext("The Parameter '%s' in Module '%s' doesn't exist!"),$parameter, $mod); + } + } + } + return $value; + }, + }, + ]; + + # Ask Questions + $data = $console->question(sprintf(gettext('Edit preferences of user: %s'), $obj->{USER}->{Name}), $questions, $data); + + if(ref $data eq 'HASH') { + $obj->_insert($data); + + $obj->refreshUserSettings($data->{UserPrefs}, $user->{UserPrefs}); + + $console->message(gettext('Account for user saved!')); + if($console->typ eq 'HTML') { + $console->redirect({url => '?', parent => 'top', wait => 2}); + $console->message(gettext('Please wait ... refresh the interface!')); + } + } + return 1; +} + + +# ------------------ +# Name: edit +# Descr: Edit an existing User in the Usertable. +# Usage: my $ok = $obj->edit($watcher, $console, $id, [$data]); +# ------------------ +sub edit { + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || 0; + my $data = shift || 0; + + my $user; + if($id and not ref $data) { + my $sth = $obj->{dbh}->prepare('select * from USER where Id = ?'); + $sth->execute($id) + or return $console->err(sprintf(gettext("Account for user with ID '%s' does not exist in the database!"),$id)); + $user = $sth->fetchrow_hashref(); + + # question erwartet ein Array + my @deny = split(/\s*,\s*/, $user->{Deny}); + $user->{Deny} = \@deny; + } + + my %l = ( + 'admin' => gettext('Administrator'), + 'user' => gettext('User'), + 'guest' => gettext('Guest') + ); + + my $questions = [ + 'Id' => { + typ => 'hidden', + def => $user->{Id} || 0, + }, + 'Name' => { + msg => gettext("Name from this account"), + req => gettext('This is required!'), + def => $user->{Name} || '', + }, + 'Password' => { + typ => 'password', + msg => gettext("Password for this account"), + req => gettext('This is required!'), + def => '', + check => sub{ + my $value = shift || return; + # If no password given the + # take the old password as default + if($console->typ eq 'HTML') { + if($value->[0] and $value->[0] ne $value->[1]) { + return undef, gettext("Field with 1st and 2nd password must be equal to confirm!"); + } else { + return $value->[0]; + } + } + else { + return $value; + } + }, + }, + 'Level' => { + def => sub { + my $value = $user->{Level} || 'guest'; + return $l{$value}; + }, + msg => gettext("Level for this account"), + typ => 'radio', + req => gettext('This is required!'), + choices => [$l{'admin'},$l{'user'},$l{'guest'}], + check => sub{ + my $value = shift || return; + my $data = shift || return error('No Data in CB'); + unless(grep($_ eq $value, @{$data->{choices}})) { + my $ch = join(' ', @{$data->{choices}}); + return undef, sprintf(gettext("You can choose: %s!"),$ch); + } + foreach my $k (keys %l) { + return $k + if($value eq $l{$k}); + } + my $ch = join(' ', @{$data->{choices}}); + return undef, sprintf(gettext("You can choose: %s!"),$ch); + }, + }, + 'Deny' => { + msg => gettext('Deny class of commands'), + typ => 'checkbox', + choices => ['tlist', 'alist', 'rlist', 'mlist', 'tedit', 'aedit', 'redit', 'remote', 'stream', 'cedit', 'media'], + def => $user->{Deny} || '', + check => sub{ + my $value = shift || ''; + my $data = shift || return error('No Data in CB'); + my @vals = (ref $value eq 'ARRAY') ? @$value : split(/\s*,\s*/, $value); + + foreach my $v (@vals) { + unless(grep($_ eq $v, @{$data->{choices}})) { + my $ch = join(' ', @{$data->{choices}}); + return undef, sprintf(gettext("You can choose: %s!"),$ch); + } + } + return join(',', @vals); + }, + }, + 'Prefs' => { + def => $user->{Prefs} || '', + msg => gettext("Preferences for this User: ModName::Param=value, "), + typ => 'string', + check => sub{ + my $value = shift || return; + foreach my $pref (split(',', $value)) { + my ($modname, $parameter, $value) = $pref =~ /(\S+)::(\S+)\=(.+)/sg; + if(my $mod = main::getModule($modname)) { + unless(exists $mod->{$parameter}) { + return undef, sprintf(gettext("The Parameter '%s' in Module '%s' doesn't exist!"),$parameter, $mod); + } + } + } + return $value; + }, + }, + 'MaxLifeTime' => { + msg => gettext("Maximally permitted value for lifetime on timers"), + def => $user->{MaxLifeTime} || '0', + type => 'integer', + check => sub{ + my $value = shift || return 0; + unless(int($value) and int($value) > 0 and int($value) < 100) { + return undef, gettext("This value is not a integer or not between 0 and 100"); + } + return $value; + }, + }, + 'MaxPriority' => { + msg => gettext("Maximally permitted value for priority on timers"), + def => $user->{MaxPriority} || '0', + type => 'integer', + check => sub{ + my $value = shift || return 0; + unless(int($value) and int($value) > 0 and int($value) < 100) { + return undef, gettext("This value is not a integer or not between 0 and 100"); + } + return $value; + }, + }, + ]; + + # Ask Questions + $data = $console->question(($id ? gettext('Edit account of user') + : gettext('Create a new account for user')), $questions, $data); + + if(ref $data eq 'HASH') { + $obj->_insert($data); + + debug sprintf('%s account with name "%s" is saved%s', + ($id ? 'New' : 'Changed'), + $data->{Name}, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + $console->message(gettext('Account for user saved!')); + $console->redirect({url => $console->{browser}->{Referer}, wait => 2}) + if($console->typ eq 'HTML'); + } + return 1; +} + +# ------------------ +# Name: delete +# Descr: Delete an existing User in the Usertable with Id. +# Usage: my $ok = $obj->delete($watcher, $console, $id); +# ------------------ +sub delete { + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $id = shift || return $console->err(gettext("No ID for Account of user to delete! Please use udelete 'uid'")); + + my $sth = $obj->{dbh}->prepare('delete from USER where Id = ?'); + $sth->execute($id) + or return $console->err(sprintf(gettext("Account for user with ID '%s' does not exist in the database!"),$id)); + $console->message(sprintf gettext("Account of user %s is deleted."), $id); + + debug sprintf('Delete user account "%s"%s', + $id, + ( $console->{USER} && $console->{USER}->{Name} ? sprintf(' from user: %s', $console->{USER}->{Name}) : "" ) + ); + + $console->redirect({url => $console->{browser}->{Referer}, wait => 2}) + if($console->typ eq 'HTML'); + +} + + +# ------------------ +sub list { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + + my %f = ( + 'Id' => umlaute(gettext('Service')), + 'Name' => umlaute(gettext('Name')), + 'Level' => umlaute(gettext('Level')), + 'Prefs' => umlaute(gettext('Preferences')), + 'UserPrefs' => umlaute(gettext('UserPreferences')), + ); + + my $sql = qq| +select + Id as $f{Id}, + Name as $f{Name}, + Level as $f{Level}, + Prefs as $f{Prefs}, + UserPrefs as $f{UserPrefs} +from + USER + |; + my $fields = fields($obj->{dbh}, $sql); + + my $erg = $obj->{dbh}->selectall_arrayref($sql); + unshift(@$erg, $fields); + + $console->table($erg); +} + +# ------------------ +# Name: logout +# Descr: The routine for logout the user, this will clean the user temp files +# and make a rollback to the standard user settings. +# Usage: my $ok = $obj->logout(); +# ------------------ +sub logout { + my $obj = shift || return error ('No Object!' ); + + lg sprintf('Logout called%s', + $obj->{USER}->{Name} ? sprintf(" by user %s", $obj->{USER}->{Name}) : "" + ); + + # get the default user settings + $obj->setUserSettings($obj->{USER}->{UserPrefs}, 'rollback') + if($obj->{USER}->{UserPrefs}); + + # get the default settings + $obj->setUserSettings($obj->{USER}->{Prefs}, 'rollback') + if($obj->{USER}->{Prefs}); + + main::toCleanUp($obj->{USER}->{Name}); + delete $obj->{USER}; + return 1; +} + +# ------------------ +sub _checkIp { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $handle = shift || return; + + my $ip = getip($handle); + + if($obj->{withAuth}) { + my $regexp = create_iprange_regexp(split(/\s*,\s*/, $obj->{withAuth})); + if (match_ip($ip, $regexp)) { + return 0; + } + } + + if($obj->{noAuth}) { + my $regexp = create_iprange_regexp(split(/\s*,\s*/, $obj->{noAuth})); + if (match_ip($ip, $regexp)) { + return 1; + } + } + return 0; +} + +# ------------------ +# Name: check +# Descr: The loginroutine to check the User Name, Password +# or the ClientIPAdress. +# This will return a Userhash with the DB-Entrys. +# Usage: my $userHash = $obj->check($handle); +# ------------------ +sub check { + my $obj = shift || return error ('No Object!' ); + my $handle = shift || return; + + if($obj->_checkIp($handle)) { + $obj->{USER}->{Name} = undef; + $obj->{USER}->{Level} = 'admin'; + } else { + my $name = shift || return; + my $password = shift || return; + + + my $oldprefs = $obj->{USER}->{UserPrefs}; + + my $newUser = 0; + if((!$obj->{USER}) or (!scalar keys %{$obj->{USER}}) or $name ne $obj->{USER}->{Name}) { + lg sprintf('User %s try to login!', $name ); + $newUser = $name; + $obj->logout() + if($obj->{USER} and (scalar keys %{$obj->{USER}})); + } + + # check User + my $sth = $obj->{dbh}->prepare('select * from USER where Name = ? and Password = md5( ? )'); + $sth->execute($name, $password) + or return error sprintf("Can't execute query: %s.",$sth->errstr); + $obj->{USER} = $sth->fetchrow_hashref(); + + # Set the user settings from user + $obj->refreshUserSettings($obj->{USER}->{UserPrefs}, $oldprefs); + + # Set the user settings from admin + $obj->setUserSettings($obj->{USER}->{Prefs}, 'set') + if($obj->{USER}->{Prefs} and $newUser); + } + + if(my $level = $obj->getLevel($obj->{USER}->{Level})) { + $obj->{USER}->{value} = $level if($level); + } + + return $obj->{USER}; +} + +# ------------------ +sub refreshUserSettings { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $newprefs = shift || ''; + my $oldprefs = shift || ''; + + return 1 if($newprefs eq $oldprefs); + + $obj->setUserSettings($oldprefs, 'rollback') + if($oldprefs); + + $obj->setUserSettings($newprefs, 'set') + if($newprefs); + + my $mod = main::getModule('CONFIG'); + $mod->reconfigure(); + +} + + +# ------------------ +sub setUserSettings { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $prefs = shift || return error ('No Settings??'); + my $mode = shift || 'set'; + + foreach my $pref (split(',', $prefs)) { + my ($modname, $parameter, $value) = $pref =~ /(\S+)::(\S+)\=(.*)/sg; + if($modname and my $mod = main::getModule($modname) and my $cfg = main::getModule('CONFIG')->{config}) { + if(exists $mod->{$parameter}) { + if($mode eq 'set') { + $cfg->{$modname}->{$parameter} = $value; + } else { + $cfg->{$modname}->{$parameter} = $mod->{$parameter}; + } + } else { + error("The Parameter '$parameter' in Module '$mod' is doesn't exist!"); + } + } + } +} + +# ------------------ +sub allowCommand { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $modCfg = shift || return error('No Moduleinformation'); + my $cmdName = shift || return error('No Command name'); + my $user = shift || return error('No User'); + my $DontdumpViolation = shift || ''; + + if( + (exists $modCfg->{Level} and $user->{value} < $obj->getLevel($modCfg->{Level})) + or + (exists $modCfg->{Commands}->{$cmdName}->{Level} and $user->{value} < $obj->getLevel($modCfg->{Commands}->{$cmdName}->{Level})) + or + (exists $user->{Deny} and exists $modCfg->{Commands}->{$cmdName}->{DenyClass} and $user->{Deny} =~ /$modCfg->{Commands}->{$cmdName}->{DenyClass}/) + ) { + error(sprintf('User %s with Level %s has try to call command %s without permissions!', + $user->{Name}, $user->{Level}, $cmdName)) + if($DontdumpViolation eq ''); + return 0; + } + return 1; +} + +# ------------------ +# Name: checkCommand +# Descr: A routine to check the commands, translate the shortcuts. +# This will return the cmdobj and cmdname if this command ok. +# $shorterr is set in following Errorcases: +# 'noactive' = Plugin is not set active +# 'noperm' = Permission denied for the called User +# 'noexists' = Command does not exist! +# $error is the full Errortext to diaply im Userinterface. +# Usage: my ($cmdobj, $cmdname, $shorterr, $error) = $obj->checkCommand($console, $command); +# Test: +sub t_checkCommand { + my ($cmdobj, $cmdname, $shorterr, $error, $t) + = $_[0]->checkCommand($_[1], 'tl'); + $t = 1 if(ref $cmdobj and $cmdname eq 'tlist'); + ($cmdobj, $cmdname, $shorterr, $error) + = $_[0]->checkCommand($_[1], 'lalalalal'); + $t = 1 if(not ref $cmdobj and not $cmdname and $shorterr and $error); + return $t; +} +# ------------------ +sub checkCommand { + my $obj = shift || return error ('No Object!' ); + my $console = shift || return error ('No Console' ); + my $ucmd = shift || return error ('No Command' ); + my $DontdumpViolation = shift || ''; + + my $mods = main::getModules(); + my $err = 0; + my $shorterr = 0; + my $cmdobj = 0; + my $cmdname = 0; + my $cfg = main::getModule('CONFIG')->{config}; + my $ok = 0; + + # Checks the Commands Syntax (double shortcmds?) + $obj->checkCmdSyntax() + unless(defined $obj->{Check}); + + foreach my $modName (keys %{$mods}) { + my $modCfg = $mods->{$modName}->{MOD}; + foreach my $cmdName (sort keys %{$modCfg->{Commands}}) { + if(lc($ucmd) eq $cmdName or (exists $modCfg->{Commands}->{$cmdName}->{short} and lc($ucmd) eq $modCfg->{Commands}->{$cmdName}->{short})) { + $ok++; + $cmdobj = $modCfg->{Commands}->{$cmdName}; + $cmdname = $cmdName; + # Check on active Modul + if(exists $mods->{$modName}->{active} and $cfg->{$modCfg->{Name}}->{active} eq 'n') { + $err = sprintf(gettext("Sorry but the module %s is inactive! Switch this active in %s:Preferences:active = y"), + $modCfg->{Name}, $modCfg->{Name}); + $shorterr = 'noactive'; + } + + if($obj->{active} eq 'y') { + # Check Userlevel and Permissions + unless($obj->allowCommand($modCfg, $cmdName, $console->{USER},$DontdumpViolation)) { + $err = gettext('You have no permissions on this command!'); + $shorterr = 'noperm'; + } + } + } + } + } + unless($ok) { + $err = sprintf(gettext("I don't understand the command '%s' \n"), $ucmd); + $shorterr = 'noexists'; + } + + if($shorterr) { + return (undef, 'nothing', $shorterr, $err) + } else { + return ($cmdobj, $cmdname, undef, undef) + } +} + +# ------------------ +# Name: checkCmdSyntax +# Descr: Check the Syntax of Commands and for double Names in different Modules +# Usage: my $ok = $obj->checkCmdSyntax(tlist); +# Test: +sub t_checkCmdSyntax { + return $_[0]->checkCmdSyntax('tlist'); +} +# ------------------ +sub checkCmdSyntax { + my $obj = shift || return error ('No Object!' ); + my $mods = main::getModules(); + + my $shorts = {}; + foreach my $modName (keys %{$mods}) { + my $modCfg = $mods->{$modName}->{MOD}; + foreach my $cmdName (sort keys %{$modCfg->{Commands}}) { + my $short = $modCfg->{Commands}->{$cmdName}->{short} || $cmdName; + if(exists $shorts->{$short} ) { + return error("[ERROR] In %s::%s double short name %s, also in %s!", + $modName, $cmdName, $short, $shorts->{$short}); + } else { + $shorts->{$short} = $modName.'::'.$cmdName; + } + } + } + $obj->{Check} = 1; + 1; +} + +# ------------------ +# Name: getLevel +# Descr: Translate the Levelname to an numeric level +# Usage: my $score = $obj->getLevel(levelname); +# Test: +sub t_getLevel { + return $_[0]->getLevel('user') == 5; +} +# ------------------ +sub getLevel { + my $obj = shift || return error ('No Object!' ); + my $name = shift || return; + + # Level Table + $obj->{LEV} = { + admin => 10, + user => 5, + guest => 1, + } unless(exists $obj->{LEV}); + + if($obj->{LEV}->{$name}) { + return $obj->{LEV}->{$name}; + } else { + return error("This Levelname '$name' does not exist"); + } + +} + +# ------------------ +sub _insert { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return; + + if(ref $data eq 'HASH') { + my ($names, $vals, $kenn); + map { + + if($_ eq 'Password') { + if($data->{Password}) { + push(@$names, $_); + push(@$vals, $data->{$_}); + push(@$kenn, 'MD5(?)'); + } + } else { + push(@$names, $_); + push(@$vals, $data->{$_}); + push(@$kenn, '?'); + } + + } sort keys %$data; + + my $sql; + if($data->{Id}) { + my $temp = []; + my $c = 0; + foreach (@$names) { + push(@$temp, sprintf("%s=%s", $names->[$c], $kenn->[$c])); + $c++; + } + $sql = sprintf("UPDATE USER SET %s WHERE Id = %lu", + join(', ', @$temp), + $data->{Id}, + ); + } else { + $sql = sprintf("REPLACE INTO USER (%s) VALUES (%s)", + join(', ', @$names), + join(', ', @$kenn), + ); + } + my $sth = $obj->{dbh}->prepare( $sql ); + $sth->execute( @$vals ); + } else { + my $sth = $obj->{dbh}->prepare('REPLACE INTO USER VALUES (?,?,?,?)'); + $sth->execute( @$data ); + } +} + +# ------------------ +# Name: userTmp +# Descr: Return a temp directory only for logged user and delete this by exit xxv. +# Usage: my $tmpdir = $obj->userTmp([username]); +# ------------------ +sub userTmp { + my $obj = shift || return error ('No Object!' ); + my $user = ($obj->{active} eq 'y' ? ( shift || ($obj->{USER}->{Name}?$obj->{USER}->{Name}:"nobody") ) : "nobody" ); + + # /var/cache/xxv/temp/xpix/$PID + my $dir = sprintf('%s/%s/%d', $obj->{tempimages} , $user, $$); + + unless(-d $dir) { + mkpath($dir) or error "Can't mkpath $dir : $!"; + } + + # Nach Logout oder beenden von xxv das temp löschen + main::toCleanUp($user, sub{ deleteDir($dir) }, 'logout') + unless(main::toCleanUp($user, undef, 'exists')); # ein CB registrieren + + return $dir; +} + +1; diff --git a/lib/XXV/MODULES/VTX.pm b/lib/XXV/MODULES/VTX.pm new file mode 100644 index 0000000..6062f65 --- /dev/null +++ b/lib/XXV/MODULES/VTX.pm @@ -0,0 +1,1396 @@ +package XXV::MODULES::VTX;
+
+use strict;
+
+use File::Find;
+use FileHandle;
+use Locale::gettext;
+
+################################################################################
+# This module method must exist for XXV
+sub module {
+ my $self = shift || return error ('No Object!' );
+ my $args = {
+ Name => 'VTX',
+ Prereq => {
+ # 'Perl::Module' => 'Description',
+ },
+ Description => gettext('This module display cached teletext pages from osdteletext-plugin.'),
+ Version => '0.93',
+ Date => '2007-03-04',
+ Author => 'Andreas Brachold <vdr04 at deltab.de>',
+ Preferences => {
+ active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + }, + dir => {
+ description => gettext('Directory where the teletext files are be located'),
+ default => '/vtx',
+ type => 'dir',
+ required => gettext('This is required!'),
+ },
+ cache => {
+ description => gettext("Used cache system.\nChoose 'legacy' for the traditional one-file-per-page system.\nDefault is 'packed' for the one-file-for-a-few-pages system.\nVDR-osdteletext-Plugin\n'legacy' <= osdteletext-0.3.2 or 'packed' >= osdteletext-0.4.0"),
+ default => 'packed',
+ type => 'radio',
+ required => gettext('This is required!'),
+ choices => ['legacy','packed']
+ },
+ },
+ Commands => {
+ vtxpage => {
+ description => gettext("Display the teletext page 'pagenumber'"),
+ short => 'vt',
+ callback => sub{ $self->page(@_) },
+ },
+ vtxchannel => {
+ description => gettext("Channel for teletext actions 'cid'"),
+ short => 'vc',
+ callback => sub{ $self->channel(@_) },
+ },
+ vtxsearch => {
+ description => gettext("Search for text inside teletext pages 'text'"),
+ short => 'vs',
+ callback => sub{ $self->search(@_) },
+ },
+ },
+ };
+ return $args;
+}
+
+################################################################################
+# Ctor
+sub new {
+ my($class, %attr) = @_;
+ my $self = {};
+ bless($self, $class);
+
+ # paths
+ $self->{paths} = delete $attr{'-paths'};
+
+ # who am I
+ $self->{MOD} = $self->module;
+
+ # all configvalues to $self without parents (important for ConfigModule)
+ map {
+ $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}};
+
+ # Try to use the Requirments
+ map {
+ eval "use $_";
+ return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@);
+ } keys %{$self->{MOD}->{Prereq}};
+
+ return $self;
+}
+
+
+################################################################################
+# Find first usable channel
+sub findfirst {
+
+ my $self = shift || return error ('No Object!');
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+
+ my $basedir = $self->{dir}
+ || return $self->pagedump($console,gettext("directory is for modul vtx not registered!"),"");
+
+ my $mod = main::getModule ('CHANNELS');
+ my $channels =[];
+
+ my $cache = $self->{cache} ||'packed';
+ if ($cache ne 'packed') {
+ foreach my $ch (@{$mod->ChannelArray ('Name')}) {
+ if (-d $basedir.'/'.$ch->[1]) {
+ return $self->channel ($watcher, $console,$ch->[1]);
+ }
+ }
+ } else {
+ foreach my $ch (@{$mod->ChannelArray ('Id')}) {
+ if (-d $basedir.'/'.$ch->[0]) {
+ return $self->channel ($watcher,$console,$ch->[1]);
+ }
+ }
+ }
+}
+
+################################################################################
+# Callback "Channel choice"
+sub channel
+{
+ my $self = shift || return error ('No Object!');
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $channel = shift || return $self->findfirst ($watcher, $console);
+
+ my $basedir = $self->{dir} || return error ('No Base Directory defined !');
+ my $cache = $self->{cache} || 'packed';
+
+ my $mod = main::getModule ('CHANNELS');
+
+ my $chandir = "";
+ my $channelname = "";
+
+ # Get ChannelID and channel's Name
+ foreach my $ch (@{$mod->ChannelArray ('Name, Id')}) {
+ if ($ch->[2] == $channel) {
+ $channelname = $ch->[0];
+ if ($cache eq 'packed') {
+ $chandir = $ch->[1];
+ } else {
+ $chandir = $channel;
+ }
+ last;
+ }
+ }
+
+
+ if ($channelname ne ""
+ and $chandir ne ""
+ and -d "$basedir/$chandir") {
+
+ $self->{CHANNEL}= $channel;
+ $self->{CHANNELDIR}= $chandir;
+ {
+ $self->{INDEX} = [];
+ my @index;
+ if ($cache eq 'packed') {
+ find(
+ sub{
+ if($File::Find::name =~ /\d{3}s.vtx$/sig) {
+ push(@index,GetPackedToc($File::Find::name));
+ }
+ },"$basedir/$chandir");
+ } else {
+ find(
+ sub{
+ if($File::Find::name =~ /\d{3}_\d{2}.vtx$/sig) {
+ my ($page, $subpage)
+ = $File::Find::name =~ /^.*(\d{3})_(\d{2}).*/si;
+ if($page and $subpage) {
+ my $found = 0;
+ foreach my $p (@index) {
+ if($p->[0] == $page) {
+ $found = 1;
+ push(@{$p->[1]},$subpage)
+ if($subpage != 0);
+ last;
+ }
+ }
+ if ($found == 0) {
+ push(@index,[$page, [$subpage] ]);
+ }
+ }
+ }
+ },"$basedir/$chandir");
+ }
+ if (scalar @index == 0) {
+ $self->pagedump($console,sprintf(gettext("No data found for \'%s\'!"),$channelname),"");
+ return;
+ }
+ # Seitenindex sortieren
+ @{$self->{INDEX}} = sort { $a->[0] <=> $b->[0] } @index;
+ # Subseitenindex sortieren
+ foreach my $p (@{$self->{INDEX}}) {
+ if (scalar @{$p->[1]} > 1) {
+ my @tmp = sort { $a <=> $b } @{$p->[1]};
+ @{$p->[1]} = @tmp;
+ }
+ }
+ }
+
+# Dump PageIndex
+# foreach my $p (@{$self->{INDEX}}) {
+# my $dump = "Pages $p->[0]";
+# foreach my $s (@{$p->[1]}) {
+# $dump .= ", $s";
+# }
+# warn($dump);
+# }
+
+ $console->message(sprintf(gettext("channel \'%s\' for modul vtx registered."),$channelname))
+ if ($console->{TYP} ne 'HTML') ;
+ } else {
+ $self->pagedump($console,sprintf(gettext("No data found for \'%s\'!"),$channelname),"");
+ return;
+ }
+ my $fpage = @{$self->{INDEX}}[0];# First Page on Index
+ return $self->page ($watcher, $console,sprintf ("%03d_%02d", $fpage->[0],$fpage->[1]->[0]));
+}
+
+################################################################################
+# Callback "Teletextpage choice"
+sub page { + my $self = shift || return error ('No Object!');
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $page = shift || "";
+ my $channel = $self->{CHANNEL} || return $self->findfirst ($watcher, $console);
+ my $basedir = $self->{dir} || return error ('No Base Directory defined !');
+ my $chandir = $self->{CHANNELDIR} || return error ('No CHANNEL');
+ my $cache = $self->{cache} || 'packed';
+
+ my @pp = split ('_', $page);
+ if (scalar @pp == 0) {
+ # First Page on Index
+ my $fpage = @{$self->{INDEX}}[0];
+ $pp[0] = sprintf("%3d",$fpage->[0]);
+ $pp[1] = sprintf("%2d",$fpage->[1]->[0]);
+ }
+ elsif (scalar @pp == 1) {
+ # First Subpage on Index
+ $pp[1] = "00";
+ foreach my $fpage (@{$self->{INDEX}}) {
+ if($fpage->[0] == $pp[0]) {
+ $pp[1] = sprintf("%2d",$fpage->[1]->[0]);
+ last;
+ }
+ }
+ }
+ my $bHTML = ($console->{TYP} ne 'HTML')?0:1;
+ my $result = $self->realpage($console, $pp[0], $pp[1],$bHTML);
+
+ return 0 if($result eq "");
+ return $self->pagedump($console,$result,$chandir);
+}
+
+################################################################################
+# Generate Message
+sub pagedump {
+ my $self = shift || return error ('No Object!');
+ my $console = shift || return error ('No Console');
+ my $result = shift;
+ my $chandir = shift;
+
+ if ($console->{TYP} ne 'HTML') {
+ return $console->message ($result);
+ } else {
+
+ my $charray =[];
+ my $chsel = $self->{CHANNELDIR};
+ my $cache = $self->{cache};
+ my $basedir = $self->{dir};
+ my $mod = main::getModule ('CHANNELS');
+
+ my @chan = (@{$mod->ChannelArray ('Name, Id')});
+ if ($cache ne 'packed') {
+ foreach my $ch (@chan) {
+ push (@$charray, [$ch->[0], $ch->[2]])
+ if (-d $basedir.'/'.$ch->[2]) ; # Lookup /vtx/25/
+ }
+ } else {
+ foreach my $ch (@chan){
+ if (-d $basedir.'/'.$ch->[1]) { # Lookup /vtx/S19.2E-1-1101-28108/
+ push (@$charray, [$ch->[0], $ch->[2]]);
+ $chsel = $ch->[2]
+ if ($ch->[1] eq $chandir) ;
+ }
+ }
+ }
+
+ my @lines = $self->InsertPageLink($result); + $self->NavigatePages();
+ my $tmpldata =
+ {
+ channel => $chsel,
+ channels => $charray,
+ page => $self->{mainpage},
+ subpage => $self->{subpage},
+ toppage => $self->{toppage}, + page_prev => $self->{page_prev},
+ page_next => $self->{page_next},
+ subpage_prev => $self->{subpage_prev},
+ subpage_next => $self->{subpage_next}
+ }; + + $console->{dontparsedData} = 1;
+ return $console->vtx(\@lines, $tmpldata);
+ }
+ return 1;
+}
+
+################################################################################
+# Insert for HTML Pages, Link for other Pages
+sub InsertPageLink {
+
+ my $self = shift;
+ my $result = shift; + my @lines; + + # Replace XXX => <a href="?cmd=vt&data=XXX">XXX</a> + my $ua = "<a class='vtx' href='?cmd=vt&data="; + my $ub = "'>"; + my $uc = "</a>"; + + foreach my $line (split('\n',$result)) { + my ($page1,$page2) = $line =~ /\D+([1-8]\d{2})\D+([1-8]\d{2})\D+/s; + if($page1 and $page2) { + foreach my $p (@{$self->{INDEX}}) { + if($p->[0] == $page1) { + $line =~ s/$page1/$ua.$page1.$ub.$page1.$uc/eg; + } elsif($p->[0] == $page2) { + $line =~ s/$page2/$ua.$page2.$ub.$page2.$uc/eg; + last; + } + } + } else { + my ($page1) = $line =~ /\D+([1-8]\d{2})\D+/s; + if($page1) { + foreach my $p (@{$self->{INDEX}}) { + if($p->[0] == $page1) { + $line =~ s/$page1/$ua.$page1.$ub.$page1.$uc/eg; + last; + } + } + } + } + + # Make anchor for external URLs + $line =~ s/((www)\.[a-z0-9\.\/\-]+)/<a target=\"blank\" class=\"vtx\" href=\"http:\/\/$1\">$1<\/a>/gi; + push (@lines, $line); + } + return @lines; +}
+ +################################################################################
+# Find next and prior Pages, used one HTML View
+sub NavigatePages {
+ my $self = shift;
+
+ my $mFound = 0;
+ my $sFound = 0; + $self->{toppage} = 0;
+ $self->{page_prev} = 0;
+ $self->{page_next} = 0;
+ $self->{subpage_prev} = 0;
+ $self->{subpage_next} = 0;
+ + $self->{toppage} = $self->{INDEX}->[0][0] if ($self->{INDEX} && scalar ($self->{INDEX}));
+
+# Outer Mainpages-Loop##########################################################
+ foreach my $p (@{$self->{INDEX}}) {
+ if($mFound == 1) {
+ $self->{page_next} = $p->[0];
+ last;
+ }
+ if($p->[0] && $p->[0] == $self->{mainpage}) {
+ $mFound = 1;
+ if ($p->[1] && scalar @{$p->[1]} > 1) {
+# Inner Subpages-Loop###########################################################
+ foreach my $s (@{$p->[1]}) {
+ if($sFound == 1) {
+ $self->{subpage_next} = sprintf ("%03d_%02d", $self->{mainpage},$s);
+ last;
+ }
+ if($s == $self->{subpage}) {
+ $sFound = 1;
+ }
+ if($sFound == 0) {
+ $self->{subpage_prev} = sprintf ("%03d_%02d", $self->{mainpage},$s);
+ }
+ }
+ if($sFound == 0) {
+ $self->{subpage_prev} = 0;
+ }
+# Inner Subpages-Loop###########################################################
+ }
+ }
+ if($mFound == 0) {
+ $self->{page_prev} = $p->[0];
+ }
+ }
+ if($mFound == 0) {
+ $self->{page_prev} = 0;
+ }
+# Outer Mainpages-Loop##########################################################
+}
+
+################################################################################
+# Our internal real page deliverer
+sub realpage {
+ my $self = shift || return error ('No Object!');
+ my $console = shift || return error ('No Console!');
+ my $mainpage= shift || return error ('No Page!');
+ my $subpage = shift || return error ('No Subpage!');
+ my $bHTML = shift;
+
+ my $basedir = $self->{dir} || return error ('No directory is defined!');
+ my $chandir = $self->{CHANNELDIR} || return error ('No CHANNEL');
+ my $cache = $self->{cache} || 'packed';
+################################################################################
+# get filename
+ my $filename;
+ if ($cache eq 'packed') {
+ # Build name /vtx/S19.2E-1-1101-28108/100s.vtx
+ my $group = (int ($mainpage / 10)) *10;
+ $filename = sprintf ("%s/%s/%03ds.vtx", $basedir, $chandir, $group);
+ } else {
+ # Build name /vtx/15/100_01.vtx
+ $filename = sprintf ("%s/%s/%03d_%02d.vtx", $basedir, $chandir, $mainpage, $subpage);
+ }
+################################################################################
+# Now open and read this file
+ my $fh = FileHandle->new;
+ if(!$fh->open($filename)) {
+ $self->pagedump($console,gettext("The page could not be found!"),"");
+ return "";
+ }
+
+ my $result = $self->readpage($console, $fh, $mainpage, $subpage, $bHTML);
+ $fh->close();
+ return $result;
+}
+
+################################################################################
+# Translation table for ASCII
+# Source - Bytelayout - vdr-plugin osdteletext-0.4.1/txtfont.c
+# Codingrule iso-8859-15
+my @tableascii = (
+ ' ', # 0x20
+ '!', # 0x21
+ '"', # 0x22
+ '#', # 0x23
+ '$', # 0x24
+ '%', # 0x25
+ '&', # 0x26
+ '\'', # 0x27
+ '(', # 0x28
+ ')', # 0x29
+ '*', # 0x2A
+ '+', # 0x2B
+ ',', # 0x2C
+ '-', # 0x2D
+ '.', # 0x2E
+ '/', # 0x2E
+ '0', # 0x30
+ '1', # 0x31
+ '2', # 0x32
+ '3', # 0x33
+ '4', # 0x34
+ '5', # 0x35
+ '6', # 0x36
+ '7', # 0x37
+ '8', # 0x38
+ '9', # 0x39
+ ':', # 0x3A
+ ';', # 0x3B
+ '<', # 0x3C
+ '=', # 0x3D
+ '>', # 0x3E
+ '?', # 0x3F
+ '§', # 0x40
+ 'A', # 0x41
+ 'B', # 0x42
+ 'C', # 0x43
+ 'D', # 0x44
+ 'E', # 0x45
+ 'F', # 0x46
+ 'G', # 0x47
+ 'H', # 0x48
+ 'I', # 0x49
+ 'J', # 0x4A
+ 'K', # 0x4B
+ 'L', # 0x4C
+ 'M', # 0x4D
+ 'N', # 0x4E
+ 'O', # 0x4F
+ 'P', # 0x50
+ 'Q', # 0x51
+ 'R', # 0x52
+ 'S', # 0x53
+ 'T', # 0x54
+ 'U', # 0x55
+ 'V', # 0x56
+ 'W', # 0x57
+ 'X', # 0x58
+ 'Y', # 0x59
+ 'Z', # 0x5A
+ 'Ä', # 0x5B
+ 'Ö', # 0x5C
+ 'Ü', # 0x5D
+ '^', # 0x5E
+ '_', # 0x5F
+ '°', # 0x60
+ 'a', # 0x61
+ 'b', # 0x62
+ 'c', # 0x63
+ 'd', # 0x64
+ 'e', # 0x65
+ 'f', # 0x66
+ 'g', # 0x67
+ 'h', # 0x68
+ 'i', # 0x69
+ 'j', # 0x6A
+ 'k', # 0x6B
+ 'l', # 0x6C
+ 'm', # 0x6D
+ 'n', # 0x6E
+ 'o', # 0x6F
+ 'p', # 0x70
+ 'q', # 0x71
+ 'r', # 0x72
+ 's', # 0x73
+ 't', # 0x74
+ 'u', # 0x75
+ 'v', # 0x76
+ 'w', # 0x77
+ 'x', # 0x78
+ 'y', # 0x79
+ 'z', # 0x7A
+ 'ä', # 0x7B
+ 'ö', # 0x7C
+ 'ü', # 0x7D
+ 'ß', #/0x7E + ' ', # Block 0x7F
+ '@', # 0x80
+ ' ', # 0x81
+ ' ', # 0x82
+ '£', # 0x83
+ '$', # 0x84
+ ' ', # 0x85
+ ' ', # 0x86
+ ' ', # 0x87
+ ' ', # 0x88
+ ' ', # 0x89
+ ' ', # 0x8A
+ ' ', # 0x8B
+ ' ', # 0x8C
+ ' ', # 0x8D
+ ' ', # 0x8E
+ '#', # 0x8F
+ 'É', # 0x90
+ 'é', # 0x91
+ 'ä', # 0x92
+ '#', # 0x93
+ ' ', # 0x94
+ ' ', # 0x95
+ ' ', # 0x96
+ ' ', # 0x97
+ 'ö', # 0x98
+ 'å', # 0x99
+ 'ü', # 0x9A
+ 'Ä', # 0x9B
+ 'Ö', # 0x9C
+ 'Å', # 0x9D
+ 'Ü', # 0x9E
+ '_', # 0x9F
+ ' ', # 0x20a 0xA0
+ ' ', # 0x21a 0xA1
+ ' ', # 0x22a 0xA2
+ ' ', # 0x23a 0xA3
+ ' ', # 0x24a 0xA4
+ ' ', # 0x25a 0xA5
+ ' ', # 0x26a 0xA6
+ ' ', # 0x27a 0xA7
+ ' ', # 0x28a 0xA8
+ ' ', # 0x29a 0xA9
+ ' ', # 0x2Aa 0xAA
+ ' ', # 0x2Ba 0xAB
+ ' ', # 0x2Ca 0xAC
+ ' ', # 0x2Da 0xAD
+ ' ', # 0x2Ea 0xAE
+ ' ', # 0x2Fa 0xAF
+ ' ', # 0x30a 0xB0
+ ' ', # 0x31a 0xB1
+ ' ', # 0x32a 0xB2
+ ' ', # 0x33a 0xB3
+ ' ', # 0x34a 0xB4
+ ' ', # 0x35a 0xB5
+ ' ', # 0x36a 0xB6
+ ' ', # 0x37a 0xB7
+ ' ', # 0x38a 0xB8
+ ' ', # 0x39a 0xB9
+ ' ', # 0x3Aa 0xBA
+ ' ', # 0x3Ba 0xBB
+ ' ', # 0x3Ca 0xBC
+ ' ', # 0x3Da 0xBD
+ ' ', # 0x3Ea 0xBE
+ ' ', # 0x3Fa 0xBF
+ 'é', # 0xC0
+ 'ù', # 0xC1
+ 'à', # 0xC2
+ '£', # 0xC3
+ '$', # 0xC4
+ 'ã', # 0xC5
+ 'õ', # 0xC6
+ ' ', # 0xC7
+ 'ò', # 0xC8
+ 'è', # 0xC9
+ 'ì', # 0xCA
+ '°', # 0xCB
+ 'ç', # 0xCC
+ ' ', # 0xCD
+ ' ', # 0xCE
+ '#', # 0xCF
+ 'à', # 0xD0
+ 'è', # 0xD1
+ 'â', # 0xD2
+ 'é', # 0xD3
+ 'ï', # 0xD4
+ 'Ã', # 0xD5
+ 'Õ', # 0xD6
+ 'Ç', # 0xD7
+ 'ô', # 0xD8
+ 'û', # 0xD9
+ 'ç', # 0xDA
+ 'ë', # 0xDB
+ 'ê', # 0xDC
+ 'ù', # 0xDD
+ 'î', # 0xDE
+ '#', # 0xDF
+ '¡', # 0xE0
+ '¿', # 0xE1
+ 'ü', # 0xE2
+ 'ç', # 0xE3
+ '$', # 0xE4
+ ' ', # 0xE5
+ ' ', # 0xE6
+ ' ', # 0xE7
+ 'ñ', # 0xE8
+ 'è', # 0xE9
+ 'à', # 0xEA
+ 'á', # 0xEB
+ 'é', # 0xEC
+ 'í', # 0xED
+ 'ó', # 0xEE
+ 'ú', # 0xEF
+ 'Á', # 0xF0
+ 'À', # 0xF1
+ 'È', # 0xF2
+ 'Í', # 0xF3
+ 'Ï', # 0xF4
+ 'Ó', # 0xF5
+ 'Ò', # 0xF6
+ 'Ú', # 0xF7
+ 'æ', # 0xF8
+ 'Æ', # 0xF9
+ 'ð', # 0xFA
+ ' ', # 0xFB
+ 'ø', # 0xFC
+ 'Ø', # 0xFD
+ ' ', # 0xFE
+ ' ', # 0xFF
+ ' ', # 0x60a
+ ' ', # 0x61a
+ ' ', # 0x62a
+ ' ', # 0x63a
+ ' ', # 0x64a
+ ' ', # 0x65a
+ ' ', # 0x66a
+ ' ', # 0x67a
+ ' ', # 0x68a
+ ' ', # 0x69a
+ ' ', # 0x6Aa
+ ' ', # 0x6Ba
+ ' ', # 0x6Ca
+ ' ', # 0x6Da
+ ' ', # 0x6Ea
+ ' ', # 0x6Fa
+ ' ', # 0x70a
+ ' ', # 0x71a
+ ' ', # 0x72a
+ ' ', # 0x73a
+ ' ', # 0x74a
+ ' ', # 0x75a
+ ' ', # 0x76a
+ ' ', # 0x77a
+ ' ', # 0x78a
+ ' ', # 0x79a
+ ' ', # 0x7Aa
+ ' ', # 0x7Ba
+ ' ', # 0x7Ca
+ ' ', # 0x7Da
+ ' ', # 0x7Ea
+ ' ' # 0x7Fa
+);
+
+################################################################################
+# Translation table for HTML
+my @tablehtml = (
+ ' ', # 0x20
+ '!', # 0x21
+ '"', # 0x22
+ '#', # 0x23
+ '$', # 0x24
+ '%', # 0x25
+ '&', # 0x26
+ '\'', # 0x27
+ '(', # 0x28
+ ')', # 0x29
+ '*', # 0x2A
+ '+', # 0x2B
+ ',', # 0x2C
+ '-', # 0x2D
+ '.', # 0x2E
+ '/', # 0x2E
+ '0', # 0x30
+ '1', # 0x31
+ '2', # 0x32
+ '3', # 0x33
+ '4', # 0x34
+ '5', # 0x35
+ '6', # 0x36
+ '7', # 0x37
+ '8', # 0x38
+ '9', # 0x39
+ ':', # 0x3A
+ ';', # 0x3B
+ '<', # 0x3C
+ '=', # 0x3D
+ '>', # 0x3E
+ '?', # 0x3F
+ '§', # 0x40
+ 'A', # 0x41
+ 'B', # 0x42
+ 'C', # 0x43
+ 'D', # 0x44
+ 'E', # 0x45
+ 'F', # 0x46
+ 'G', # 0x47
+ 'H', # 0x48
+ 'I', # 0x49
+ 'J', # 0x4A
+ 'K', # 0x4B
+ 'L', # 0x4C
+ 'M', # 0x4D
+ 'N', # 0x4E
+ 'O', # 0x4F
+ 'P', # 0x50
+ 'Q', # 0x51
+ 'R', # 0x52
+ 'S', # 0x53
+ 'T', # 0x54
+ 'U', # 0x55
+ 'V', # 0x56
+ 'W', # 0x57
+ 'X', # 0x58
+ 'Y', # 0x59
+ 'Z', # 0x5A
+ 'Ä', # 0x5B
+ 'Ö', # 0x5C
+ 'Ü', # 0x5D
+ '^', # 0x5E
+ '_', # 0x5F
+ '°', # 0x60
+ 'a', # 0x61
+ 'b', # 0x62
+ 'c', # 0x63
+ 'd', # 0x64
+ 'e', # 0x65
+ 'f', # 0x66
+ 'g', # 0x67
+ 'h', # 0x68
+ 'i', # 0x69
+ 'j', # 0x6A
+ 'k', # 0x6B
+ 'l', # 0x6C
+ 'm', # 0x6D
+ 'n', # 0x6E
+ 'o', # 0x6F
+ 'p', # 0x70
+ 'q', # 0x71
+ 'r', # 0x72
+ 's', # 0x73
+ 't', # 0x74
+ 'u', # 0x75
+ 'v', # 0x76
+ 'w', # 0x77
+ 'x', # 0x78
+ 'y', # 0x79
+ 'z', # 0x7A
+ 'ä', # 0x7B
+ 'ö', # 0x7C
+ 'ü', # 0x7D
+ 'ß', # 0x7E
+ 'image-7F', # Block 0x7F
+ '@', # 0x80
+ '–', # 0x81
+ '¼', # 0x82 1/4
+ '£', # 0x83
+ '$', # 0x84
+ ' ', # 0x85 Taste Teletext (a)
+ ' ', # 0x86 Taste Small
+ ' ', # 0x87 Taste Hide
+ ' ', # 0x88 ||
+ '¾', # 0x89 3/4
+ '÷', # 0x8A
+ '←', # 0x8B <-
+ '½', # 0x8C 1/2
+ '→', # 0x8D ->
+ '↑', # 0x8E
+ '#', # 0x8F
+ 'É', # 0x90
+ 'é', # 0x91
+ 'ä', # 0x92
+ '#', # 0x93
+ '¤', # 0x94
+ ' ', # 0x95 Taste Teletext (b)
+ ' ', # 0x96 Taste
+ ' ', # 0x97 Taste Big
+ 'ö', # 0x98
+ 'å', # 0x99
+ 'ü', # 0x9A
+ 'Ä', # 0x9B
+ 'Ö', # 0x9C
+ 'Å', # 0x9D
+ 'Ü', # 0x9E
+ '_', # 0x9F
+ 'image-20', # 0x20a 0xA0 # image-20 == whitespace
+ 'image-21', # 0x21a 0xA1
+ 'image-22', # 0x22a 0xA2
+ 'image-23', # 0x23a 0xA3
+ 'image-24', # 0x24a 0xA4
+ 'image-25', # 0x25a 0xA5
+ 'image-26', # 0x26a 0xA6
+ 'image-27', # 0x27a 0xA7
+ 'image-28', # 0x28a 0xA8
+ 'image-29', # 0x29a 0xA9
+ 'image-2A', # 0x2Aa 0xAA
+ 'image-2B', # 0x2Ba 0xAB
+ 'image-2C', # 0x2Ca 0xAC
+ 'image-2D', # 0x2Da 0xAD
+ 'image-2E', # 0x2Ea 0xAE
+ 'image-2F', # 0x2Fa 0xAF
+ 'image-30', # 0x30a 0xB0
+ 'image-31', # 0x31a 0xB1
+ 'image-32', # 0x32a 0xB2
+ 'image-33', # 0x33a 0xB3
+ 'image-34', # 0x34a 0xB4
+ 'image-35', # 0x35a 0xB5
+ 'image-36', # 0x36a 0xB6
+ 'image-37', # 0x37a 0xB7
+ 'image-38', # 0x38a 0xB8
+ 'image-39', # 0x39a 0xB9
+ 'image-3A', # 0x3Aa 0xBA
+ 'image-3B', # 0x3Ba 0xBB
+ 'image-3C', # 0x3Ca 0xBC
+ 'image-3D', # 0x3Da 0xBD
+ 'image-3E', # 0x3Ea 0xBE
+ 'image-3F', # 0x3Fa 0xBF
+ 'é', # 0xC0
+ 'ù', # 0xC1
+ 'à', # 0xC2
+ '£', # 0xC3
+ '$', # 0xC4
+ 'ã', # 0xC5
+ 'õ', # 0xC6
+ '•', # 0xC7
+ 'ò', # 0xC8
+ 'è', # 0xC9
+ 'ì', # 0xCA
+ '°', # 0xCB
+ 'ç', # 0xCC
+ '→', # 0xCD
+ '↑', # 0xCE
+ '#', # 0xCF
+ 'à', # 0xD0
+ 'è', # 0xD1
+ 'â', # 0xD2
+ 'é', # 0xD3
+ 'ï', # 0xD4
+ 'Ã', # 0xD5
+ 'Õ', # 0xD6
+ 'Ç', # 0xD7
+ 'ô', # 0xD8
+ 'û', # 0xD9
+ 'ç', # 0xDA
+ 'ë', # 0xDB
+ 'ê', # 0xDC
+ 'ù', # 0xDD
+ 'î', # 0xDE
+ '#', # 0xDF
+ '¡', # 0xE0
+ '¿', # 0xE1
+ 'ü', # 0xE2
+ 'ç', # 0xE3
+ '$', # 0xE4
+ ' ', # 0xE5 a mit unterstrich
+ ' ', # 0xE6 o mit unterstrich
+ 'Ñ', # 0xE7
+ 'ñ', # 0xE8
+ 'è', # 0xE9
+ 'à', # 0xEA
+ 'á', # 0xEB
+ 'é', # 0xEC
+ 'í', # 0xED
+ 'ó', # 0xEE
+ 'ú', # 0xEF
+ 'Á', # 0xF0
+ 'À', # 0xF1
+ 'È', # 0xF2
+ 'Í', # 0xF3
+ 'Ï', # 0xF4
+ 'Ó', # 0xF5
+ 'Ò', # 0xF6
+ 'Ú', # 0xF7
+ 'æ', # 0xF8
+ 'Æ', # 0xF9
+ 'ð', # 0xFA
+ 'Ð', # 0xFB
+ 'ø', # 0xFC
+ 'Ø', # 0xFD
+ 'þ', # 0xFE
+ 'Þ', # 0xFF
+ 'image-60', # 0x60a
+ 'image-61', # 0x61a
+ 'image-62', # 0x62a
+ 'image-63', # 0x63a
+ 'image-64', # 0x64a
+ 'image-65', # 0x65a
+ 'image-66', # 0x66a
+ 'image-67', # 0x67a
+ 'image-68', # 0x68a
+ 'image-69', # 0x69a
+ 'image-6A', # 0x6Aa
+ 'image-6B', # 0x6Ba
+ 'image-6C', # 0x6Ca
+ 'image-6D', # 0x6Da
+ 'image-6E', # 0x6Ea
+ 'image-6F', # 0x6Fa
+ 'image-70', # 0x70a
+ 'image-71', # 0x71a
+ 'image-72', # 0x72a
+ 'image-73', # 0x73a
+ 'image-74', # 0x74a
+ 'image-75', # 0x75a
+ 'image-76', # 0x76a
+ 'image-77', # 0x77a
+ 'image-78', # 0x78a
+ 'image-79', # 0x79a
+ 'image-7A', # 0x7Aa
+ 'image-7B', # 0x7Ba
+ 'image-7C', # 0x7Ca
+ 'image-7D', # 0x7Da
+ 'image-7E', # 0x7Ea
+ 'image-7F' # 0x7Fa
+);
+
+################################################################################
+# Color table
+my @colors = (
+ "black", "red", "green", "yellow",
+ "blue", "magenta", "cyan", "white"
+);
+
+################################################################################
+# Translation unpacked bytes to text
+sub translate {
+
+ my $self=shift;
+ my $bHTML=shift;
+ my $c=shift;
+ my $graph=shift;
+ my $double=shift;
+ my $sepgraph=shift;
+ my $fg=shift;
+ my $bg=shift;
+ $c = int($c);
+ if ($graph == 1) {
+ if (($c>=0x20) and ($c<=0x3F)) { $c += 0x80; }
+ elsif (($c>=0x60) and ($c<=0x7F)) { $c += 0xA0; }
+ }
+ $c -= 0x20;
+ if($bHTML == 1) {
+ my $result;
+
+ if ($fg != $self->{ofg} or $bg != $self->{obg}) {
+ if ($self->{ofg} != -1 or $self->{obg} != -1) {
+ $result .= "</font>";
+ }
+ $result .= sprintf("<font style=\"color:%s;background-color:%s;\">",$colors[$fg],$colors[$bg]);
+
+ $self->{ofg} = $fg;
+ $self->{obg} = $bg;
+ }
+ if($c < 0 or $c > 256) {
+ $result .= ' ';
+ } else {
+ my $h .= $tablehtml[$c]; + $h =~ s/ /" "/eg; + $result .= $h;
+ if ($graph == 1 || $c == 0x5f) #Block 0x5f = 0x7f - 0x20 + { + my $pre = "<img class=\"vtx\" src=\"vtximages/"; + my $color = $colors[$fg]; + my $post = ".gif\" alt=\"\" title=\"\" /> "; + # set <img class="vtx" class="vtx" src="vtximages/black21.gif" alt="" title=""> + # vtx-image are locate inside skin folder + $result =~ s/(image)\-(.+)/$pre.$color.$2.$post/eg;
+ } + }
+ return $result;
+ } else {
+ return ' ' if($c < 0 or $c > 256);
+ return $tableascii[$c];
+ }
+}
+################################################################################
+# close text line
+sub endline {
+ my $self=shift;
+ my $bHTML=shift;
+ my $result = "";
+ $result .= "</font><br />" if($bHTML);
+ $result .= "\n";
+ return $result;
+}
+
+################################################################################
+# Read page which open from filehandle
+sub readpage {
+ my $self=shift;
+ my $console=shift;
+ my $fh=shift;
+ my $mainpage=shift;
+ my $subpage=shift;
+ my $bHTML = shift;
+ my $cache = $self->{cache} || 'packed';
+
+# Seek inside packed file
+ if ($cache eq 'packed') {
+ # Parse TOC
+ #
+ # 8x[MAIN,SUB a 2x4byte],
+ # 8x[PAGE a 972byte],
+ # 8x[MAIN,SUB a 2x4byte],
+ # 8x[PAGE a 972byte]
+ #
+ my $tocbuf;
+ my $notfound = 1;
+ while($notfound == 1) {
+ if($fh->read($tocbuf, 4*2*8) ne 64) {
+ $self->pagedump($console,gettext("The page could not readed!"),"");
+ return "";
+ }
+ my @toc = unpack( "i*", $tocbuf);
+ my $n = 0;
+ for (;$n < 8 and $notfound == 1; ++$n ) {
+ my $mpage = int(sprintf ("%X",@toc[$n*2]));
+ my $spage = int(sprintf ("%X",@toc[($n*2)+1]));
+ # Check for last toc entry 0/0
+ if($mpage == 0 and $spage == 0) {
+ $self->pagedump($console,gettext("The page could not be found!"),"");
+ return "";
+ }
+ # Look for toc entry same wanted page
+ if($mpage == $mainpage) {
+ if(($spage == $subpage )
+ or ($subpage <= 1 and $spage <= 1)) {
+
+ $self->{mainpage} = $mpage;
+ $self->{subpage} = $spage;
+
+ $notfound = 0;
+ }
+ }
+ }
+ --$n if($notfound == 0);
+ # Skip unwanted Pages + if(0 == $fh->seek((972*$n), 1)) {
+ $self->pagedump($console,gettext("The page could not readed!"),"");
+ return "";
+ }
+ }
+ } else {
+ $self->{mainpage} = $mainpage;
+ $self->{subpage} = $subpage;
+ }
+
+# Read page now
+ my $packed;
+ if($fh->read($packed, 972) ne 972) {
+ $self->pagedump($console,gettext("The page could not readed!"),"");
+ return "";
+ }
+ my $result = "";
+ $result .= "<p class=\"vtx\">\n" if($bHTML);
+
+ my @buf = unpack( "C*", $packed);
+
+ my $n = 9 + 1 + 2; #Index, skip irgendwas davor, Language, irgendwas wieder
+ my $flash=0;
+ my $double=0;
+ my $hidden=0; #hidden = verdeckt!!!
+ my $sepgraph=0;
+ my $hold=0;
+ my $graph=0;
+ my $skipnextline=0;
+ my $lc=0x20;
+
+ my $fg = 7;
+ my $bg = 0;
+ for (my $y=0;$y<24;$y++) {
+
+ $flash=0;
+ $double=0;
+ $hidden=0; #hidden = verdeckt!!!
+ $sepgraph=0;
+ $hold=0;
+ $graph=0;
+ $skipnextline=0;
+ $lc=0x20;
+
+ $fg = 7;
+ $bg = 0;
+ $self->{ofg} = -1;
+ $self->{obg} = -1;
+
+ for (my $x=0;$x<40;++$x,++$n)
+ { +# $result .= sprintf("<!-- %2x -->",$buf[$n]) +# if($bHTML); +
+ my $c=int($buf[$n] & 0x7F); #Parity Bit ist uninteressant!
+
+ if (($y==0)&&($x<8)) { # Die Daten sind uninteressant zur Anzeige!
+ $c = 0x20;
+ }
+
+ if( $c >= 0x00 and $c <= 0x07 ) { + $lc=0x20 + if($graph); + $hidden= 0;
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+ $graph= 0;
+ $fg = int($c);
+
+ } elsif( $c == 0x08 ) { # Blinken einschalten (flashing)
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+ $flash= 1;
+
+ } elsif( $c == 0x09 ) { # Blinken ausschalten (steady)
+ $flash= 0;
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+ } elsif( $c == 0x0A ) { # end box (nicht benutzt)
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x0B ) { # start box (nicht benutzt)
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x0C ) { # normal high
+ $double= 0; + $lc=0x20;
+ $result .= $self->translate($bHTML, 0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x0D ) { # double high
+# for (my $frei=1;$frei<40;$frei++)
+# $result .= $self->translate($bHTML, $frei,$y+1,0x20,$graph,$double,$sepgraph,$fg,$bg);
+# $result .= $self->endline($bHTML);
+
+ $result .= $self->translate($bHTML, 0x20,$graph,$double,$sepgraph,$fg,$bg);
+ $double= 1;
+# $skipnextline= 1;
+
+ } elsif( $c >= 0x0E and $c <= 0x0F ) { # keine Funktion
+
+ } elsif( $c >= 0x10 and $c <= 0x17 ) { #
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+ $hidden= 0;
+ $graph= 1;
+ $fg = $c-0x10;
+
+ } elsif( $c == 0x18 ) { # verborgen
+ $hidden= 1;
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x19 ) { # contigouous graphics
+ $sepgraph= 0;
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x1A ) { # separated grphics
+ $sepgraph= 1;
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x1B ) { # ESC
+
+ } elsif( $c == 0x1C ) { # black background
+ $bg = (0);
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x1D ) { # new background
+ my $tmp = $fg; # ExchangeColor
+ $fg = $bg;
+ $bg = $tmp;
+
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x1E ) { # hold graphics
+ $hold= 1;
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+
+ } elsif( $c == 0x1F ) { # release graphics
+ $result .= $self->translate($bHTML, ($hold == 1)?$lc:0x20,$graph,$double,$sepgraph,$fg,$bg);
+ $hold= 0;
+
+ } else { #
+ if ($graph == 1) {
+ $lc = $c;
+ }
+ $result .= $self->translate($bHTML, $c,$graph,$double,$sepgraph,$fg,$bg);
+ }
+ }
+ $result .= $self->endline($bHTML);
+ if ($skipnextline==1) {
+ $y++;
+ }
+ }
+ $result .= "</p>\n" if($bHTML);
+ return $result;
+}
+
+################################################################################
+# Read TOC from packed file for index
+sub GetPackedToc {
+
+ my $filename = shift;
+ my @index;
+ my $fh = FileHandle->new;
+ if(!$fh->open($filename)) {
+ error ("The page could not be found! : $filename");
+ } else {
+ # Parse TOC
+ #
+ # 8x[MAIN,SUB a 2x4byte],
+ # 8x[PAGE a 972byte],
+ # 8x[MAIN,SUB a 2x4byte],
+ # 8x[PAGE a 972byte]
+ #
+ my $tocbuf;
+ my $bEnd = 0;
+ while(!$fh->eof() and $bEnd == 0) {
+ if($fh->read($tocbuf, 4*2*8) ne 64) {
+ $bEnd = 1;
+ last;
+ }
+ my @toc = unpack( "i*", $tocbuf);
+ my $n = 0;
+ for (;$n < 8; ++$n ) {
+ my $m = (sprintf ("%X",@toc[$n*2]));
+ + next # Skip nonregular pages like 80F
+ if($m =~ /\D/sig); + + my $mpage = int($m);
+ my $spage = int(sprintf ("%X",@toc[($n*2)+1])); + + # Check for last toc entry 0/0
+ if($mpage == 0 and $spage == 0) {
+ $bEnd = 1;
+ last;
+ }
+ my $found = 0;
+ foreach my $p (@index) {
+ if($p->[0] == $mpage) {
+ $found = 1;
+ push(@{$p->[1]},$spage)
+ if($spage != 0);
+ last;
+ }
+ }
+ if ($found == 0) {
+ push(@index,[$mpage, [$spage] ]);
+ }
+ }
+ # Skip Pages + if(0 == $fh->seek((972*8), 1)) {
+ $bEnd = 1;
+ last;
+ }
+ }
+
+ $fh->close();
+ }
+ return @index;
+}
+ +################################################################################
+# HighLight searched text
+sub HighLight {
+
+ my $self = shift;
+ my $result = shift;
+ my $search = shift;
+ my $lines;
+
+ my $ua = "<font style=\"color:black;background-color:lime;\">";
+ my $ub = "</font>";
+
+ foreach my $line (split('\n',$result)) {
+ $line =~ s/$search/$ua$search$ub/g;
+ $lines .= $line; + }
+ return $lines;
+} + +################################################################################
+# Callback "Teletext search"
+sub search {
+ my $self = shift || return error ('No Object!');
+ my $watcher = shift || return error ('No Watcher!');
+ my $console = shift || return error ('No Console');
+ my $search = shift;
+
+ my $channel = $self->{CHANNEL};
+ my $chandir = $self->{CHANNELDIR};
+ if($channel eq "" or $chandir eq "") {
+ $self->pagedump($console,gettext("No channel defined!"),"");
+ }
+ + chomp($search); + unless($search) { + $self->pagedump($console,gettext("No data to search given!"),$chandir);
+ } + + my $oldpage = $self->{mainpage};
+ my $oldsubpage = $self->{subpage}; + + my @foundlist; + my $searchlimit = 25; + foreach my $p (@{$self->{INDEX}}) {
+ foreach my $s (@{$p->[1]}) { + my $mp = sprintf("%3d",$p->[0]);
+ my $sp = sprintf("%2d",$s);
+ + my $lookup = $self->realpage($console, $mp, $sp, 0); + + my @found = grep(/$search/,$lookup); + if(scalar @found > 0) { + push(@foundlist,[$mp, $sp]); + $searchlimit--; + last if($searchlimit <= 0); + }
+ }
+ last if($searchlimit <= 0);
+ } + + if(scalar @foundlist < 1) { + $self->{mainpage} = $oldpage;
+ $self->{subpage} = $oldsubpage; + $self->pagedump($console,sprintf(gettext("No page with \'%s\' found!"),$search),$chandir);
+ return 0; + } + + my $bHTML = ($console->{TYP} ne 'HTML')?0:1;
+ foreach my $pp (@foundlist) { + + $self->{mainpage} = $pp->[0];
+ $self->{subpage} = $pp->[1]; + + my $result = $self->realpage($console, $pp->[0], $pp->[1],$bHTML); + + if($bHTML) { + $result = $self->HighLight($result,$search); + } + + $self->pagedump($console,$result,$chandir) + if($result ne ""); + } + return 1; +}
+
+1; diff --git a/lib/XXV/MODULES/WAPD.pm b/lib/XXV/MODULES/WAPD.pm new file mode 100644 index 0000000..8114108 --- /dev/null +++ b/lib/XXV/MODULES/WAPD.pm @@ -0,0 +1,354 @@ +package XXV::MODULES::WAPD; + +use Locale::gettext; +use XXV::OUTPUT::Wml; +use File::Basename; +use File::Find; +use Tools; + +use strict; + +my $mime = { + wml => "text/vnd.wap.wml", # WML-Dateien (WAP) + wmlc => "application/vnd.wap.wmlc", # WMLC-Dateien (WAP) + wmls => "text/vnd.wap.wmlscript", # WML-Scriptdateien (WAP) + wmlsc => "application/vnd.wap.wmlscriptc", # WML-Script-C-dateien (WAP) + wbm => "image/vnd.wap.wbmp", # Bitmap-Dateien (WAP) + wbmp => "image/vnd.wap.wbmp" # Bitmap-Dateien (WAP) +}; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'WAPD', + Prereq => { + 'IO::Socket::INET' => 'Object interface for AF_INET domain sockets ', + 'MIME::Base64' => 'Encoding and decoding of base64 strings', + 'CGI qw/:push -nph -no_xhtml -compile/' + => 'Simple Common Gateway Interface Class', + }, + Description => gettext('This module is a multisession WAPD server.'), + Version => '0.45', + Date => '16.09.2005', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + }, + Clients => { + description => gettext('Maximum number from simultaneous connections to the same time'), + default => 5, + type => 'integer', + required => gettext('This is required!'), + }, + Port => { + description => gettext('Number of port to listen for wap clients'), + default => 8085, + type => 'integer', + required => gettext('This is required!'), + }, + Interface => { + description => gettext('Local interface to bind service'), + default => '0.0.0.0', + type => 'host', + required => gettext('This is required!'), + }, + WMLRoot => { + description => gettext('Used Skin'), + default => 'wml', + type => 'list', + required => gettext('This is required!'), + choices => $obj->findskins, + }, +# StartPage => { +# description => gettext('First page, which is to be seen when logon'), +# default => 'now', +# type => 'list', +# required => gettext('This is required!'), +# choices => [ +# [ gettext('Running now'), 'now'], +# [ gettext('Program guide'), 'program'], +# [ gettext('Autotimer'), 'alist'], +# [ gettext('Timers'), 'tlist'], +# [ gettext('Recordings'), 'rlist'], +# [ gettext('Music'), 'mlist'], +# [ gettext('Remote'), 'remote'], +# [ gettext('Teletext'), 'vtxpage'], +# [ gettext('Status'), 'sa'], +# ], +# }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_}; + $self->{$_} = $self->{MOD}->{Preferences}->{$_}->{default} unless($self->{$_}); + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # read the DB Handle + $self->{dbh} = delete $attr{'-dbh'}; + + # The Initprocess + $self->init or return error('Problem to initialize module'); + + return $self; +} + + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + # globals + my $channels; + + # make socket + my $socket = IO::Socket::INET->new( + Listen => $obj->{Clients}, + LocalPort => $obj->{Port}, + LocalAddr => $obj->{Interface}, + Reuse => 1 + ) or return error("Can't create Socket: $!"); + + # install an initial watcher + Event->io( + fd => $socket, + prio => -1, # -1 very hard ... 6 very low + cb => sub { + # accept client + my $client=$socket->accept; + panic "Can't connect wapd to new client." and return unless $client; + $client->autoflush; + + # make "channel" number + my $channel=++$channels; + + # install a communicator + Event->io( + fd => $client, + poll => 'r', + prio => -1, # -1 very hard ... 6 very low + cb => sub { + my $watcher = shift; + + # read new line and report it + my $handle=$watcher->w->fd; + + my $data = $obj->parseRequest($handle,(defined $obj->{LOGOUT} && $obj->{LOGOUT} == 1 )); + unless($data) { + undef $obj->{LOGOUT}; + $watcher->w->cancel; + $handle->close(); + undef $watcher; + return 1; + } + + undef $obj->{LOGOUT} + if(exists $obj->{LOGOUT}); + + my $WMLRootDir = sprintf('%s/%s', $obj->{paths}->{HTMLDIR}, $obj->{WMLRoot}); + my $cgi = CGI->new( $data->{Query} ); + + my $console = XXV::OUTPUT::Wml->new( + -handle => $handle, + -dbh => $obj->{dbh}, + -wmldir => $WMLRootDir, + -cgi => $cgi, + -mime => $mime, + -browser=> $data, + -paths => $obj->{paths}, +# -start => $obj->{StartPage}, + ); + + my $userMod = main::getModule('USER'); + if(ref $userMod and $userMod->{active} eq 'y') { + $console->{USER} = $userMod->check($handle, $data->{username}, $data->{password}); + $console->login(gettext('You have no permissions to this system!')) + unless(exists $console->{USER}->{Level}); + } + + if(ref $userMod and + ($userMod->{active} ne 'y' + or exists $console->{USER}->{Level})) { + + $console->{call} = 'nothing'; + if(($data->{Request} eq '/' or $data->{Request} =~ /\.WML$/) and not $data->{Query}) { + # Send the first page (wapd.tmpl) + my $page = $data->{Request}; + if($page eq '/') { + if(-r sprintf('%s/wapd.tmpl', $WMLRootDir)) { + $console->{call} = 'wapd'; + my $output = $console->parseTemplate('wapd','wapd'); + $console->out( $output ); + } else { + $console->datei(sprintf('%s/index.WML', $WMLRootDir)); + } + } else { + $console->datei(sprintf('%s/%s', $WMLRootDir, $page)); + } + } elsif(my $typ = $mime->{lc((split('\.', $data->{Request}))[-1])}) { + # Send multimedia files (this must registered in $mime!) + $console->image(sprintf('%s%s', $WMLRootDir, $data->{Request}), $typ); + } elsif( $cgi->param('binary') ) { + # Send multimedia files (if param binary) + $obj->handleInput($watcher, $console, $cgi); + } else { + $console->start(); + $obj->handleInput($watcher, $console, $cgi); + $console->footer(); + } + } + $watcher->w->cancel; + undef $watcher; + $handle->close(); + }, + ); + + }, + ) if($obj->{active} eq 'y'); + + return 1; + +} + +# ------------------ +sub parseRequest { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $hdl = shift || return error ('No Handle!' ); + my $logout = shift || 0; + + my ($Req, $size) = getFromSocket($hdl); + + if($Req->[0] =~ /^GET (\/[\w\.\/-\:\%]*)([\?[\w=&\.\+\%-\:\!]*]*)[\#\d ]+HTTP\/1.\d$/) { + my $data = {}; + ($data->{Request}, $data->{Query}) = ($1, $2 ? substr($2, 1, length($2)) : undef); + + # parse header + foreach my $line (@$Req) { + if($line =~ /Referer: (.*)/) { + $data->{Referer} = $1; + } + if($line =~ /Host: (.*)/) { + $data->{HOST} = $1; + } + if($line =~ /Authorization: basic (.*)/i and not $logout) { + ($data->{username}, $data->{password}) = split(":", MIME::Base64::decode_base64($1), 2); + } + if($line =~ /User-Agent: (.*)/i) { + $data->{http_useragent} = $1; + } + } + $data->{Request} =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg; + + return $data; + } else { + error sprintf("Unknown Request: <%s>\n", join("\n", @$Req)); + return; + } + +} + +# ------------------ +sub handleInput { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $watcher = shift || return error ('No Watcher!'); + my $console = shift || return error ('No Console'); + my $cgi = shift || return error ('No CGI Object'); + + my $ucmd = $cgi->param('cmd') || '<undef>'; + my $udata = $cgi->param('data') || ''; + + # Set the referer, if come a form with a error + # then patch the referer + $console->{browser}->{Referer} = $cgi->param('referer') + if($cgi->param('referer')); + + # Test on result set (user has save) and + # get the DataVars in a special Hash + my $result; + foreach my $name ($cgi->param) { + if(my ($n) = $name =~ /^__(.+)/sig) { + my @vals = $cgi->param($name); + if(scalar @vals > 1) { + @{$result->{$n}} = @vals; + } else { + $result->{$n} = shift @vals; + } + } + } + + # Test the command on exists, permissions and so on + my $u = main::getModule('USER'); + my ($cmdobj, $cmdname, $shorterr, $err) = $u->checkCommand($console, $ucmd); + $console->{call} = $cmdname; + if($cmdobj and not $shorterr) { + $cmdobj->{callback}($watcher, $console, $udata, $result ); + } elsif($shorterr eq 'noperm' or $shorterr eq 'noactive') { + return $console->status403($err); + } else { + return $obj->usage($watcher, $console, undef, $err); + } +} + + +# ------------------ +sub usage { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return main::getModule('TELNET')->usage(@_); +} + +# ------------------ +sub findskins +# ------------------ +{ + my $obj = shift || return error ('No Object!' ); + my $found; + find({ wanted => sub{ + if(-d $File::Find::name and -e $File::Find::name.'/wapd.tmpl' ) { + my $l = basename($File::Find::name); + push(@{$found},[$l,$l]); + } + }, + follow => 1, + follow_skip => 2, + }, + $obj->{paths}->{HTMLDIR} + ); + error "Can't find useful WML Skin at : $obj->{paths}->{HTMLDIR}" + if(scalar $found == 0); + return $found; +} + +1; diff --git a/lib/XXV/OUTPUT/Ajax.pm b/lib/XXV/OUTPUT/Ajax.pm new file mode 100644 index 0000000..0151b5f --- /dev/null +++ b/lib/XXV/OUTPUT/Ajax.pm @@ -0,0 +1,231 @@ +package XXV::OUTPUT::Ajax; + +use strict; + +#use Template; +use vars qw($AUTOLOAD); +use Locale::gettext; +use Tools; + +$SIG{CHLD} = 'IGNORE'; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'Ajax', + Prereq => { + 'XML::Simple' => 'Easy API to maintain XML (esp config files)', + 'JSON' => 'Parse and convert to JSON (JavaScript Object Notation)', + }, + Description => gettext('This receive and send Ajax messages.'), + Version => '0.01', + Date => '27.10.2004', + Author => 'xpix', + }; + return $args; +} + +# ------------------ +sub AUTOLOAD { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || {}; + my $params = shift || 0; + + my $name = (split('::', $AUTOLOAD))[-1]; + return if($name eq 'DESTROY'); + + $obj->{nopack} = 1; + $obj->out( $data, $params, $name ); + + $obj->{call} = ''; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # who am I + $self->{MOD} = $self->module; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{handle} = $attr{'-handle'} + || return error('No handle defined!'); + + $self->{cgi} = $attr{'-cgi'} + || return error('No TemplateDir given!'); + + $self->{browser} = $attr{'-browser'} + || return error('No Mimehash given!'); + + $self->{xml} = XML::Simple->new() + || return error('XML failed!'); + + $self->{outtype} = $attr{'-output'} + || return error('No output type given!'); + + $self->{types} = { + 'xml' => 'application/xml', + 'json' => 'text/html', + 'html' => 'text/html', + 'javascript' => 'text/javascript', + }; + + # New JSON Object if required + if($self->{outtype} eq 'json') { + $self->{json} = JSON->new() + unless(ref $self->{json}); + } + + $self->{TYP} = 'AJAX'; + + $self->{CMDSTAT} = undef; + + return $self; +} + +# ------------------ +sub out { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || 0; + my $para = shift || 0; + my $name = shift || 'noName'; + my $type = shift || $obj->{types}->{$obj->{outtype}} || 'text/plain'; + my %args = @_; + + $obj->{nopack} = 1; + unless(defined $obj->{header}) { + # HTTP Header + $obj->{output_header} = $obj->header($type, \%args); + } + + $obj->{sendbytes}+= length($data); + + if($obj->{outtype} eq 'json') { + $obj->{output}->{data} = $data; + } else { + $obj->{output}->{DATA} = $data; + $obj->{output}->{$name}->{data} = $data; + $obj->{output}->{$name}->{params} = $para + if($para); + } +} + +# ------------------ +sub printout { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $nopack = shift || $obj->{nopack} || 0; + + + my $content .= ($obj->{outtype} eq 'xml' + ? $obj->{xml}->XMLout($obj->{output}) + : + ( $obj->{outtype} eq 'json' + ? $obj->{json}->objToJson ($obj->{output}, {pretty => 1, indent => 2}) + : $obj->{output}->{DATA}) + ); + # Kompress + $content = Compress::Zlib::memGzip($content) + if(! $nopack and $obj->{Zlib} and $obj->{browser}->{accept_gzip}); + + $obj->{handle}->print($obj->{output_header}, $content); + + undef $obj->{output}; + undef $obj->{output_header}; + undef $obj->{nopack}; +} + + +# ------------------ +sub header { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $typ = shift || return error ('No Type!' ); + my $arg = shift || {}; + + $arg->{'Content-encoding'} = 'gzip' + if($obj->{browser}->{accept_gzip} && ((!defined $obj->{nopack}) || $obj->{nopack} == 0) ); + + $arg->{'Cache-Control'} = 'no-cache, must-revalidate' if(!defined $arg->{'Cache-Control'}); + $arg->{'Pragma'} = 'no-cache' if(!defined $arg->{'Pragma'}); + + $obj->{header} = 200; + return $obj->{cgi}->header( + -type => $typ, + -status => "200 OK", + -expires => "now", + %{$arg}, + ); +} + +# ------------------ +sub headerNoAuth { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $typ = shift || 'text/html'; + + $obj->{header} = 401; + return $obj->{cgi}->header( + -type => $typ, + -status => "401 Authorization Required\nWWW-Authenticate: Basic realm=\"xxvd\"" + ); +} + +# ------------------ +sub msg { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || 0; + my $err = shift || 0; + + + my $msg; + if(! $err and $data) { + $msg = $data; + } else { + $msg = sprintf('ERROR:%s (%s)', $data); + } + + $obj->out( $msg, 0, 'msg' ); + + $obj->{call} = ''; +} + +# ------------------ +sub typ { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{TYP}; +} + +# ------------------ +sub setCall { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return error ('No Name!' ); + + $obj->{call} = $name; + return $obj->{call}; +} + +# ------------------ +sub browser { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{browser}; +} + +1; diff --git a/lib/XXV/OUTPUT/Console.pm b/lib/XXV/OUTPUT/Console.pm new file mode 100644 index 0000000..b1b6d80 --- /dev/null +++ b/lib/XXV/OUTPUT/Console.pm @@ -0,0 +1,741 @@ +package XXV::OUTPUT::Console; + +BEGIN{ + $ENV{PERL_RL} = 'Perl' +}; + +use Locale::gettext; +use Term::ReadLine; + +use strict; + +use Tools; +use Pod::Text; +use vars qw($AUTOLOAD); + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'Telnet', + Prereq => { + 'XML::Simple' => 'Easy API to maintain XML (esp config files)', + 'Text::ASCIITable' => 'Create a nice formatted table using ASCII characters.', + 'Term::ReadLine::Perl' => 'a quick implementation of the minimal interface to Readline', + }, + Description => gettext('This receive and send ASCII messages'), + Version => '0.01', + Date => '27.10.2004', + Author => 'xpix', + }; + return $args; +} + +# ------------------ +sub AUTOLOAD { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || {}; + my $params = shift || 0; + + my $name = (split('::', $AUTOLOAD))[-1]; + return if($name eq 'DESTROY'); + + $obj->message(gettext("Sorry, but this command is not available in this Interface!")); +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # who am I + $self->{MOD} = $self->module; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{handle} = $attr{'-handle'} + || return error('No handle defined!'); + + $self->{dbh} = $attr{'-dbh'} + || return error('No DBH defined!'); + + $self->{paths} = $attr{'-paths'} + || return error('No Paths given!'); + + $self->{term} = Term::ReadLine->new('xxv', $self->{handle}, $self->{handle}) + || return error('No Term given!'); + + $self->{TYP} = 'CONSOLE'; + + $self->{maxwidth} = 20; + + $self->{TableDefaults} = { + allowANSI => 1, + allowHTML => 1, + drawRowLine => 1, + reportErrors=> 1, + cb_count => sub{ $self->_myallowansi_cb(@_) }, + }; + + return $self; +} + +# ------------------ +sub printout { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + $data =~ s/[^\r]\n/\r\n/sig; + + my $h = $obj->{handle}; + print $h $data."\r\n"; +} + +# ------------------ +sub message { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + my $t = Text::ASCIITable->new(); + $t->setOptions( $obj->{TableDefaults} ); + + $t->setCols(gettext('Message')); + if(ref $data eq 'ARRAY') { + map { $t->addRow($_) } @$data; + } else { + $t->addRow($data); + } + $obj->printout($t->draw()); +} + +# ------------------ +sub push { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + $obj->printout($data); +} +# ------------------ +sub msg { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + my $err = shift || return $obj->message($data); + + $obj->err($data) if($err); +} + +# ------------------ +sub err { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + my $t = Text::ASCIITable->new; + $t->setOptions( $obj->{TableDefaults} ); + + $t->setCols(gettext('ERROR')); + if(ref $data eq 'ARRAY') { + map { $t->addRow($_) } @$data; + } else { + $t->addRow($data); + } + $obj->printout($t->draw()); +} + +# ------------------ +sub menu { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + my $t = Text::ASCIITable->new; + $t->setOptions( $obj->{TableDefaults} ); + $t->setCols(gettext('Module'), + gettext('Short cut'), + gettext('Name'), + gettext('Description')); + + foreach my $line (@$data) { + if(ref $line eq 'ARRAY') { + $t->addRow(@$line); + } else { + $obj->printout($line); + } + } + + $obj->printout($t->draw()); +} + +# ------------------ +sub littlemenu { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + my $text = $data->{title}."\n"; + $text .= gettext("Please use command and one of the following sectors:\n"); + $text .= join(', ', sort keys %{$data->{links}}); + + $obj->message($text); +} + +# ------------------ +sub login { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + my $questions = [ + 'Name' => { + typ => 'string', + msg => gettext("Username?"), + }, + 'Password' => { + typ => 'string', + msg => gettext("Password?"), + }, + ]; + + my $answer = $obj->question($data."\r\n", $questions); + return $answer; +} + + +# ------------------ +sub table { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + my $param = shift || {}; + my $noPrint = shift || 0; + + my $out = ''; + my $UserMaxWidth = (delete $param->{maxwidth} || $obj->{maxwidth}); + + my $fields = (ref $data eq 'ARRAY') ? + shift @$data : + [ + gettext('Name'), + gettext('Value') + ]; + + my $t = Text::ASCIITable->new; + $t->setOptions( $obj->{TableDefaults} ); + $t->setOptions($param) if($param); + + my ($displayFields, $displayData) = $obj->_parseData($fields, $data); + $t->setCols(@$displayFields); + map { $t->setColWidth($_, $UserMaxWidth) } @$displayFields; + + if(ref $displayData eq 'ARRAY') { + foreach my $line (@$displayData) { + if(ref $line eq 'ARRAY') { + $t->addRow(@$line); + } else { + $out .= $line; + } + } + } else { + foreach my $name (sort keys %$data) { + my $dspl = ''; + if(ref $data->{$name} eq 'HASH') { + foreach (sort keys %{$data->{$name}}) { + if(ref $data->{$name}->{$_}) { + $dspl .= $obj->table($data->{$name}->{$_}, $param, 'noPrint'); + } else { + $dspl .= sprintf("%s: %s\n", $_, $data->{$name}->{$_}); + } + } + } else { + $dspl = $data->{$name}; + } + $t->addRow($name, $dspl); + } + } + + $out .= $t->draw(); + + unless($noPrint) { + $obj->printout($out); + } else { + return $out; + } +} + +# ------------------ +sub question { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $title = shift || 0; + my $questions = shift || return error ('No Data!' ); + my $erg = shift || {}; + + my $quest; + + # Check Data + if(ref $erg eq 'HASH' and ref $questions eq 'ARRAY' and exists $erg->{action}) { + my $error; + @$quest = @$questions; + while (my ($name, $data) = splice(@$quest, 0, 2)) { + # Required value ... + $error = $data->{req} + if($data->{req} and not $erg->{$name}); + + # Check Callback + if(exists $data->{check} and ref $data->{check} eq 'CODE' and not $error) { + ($erg->{$name}, $error) = $data->{check}($erg->{$name}, $data, $erg); + } + + # Check on directory + if($data->{typ} eq 'dir' and $data->{required} and not -d $erg->{$name}) { + ($erg->{$name}, $error) = (undef, sprintf(gettext("Directory '%s' is doesn't exist!"), $erg->{$name})); + } + + # Check on file + if($data->{typ} eq 'file' and $data->{required} and not -e $erg->{$name}) { + ($erg->{$name}, $error) = (undef, sprintf(gettext("File '%s' is doesn't exist!"), $erg->{$name})); + } + + if($error) { + $obj->err(sprintf(gettext("Error at field '%s' (%s) : %s"), $data->{msg}, $name, $error)); + last; + } + } + unless($error) { + delete $erg->{action}; + return $erg; + } + } + + $obj->printout("$title\n") if($title); + if(ref $questions eq 'ARRAY') { + while (my ($name, $data) = splice(@$questions, 0, 2)) { + my $type = delete $data->{typ}; + $type ||= 'string'; + $erg->{$name} = $obj->$type($data); + } + } else { + my $type = delete $questions->{typ}; + $type ||= 'string'; + $erg = $obj->$type($questions); + } + return $erg; +} + +# ------------------ +sub list { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + my $t = $obj->{term}; + my $error; + my $def; + + if(defined $data->{def}) { + if(ref $data->{def} eq 'CODE') { + $def = $data->{def}(); + } elsif(ref $data->{def} eq 'ARRAY') { + $def = join(', ', @{$data->{def}}); + } else { + $def = $data->{def}; + }} + + my $message = (defined $def) ? sprintf('%s [%s]: ', $data->{msg}, $def) : $data->{msg}.': '; + + while (defined (my $answer = $t->readline($message))) { + $answer =~ s/[\r|\n]//sig; + + # Default value ... + $answer = $data->{def} + if(defined $data->{def} and not $answer); + + # List ... + $error = sprintf(gettext("\nPlease use one of this list items:\n %s"), join(",\n", @{$data->{choices}})) + unless(grep($_ eq $answer, @{$data->{choices}})); + + # Required value ... + $error = $data->{req} + if($data->{req} and not $answer); + + # Check Callback ... + ($answer, $error) = $data->{check}($answer) + if(defined $data->{check} and ref $data->{check} eq 'CODE'); + + # Display Error Message .... + if($error) { + $message = (defined $data->{def}) ? sprintf('%s [%s]', $error, $def) : $error.': '; + undef $error; + } else { + return $answer; + } + } +} + + +# ------------------ +sub string { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + my $t = $obj->{term}; + my $error; + + my $def; + if(defined $data->{def}) { + if(ref $data->{def} eq 'CODE') { + $def = $data->{def}(); + } else { + $def = $data->{def}; + }} + + my $message = (defined $def) ? sprintf('%s [%s]: ', $data->{msg}, $def) : $data->{msg}.': '; + while (defined (my $answer = $t->readline($message))) { + $answer =~ s/[\r|\n]//sig; + # Default value ... + $answer = $def + if($def and not $answer); + + # Required value ... + $error = $data->{req} + if($data->{req} and not $answer); + + # Check Callback ... + ($answer, $error) = $data->{check}($answer) + if(defined $data->{check} and ref $data->{check} eq 'CODE'); + + # Display Error Message .... + if($error) { + $message = ($def) ? sprintf('%s [%s]', $error, $def) : $error.': '; + undef $error; + } else { + return $answer; + } + } +} + +# ------------------ +sub file { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->string(@_); +} + +# ------------------ +sub dir { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->string(@_); +} + +# ------------------ +sub password { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->string(@_); +} + +# ------------------ +sub date { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->string(@_); +} + +# ------------------ +sub integer { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + my $t = $obj->{term}; + my $error; + + my $message = (defined $data->{def} ) ? sprintf('%s [%s]: ', $data->{msg}, $data->{def}) : $data->{msg}.': '; + while (defined (my $answer = $t->readline($message))) { + $answer =~ s/[\r|\n]//sig; + + # Default value ... + $answer = $data->{def} + if($data->{def} and ! $answer); + + # Interger? + $error = sprintf(gettext("'%s' is not an integer!"),$answer) + if($answer and not int($answer)); + + # Required? + $error = $data->{req} + if(defined $data->{req} and not $answer); + + # Check Callback + ($answer, $error) = $data->{check}($answer) + if(defined $data->{check} and ref $data->{check} eq 'CODE'); + + if($error) { + $message = (defined $data->{def}) ? sprintf('%s [%s]', $error, $data->{def}) : $error.': '; + undef $error; + } else { + return $answer; + } + } +} + +# ------------------ +sub confirm { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + my $t = $obj->{term}; + my $error; + + my $message = (defined $data->{def} ) ? sprintf('%s [%s]: ', $data->{msg}, $data->{def}) : $data->{msg}.': '; + while (defined (my $answer = $t->readline($message))) { + $answer =~ s/[\r|\n]//sig; + + # Default value ... + $answer = $data->{def} + if($data->{def} and ! $answer); + + # Only yes or no ... + $error = gettext("Please answer with 'y'es or 'n'o: ") + if($answer !~ /^[y|n]$/); + + # Required value ... + $error = $data->{req} + if($data->{req} and not $answer); + + # Check Callback ... + ($answer, $error) = $data->{check}($answer) + if(defined $data->{check} and ref $data->{check} eq 'CODE'); + + # Display Error Message .... + if($error) { + $message = (defined $data->{def}) ? sprintf('%s [%s]', $error, $data->{def}) : $error.': '; + undef $error; + } else { + return $answer; + } + } +} + +# ------------------ +sub hidden { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + + return error('No <def> in hidden Variable!') + unless(defined $data->{def}); + return $data->{def}; +} + +# ------------------ +sub image { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data to display'); + + return $obj->message(gettext("Sorry, but i cannot display an image on this Interface.")); +} + +# ------------------ +sub checkbox { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + my $t = $obj->{term}; + my $error; + + my $message = (defined $data->{def}) ? sprintf('%s [%s]: ', $data->{msg}, join(', ', @{$data->{def}})) : $data->{msg}.': '; + while (defined (my $answer = $t->readline($message))) { + $answer =~ s/[\r|\n]//sig; + # Default value ... + $answer = $data->{def} + if(defined $data->{def} and not $answer); + + # Required value ... + $error = $data->{req} + if($data->{req} and not $answer); + + # Check Callback ... + ($answer, $error) = $data->{check}($answer, $data) + if(defined $data->{check} and ref $data->{check} eq 'CODE'); + + # Display Error Message .... + if($error) { + $message = (defined $data->{def}) ? sprintf('%s [%s]', $error, join(', ', @{$data->{def}})) : $error.': '; + undef $error; + } else { + return $answer; + } + } +} + +# ------------------ +sub radio { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || return error ('No Data!' ); + my $t = $obj->{term}; + my $error; + + my $message = (defined $data->{def}) ? sprintf('%s [%s]: ', $data->{msg}, $data->{def}) : $data->{msg}.': '; + while (defined (my $answer = $t->readline($message))) { + $answer =~ s/[\r|\n]//sig; + # Default value ... + $answer = $data->{def} + if(defined $data->{def} and not $answer); + + # Required value ... + $error = $data->{req} + if($data->{req} and not $answer); + + # only one of all ... + $error = sprintf(gettext("You can only use one of this items: %s"), join(',', @{$data->{choices}})) + unless(grep( $answer eq $_, @{$data->{choices}})); + + + # Check Callback ... + ($answer, $error) = $data->{check}($answer, $data) + if(defined $data->{check} and ref $data->{check} eq 'CODE'); + + # Display Error Message .... + if($error) { + $message = (defined $data->{def}) ? sprintf('%s [%s]', $error, $data->{def}) : $error.': '; + undef $error; + } else { + return $answer; + } + } +} + +# ------------------ +sub pod { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $modname = uc(shift) || return error ('No Modname!' ); + $modname = ucfirst($modname) if($modname eq 'GENERAL'); + + my $podfile = sprintf('%s/%s.pod', $obj->{paths}->{PODPATH}, $modname); + return $obj->err(gettext('Module %s not found!'), $modname) + unless(-r $podfile); + my $tmpdir = main::getModule('USER')->userTmp; + my $outfile = sprintf('%s/%s_%d.pod', $tmpdir, $modname, time); + + my $parser = Pod::Text->new (sentence => 0, width => 78); + + # Read POD from file.pod and write to file.txt. + $parser->parse_from_file ( + $podfile, + $outfile + ); + return error('Problem to convert pod2txt') + unless(-r $outfile); + my $txt = load_file($outfile); + + $obj->message($txt); +} + +# ------------------ +sub txtfile { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $filename = shift || return error ('No TxtFile to diplay!' ); + my $param = shift || {}; + + my $txtfile = sprintf('%s/%s.txt', $obj->{paths}->{DOCPATH}, $filename); + my $gzfile = sprintf('%s/%s.txt.gz', $obj->{paths}->{DOCPATH}, $filename); + + $txtfile = main::getModule('HTTPD')->unzip($gzfile) + if(! -r $txtfile and -e $gzfile and -r $gzfile); + + my $txt = load_file($txtfile); + return $obj->message($txt, {tags => {first => "File: $filename.txt"}}); +} + +# ------------------ +sub remote { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $text = qq! +.-----------------------. +| 1 | 2 | 3 | +|-----------------------| +| 4 | 5 | 6 | +|-----------------------| +| 7 | 8 | 9 | +|-----------------------| +| Menu | 0 | Back | +|-----------------------| +| | Up | | +|-----------------------| +| Left | Ok | Right | +|-----------------------| +| | Down | Blue | +|-----------------------| +| Red | Green | Yellow| +|-----------------------| +| Vol:+/- | Chan: <> | +|-----------------------| +| << | >> | +|-----------------------| +!; + $obj->printout($text); +} + +# ------------------ +sub _myallowansi_cb { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $_ = shift; + s/\33\[(\d+(;\d+)?)?[musfwhojBCDHRJK]//g; + return length($_); +} + +# ------------------ +sub _parseData { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $fields = shift || return error ('No Fields!' ); + my $data = shift || return error ('No Data!' ); + + my $displayFields = []; + @$displayFields = grep(!/^__/, @$fields); + + if(ref $data eq 'ARRAY') { + foreach my $d (@$data) { + my $c = -1; my @newData; + foreach my $r (@$d) { + $c++; + CORE::push(@newData, $r) + if($fields->[$c] !~ /^__/); + } + @$d = @newData; + } + return ($displayFields, $data); + } else { + return ($fields, $data); + } +} + + +# ------------------ +sub typ { +# ------------------ + my $obj = shift || return error ('No Object!'); + return $obj->{TYP}; +} + +1; diff --git a/lib/XXV/OUTPUT/Dump.pm b/lib/XXV/OUTPUT/Dump.pm new file mode 100644 index 0000000..02ea847 --- /dev/null +++ b/lib/XXV/OUTPUT/Dump.pm @@ -0,0 +1,62 @@ +package XXV::OUTPUT::Dump; + +use strict; + +use vars qw($AUTOLOAD); +use Tools; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'Dump', + Prereq => { + }, + Description => gettext('This receive and send Dump messages.'), + Version => '0.01', + Date => '27.10.2004', + Author => 'xpix', + }; + return $args; +} +# ------------------ +sub AUTOLOAD { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return if($AUTOLOAD =~ /DESTROY$/); +dumper(\@_); + return @_; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # who am I + $self->{MOD} = $self->module; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{TYP} = 'INTERFACE'; + + return $self; +} + +# ------------------ +sub typ { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{TYP}; +} + +1; diff --git a/lib/XXV/OUTPUT/HTML/PUSH.pm b/lib/XXV/OUTPUT/HTML/PUSH.pm new file mode 100644 index 0000000..7c7d7df --- /dev/null +++ b/lib/XXV/OUTPUT/HTML/PUSH.pm @@ -0,0 +1,95 @@ +package XXV::OUTPUT::HTML::PUSH; + +use strict; + +use Tools; + +$| = 1; + +=head1 NAME + +XXV::OUTPUT::HTML::PUSH - A Push for http system + +=head1 SYNOPSIS + + use XXV::OUTPUT::HTML::PUSH; + + my $pusher = XXV::OUTPUT::HTML::PUSH->new( + -cgi => $obj->{cgi}, # The CGI Object from Lincoln Stein + -handle => $obj->{handle}, # The handle to printout the http Stuff + ); + + $pusher->start(); # Start the Push Process + + while($c > 10) { + $pusher->print($c++); # Print out the message + } + + $pusher->stop(); # Stop the Push + + +=cut + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + $self->{handle} = $attr{'-handle'} + || return error('No handle defined!'); + + $self->{cgi} = $attr{'-cgi'} + || return error('No CGI Object defined!'); + + return $self; +} + +# ------------------ +sub start { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $out = shift || 0; + $obj->{handle}->print($obj->{cgi}->multipart_init(-boundary=>'----here we go!')); + $obj->print($out) if($out); +} + +# ------------------ +sub print { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $msg = shift || return; + my $type = shift || 'text/html'; + + $obj->{handle}->print($obj->{cgi}->multipart_start(-type=>$type)); + $obj->{handle}->print($msg."\n"); + $obj->{handle}->print($obj->{cgi}->multipart_end); +} + +# ------------------ +sub follow_print { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $msg = shift || return; + my $type = shift || 'text/html'; + + unless($obj->{header}) { + $obj->{handle}->print($obj->{cgi}->multipart_start(-type=>$type)); + $obj->{header} = 1; + } + $obj->{handle}->print($msg."\n"); +} + +# ------------------ +sub stop { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{handle}->print($obj->{cgi}->multipart_end); + $obj->{handle}->print($obj->{cgi}->header( + -type => 'text/html', + -status => "200 OK", + )); +} + +1; diff --git a/lib/XXV/OUTPUT/HTML/WAIT.pm b/lib/XXV/OUTPUT/HTML/WAIT.pm new file mode 100644 index 0000000..8ebd430 --- /dev/null +++ b/lib/XXV/OUTPUT/HTML/WAIT.pm @@ -0,0 +1,169 @@ +package XXV::OUTPUT::HTML::WAIT; + +use strict; + +use Tools; +use XXV::OUTPUT::HTML::PUSH; + +=head1 NAME + +XXV::OUTPUT::HTML::WAIT - A Processbar for XXV system + +=head1 SYNOPSIS + + use XXV::OUTPUT::HTML::WAIT; + + my $waiter = XXV::OUTPUT::HTML::WAIT->new( + -cgi => $obj->{cgi}, # The CGI Object from Lincoln Stein + -handle => $obj->{handle}, # The handle to printout the http Stuff + -callback => sub{ # Callback for html output. + # In this case parse the html template wait.tmpl + my ($min, $max, $cur, $steps) = @_; + my $out = $obj->parseTemplate( + 'wait', + { + msg => $msg, + minimum => $min, + current => $cur, + maximum => $max, + steps => $steps + }, + ); + return $out; + }, + ); + + $waiter->min(0); # Min Value for process Bar + $waiter->max(10); # Max Value for process Bar + $waiter->screen('yes'); # Every call of next will redraw the process bar + + while($c > 10) { + $waiter->next($c++); # Next Event with current value + } + $waiter->end; + +=cut + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + $self->{handle} = $attr{'-handle'} + || return error('No handle defined!'); + + $self->{cgi} = $attr{'-cgi'} + || return error('No CGI Object defined!'); + + $self->{callback} = $attr{'-callback'} + || return error('No Callback to print out!'); + + $self->{steps} = $attr{'-steps'} || 10; + + $self->{pusher} = XXV::OUTPUT::HTML::PUSH->new( + -cgi => $self->{cgi}, # The CGI Object from Lincoln Stein + -handle => $self->{handle}, # The handle to printout the http Stuff + ); + + $self->init(); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + $obj->{STEP} = 0; + $obj->{pusher}->start(); + undef $obj->{FirstRefresh}; +} + +# ------------------ +sub next { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $cur = shift || $obj->{MAX}; + my $end = shift || 0; + my $msg = shift || 0; + + + # Don't show really every step, even is screen defined, + # avoid high traffic and long duration of waiter progress + my $t = time; + return + if(defined $obj->{SCREEN} && $obj->{SCREEN} eq 'no' + && $end == 0 + && $obj->{LastRefreshTime} && $obj->{LastRefreshTime} > ($t - 1)); + + # remember time from from first call + $obj->{FirstRefresh} = $t + if(not $obj->{FirstRefresh}); + + # calc end time of execution + my $rest = $end ? 0 : $obj->{MAX} - $cur; + my $deltaT = $t - $obj->{FirstRefresh}; + my $etaT = ($cur > 0) ? ($deltaT / $cur * $rest) : 0; + # Format end time of execution from seconds to human readable format + my $eta = sprintf("%02d:%02d:%02d",$etaT / 3600 % 24 ,($etaT / 60) % 60, $etaT % 60 ); + + $obj->{LastRefreshTime} = $t; + + + # 2.2 = 22 / 10 + my $step = $obj->{MAX} / $obj->{steps}; + $obj->{STEP} += $step; + + if ($end or $cur > $obj->{MAX}) { + $obj->{pusher}->stop(); + my $out = $obj->{endcallback}($obj->{MIN}, $obj->{MAX}, $cur, $obj->{steps}, $msg, $eta) + if(ref $obj->{endcallback} eq 'CODE'); + } else { + my $out = $obj->{callback}($obj->{MIN}, $obj->{MAX}, $cur, $obj->{steps}, $msg, $eta); + $obj->{pusher}->print($out); + } +} + +# ------------------ +sub end { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $msg = shift || 0; + + return $obj->next(undef, $obj->{MAX}, 1, $msg); +} + + +# ------------------ +sub endcallback { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{endcallback} = shift || return $obj->{endcallback}; +} + +# ------------------ +sub max { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{MAX} = shift || return $obj->{MAX}; +} + +# ------------------ +sub min { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{MIN} = shift || return $obj->{MIN}; +} + +# ------------------ +sub screen { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{SCREEN} = shift || return $obj->{SCREEN}; +} + + +1; diff --git a/lib/XXV/OUTPUT/Html.pm b/lib/XXV/OUTPUT/Html.pm new file mode 100644 index 0000000..72251ba --- /dev/null +++ b/lib/XXV/OUTPUT/Html.pm @@ -0,0 +1,851 @@ +package XXV::OUTPUT::Html; + +use strict; + +#use Template; +use vars qw($AUTOLOAD); +use Locale::gettext; +use Tools; +use XXV::OUTPUT::HTML::WAIT; +use File::Path; +use File::Basename; +use Pod::Html; +use Fcntl; +#use Thread; + +$SIG{CHLD} = 'IGNORE'; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'Html', + Prereq => { + 'HTML::TextToHTML' => 'convert plain text file to HTML. ', + }, + Description => gettext('This receive and send HTML messages.'), + Version => '0.92', + Date => '2007-01-21', + Author => 'xpix', + }; + return $args; +} + +# ------------------ +sub AUTOLOAD { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || {}; + my $params = shift || 0; + + my $name = (split('::', $AUTOLOAD))[-1]; + return if($name eq 'DESTROY'); + + my $output = $obj->parseTemplate($name, $data, $params); + + $obj->out( $output ); + + $obj->{call} = ''; +} + + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # who am I + $self->{MOD} = $self->module; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{handle} = $attr{'-handle'} + || return error('No handle defined!'); + + $self->{paths} = $attr{'-paths'} + || return error('No Paths defined!'); + + $self->{dbh} = $attr{'-dbh'} + || return error('No DBH defined!'); + + $self->{htmdir} = $attr{'-htmdir'} + || return error('No htmdir given!'); + + $self->{htmdef} = $attr{'-htmdef'} + || return error('No htmdef given!'); + + $self->{cgi} = $attr{'-cgi'} + || return error('No TemplateDir given!'); + + $self->{mime} = $attr{'-mime'} + || return error('No Mimehash given!'); + + $self->{browser} = $attr{'-browser'} + || return error('No Mimehash given!'); + + $self->{start} = $attr{'-start'} + || return error('No StartPage given!'); + + $self->{debug} = $attr{'-debug'} + || 0; + + $self->{TYP} = 'HTML'; + + # Forward name of Server for CGI::server_software + $ENV{'SERVER_SOFTWARE'} = sprintf("xxvd %s",main::getVersion()); + $ENV{'SERVER_PROTOCOL'} = 'HTTP/1.1'; + + # create Template object + $self->{tt} = Template->new( + START_TAG => '\<\?\%', # Tagstyle + END_TAG => '\%\?\>', # Tagstyle + INCLUDE_PATH => [$self->{htmdir},$self->{htmdef}] , # or list ref + INTERPOLATE => 1, # expand "$var" in plain text + PRE_CHOMP => 1, # cleanup whitespace + EVAL_PERL => 1, # evaluate Perl code blocks + ); + + eval "use Compress::Zlib"; + $self->{Zlib} = ($@ ? 0 : 1); + + + # create TextToHTML object + $self->{txt2html} = HTML::TextToHTML->new( + preformat_whitespace_min => 4, + ); + + &bench('CLEAR'); + + return $self; +} + +# ------------------ +sub parseTemplate { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return error ('No Name!' ); + my $data = shift || return error ('No Data!' ); + my $params = shift || {}; + + my $output; + unless(defined $obj->{header}) { + $output .= $obj->parseTemplateFile("start", $data, $params); + } + $output .= $obj->parseTemplateFile($name, $data, $params,((exists $obj->{call}) ? $obj->{call} : 'nothing')); + return $output; +} + +# ------------------ +sub index { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{nopack} = 1; + $obj->{call} = 'index'; + my $params = {}; + $params->{start} = $obj->{start}; + $obj->out( $obj->parseTemplateFile("index", {}, $params, $obj->{call})); +} + + +# ------------------ +sub parseTemplateFile { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return error ('No Name!' ); + my $data = shift || return error ('No Data!' ); + my $params = shift || return error ('No params!' ); + my $call = shift || 'nothing'; + + $obj->parseData($data) + if($name ne 'start' && $name ne 'footer' + && !$obj->{dontparsedData} ); + + my $t = $obj->{tt}; + my $u = main::getModule('USER'); + + # you can use two templates, first is a user defined template + # and second the standard template + # i.e. call the htmlhelp command the htmlhelp.tmpl + # SpecialTemplate: ./htmlRoot/usage.tmpl + # StandardTemplate: ./htmlRoot/widgets/menu.tmpl + my $widget_first = sprintf('%s.tmpl', $call); + my $widget_second = sprintf('widgets/%s.tmpl', $name); + my $widget = (-e sprintf('%s/%s', $obj->{htmdir}, $widget_first) ? $widget_first : $widget_second); + + my $user = ($u->{active} eq 'y' && $obj->{USER}->{Name} ? $obj->{USER}->{Name} : "nobody" ); + my $output; + my $vars = { + cgi => $obj->{cgi}, + call => $name, + data => $data, + type => ref $data, + info => $obj->browser, + param => $params, + pid => $$, + debug => $obj->{debug}, + user => $user, + # query the current locale + locale => main::getGeneralConfig->{Language}, + allow => sub{ + my($cmdobj, $cmdname, $se, $err) = $u->checkCommand($obj, $_[0],"1"); + return $cmdobj; + }, + + # Deaktiviert da durch parseData alle Daten + # komplett mit entities behandelt wurden + entities => sub{ return $_[0] }, + + # Remove entities from parameters + reentities => sub{ return reentities($_[0]) }, + + # Escape strings for javascript + escape => sub{ + my $s = shift; # string + $s =~ s/\r//g; + $s =~ s/\n//g; + $s =~ s/"/\\"/g; + $s =~ s/\'/\\\'/g; + return $s; + }, + + # truncate string with entities + chop => sub{ + my $s = shift; # string + my $c = shift; # count + my $l = shift || 0; # lines + + if ( $c > 3 ) { + $s = reentities($s); + if($l) + { + my @text = split ('\r\n', $s); + if(scalar @text > 1) + { + my @lines; + foreach my $line (@text) + { + if ( length( $line ) > $c ) { + $line = substr( $line, 0, ( $c - 3 ) ) . '...'; + } + --$l; + last if($l < 0); + push(@lines,$line); + } + $s = join("\r\n",@lines); + } else { + if ( length( $s ) > ($c * $l) ) { + $s = substr( $s, 0, ( ($c * $l) - 3 ) ) . '...'; + } + } + } + elsif ( length( $s ) > $c ) { + $s = substr( $s, 0, ( $c - 3 ) ) . '...'; + } + return entities($s); + } else { + return $s ? '...' : ''; + } + }, + url => sub{ + my $s = shift; # string + $s = reentities($s); + $s =~ s/([^a-z0-9A-Z])/sprintf('%%%X', ord($1))/seg; + return $s; + }, + + # translate string, usage : gettext(foo,truncate) or gettext(foo) + # value for truncate are optional + gettext => sub{ + my $t = gettext($_[0]); + $t = substr($t,0,$_[1]) . "..." + if(defined $_[1] && length($t)>$_[1]); + return entities($t); + }, + version => sub{ return main::getVersion }, + loadfile => sub{ return load_file(@_) }, + writefile => sub{ + my $filename = shift || return error('No Filename to write'); + my $data = shift || return error('Nothing data to write'); + + my $dir = $u->userTmp; + + # absolut Path to file + my $file = sprintf('%s/%s', $dir, $filename); + # absolut Path to file + if(save_file($file, $data)) { + # return the relative Path + my ($relpath) = $file =~ '/(.+?/.+?)$'; + return sprintf('tempimages/%s', $filename); + } + }, + fmttime => sub{ return fmttime(@_) }, + bench => \&bench, + llog => sub{ + my $lines = shift || 10; + my $lmod = main::getModule('LOGREAD'); + return $lmod->tail($obj->{paths}->{LOGFILE}, $lines); + }, + getModule => sub{ + return main::getModule(shift); + }, + }; + + $t->process($widget, $vars, \$output) + or return error($t->error()); + + return $output; +} + +# ------------------ +sub out { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $text = shift || 'no Text for Output'; + my $type = shift || 'text/html'; + my %args = @_; + + unless(defined $obj->{header}) { + # HTTP Header + $obj->{output_header} = $obj->header($type, \%args); + } + + $obj->{output} .= $text,"\r\n" + if($text); +} + +# ------------------ +sub printout { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $nopack = shift || $obj->{nopack} || 0; + + if($obj->{output} && $obj->{handle}) { + my $content = $obj->{output}; + + $content = Compress::Zlib::memGzip($content) + if(! $nopack and $obj->{Zlib} and $obj->{browser}->{accept_gzip}); + + $obj->{handle}->print($obj->{output_header}, $content); + $obj->{sendbytes}+= length($obj->{output_header}); + $obj->{sendbytes}+= length($content); + $obj->{handle}->close(); + } + undef $obj->{output}; + undef $obj->{output_header}; + undef $obj->{nopack}; + undef $obj->{hasentities}; + undef $obj->{dontparsedData}; +} + +# ------------------ +sub getType { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $typ = shift || 'text/html'; + + my $typefile = sprintf('%s/%s', $obj->{htmdir}, 'GENERICTYP'); + if(-e $typefile and -r $typefile) { + $typ = load_file($typefile); + $typ =~ s/[\r|\n]//sig; + } + return $typ; +} + +# ------------------ +sub header { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $typ = $obj->getType(shift) || return error ('No Type!' ); + my $arg = shift || {}; + + $arg->{'Content-encoding'} = 'gzip' + if($obj->{browser}->{accept_gzip} && ((!defined $obj->{nopack}) || $obj->{nopack} == 0) ); + + if(defined $obj->{nocache} && $obj->{nocache}) { + $arg->{'Cache-Control'} = 'no-cache, must-revalidate' if(!defined $arg->{'Cache-Control'}); + $arg->{'Pragma'} = 'no-cache' if(!defined $arg->{'Pragma'}); + } + + $obj->{header} = 200; + return $obj->{cgi}->header( + -type => $typ, + -status => "200 OK", + -expires => ($typ =~ 'text/html' || (defined $obj->{nocache} && $obj->{nocache})) ? "now" : "+7d", + %{$arg}, + ); +} + +# ------------------ +sub statusmsg { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $state = shift || return error ('No Status!'); + my $msg = shift; + my $title = shift; + + unless(defined $obj->{header}) { + $obj->{nopack} = 1; + + my $s = { + 200 => '200 OK', + 204 => '204 No Response', + 301 => '301 Moved Permanently', + 302 => '302 Found', + 303 => '303 See Other', + 304 => '304 Not Modified', + 307 => '307 Temporary Redirect', + 400 => '400 Bad Request', + 401 => '401 Unauthorized', + 403 => '403 Forbidden', + 403 => '404 Not Found', + 405 => '405 Not Allowed', + 408 => '408 Request Timed Out', + 500 => '500 Internal Server Error', + 503 => '503 Service Unavailable', + 504 => '504 Gateway Timed Out', + }; + my $status = $s->{200}; + $status = $s->{$state} + if(exists $s->{$state}); + + my $arg = {}; + $arg->{'WWW-Authenticate'} = "Basic realm=\"xxvd\"" + if($state == 401); + + $arg->{'expires'} = "now" + if($state != 304); + + $obj->{header} = $state; + $obj->{output_header} = $obj->{cgi}->header( + -type => 'text/html', + -status => $status, + %{$arg}, + ); + } + if($msg && $title) { + $obj->{output} = $obj->{cgi}->start_html(-title => $title) + . $obj->{cgi}->h1($title) + . $obj->{cgi}->p($msg) + . $obj->{cgi}->end_html(); + } else { + $obj->{output} = '\r\n'; + } +} + +# ------------------ +# Send HTTP Status 401 (Authorization Required) +sub login { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $msg = shift || ''; + + $obj->statusmsg(401,$msg,gettext("Authorization required")); +} + +# ------------------ +# Send HTTP Status 403 (Access Forbidden) +sub status403 { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $msg = shift || ''; + + $obj->statusmsg(403,$msg,gettext("Forbidden")); +} + + +# ------------------ +# Send HTTP Status 404 (File not found) +sub status404 { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $file = shift || return error ('No File!'); + my $why = shift || ""; + + $file =~ s/$obj->{htmdir}\///g; # Don't post html root, avoid spy out + + $obj->statusmsg(404,sprintf(gettext("Can't open file '%s' : %s"),$file,$why), + gettext("Not found")); +} + +# ------------------ +sub question { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $titel = shift || 'undef'; + my $questions = shift || return error ('No Data!' ); + my $erg = shift || 0; + + my $q = $obj->{cgi}; + my $quest; + + # Check Data + if(ref $erg eq 'HASH' and ref $questions eq 'ARRAY' and exists $erg->{action}) { + my $error; + @$quest = @$questions; + while (my ($name, $data) = splice(@$quest, 0, 2)) { + + $data->{typ} = 'string' + unless($data->{typ}); + + # Required value ... + $error = $data->{req} + if($data->{req} and not $erg->{$name}); + + # Check Callback + if(exists $data->{check} and ref $data->{check} eq 'CODE' and not $error) { + ($erg->{$name}, $error) = $data->{check}($erg->{$name}, $data, $erg); + } + + # Check on directory + if($data->{typ} eq 'dir' and $data->{required} and not -d $erg->{$name}) { + ($erg->{$name}, $error) = (undef, sprintf(gettext("Directory '%s' is doesn't exist!"), $erg->{$name})); + } + + # Check on file + if($data->{typ} eq 'file' and $data->{required} and not -e $erg->{$name}) { + ($erg->{$name}, $error) = (undef, sprintf(gettext("File '%s' is doesn't exist!"), $erg->{$name})); + } + + # Check on password (is not set the take the old password) + if($data->{typ} eq 'password' and not $erg->{$name}) { + $erg->{$name} = $data->{def}; + } + + if($error) { + $obj->err(sprintf(gettext("Error at field '%s' (%s) : %s"), $data->{msg}, $name, $error)); + last; + } + } + unless($error) { + delete $erg->{action}; + return $erg; + } + } + + $obj->formStart($titel); + if(ref $questions eq 'ARRAY') { + my $q = $obj->{cgi}; + @$quest = @$questions; + my $c=0; + while (my ($name, $data) = splice(@$quest, 0, 2)) { + my $type = delete $data->{typ}; + my $params = delete $data->{param}; + $params->{count} = $c++; + $data->{msg} =~ s/\n/<br \/>/sig if($data->{msg}); + $data->{NAME} = '__'.$name; + $type ||= 'string'; + $obj->$type($data, $params); + } + } else { + my $type = delete $questions->{typ}; + $questions->{NAME} = '__'.$type; + $type ||= 'string'; + $obj->$type($questions); + } + $obj->formEnd; + return undef; +} + +# ------------------ +sub wait { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $msg = shift || gettext("Please wait ..."); + my $min = shift || 0; + my $max = shift || 0; + my $screen = shift || 0; + + my $http_useragent = $obj->{browser}->{http_useragent}; + if(grep(/Mozilla/i,$http_useragent) == 0 # Only Mozilla compatible browser support server push + || grep(/MSIE/i,$http_useragent) > 0 # Stopp her for Browser e.g. Internet Explorer + || grep(/Opera/i,$http_useragent) > 0 # Stopp her for Browser e.g. Opera + || grep(/KHTML/i,$http_useragent) > 0) # like Safari,Konqueror + { + lg sprintf('Sorry, only Mozilla compatible browser support server push, this browser was identify by "%s"', + $http_useragent ); + return 0; + } + $obj->{nopack} = 1; + $obj->{header} = 200; + my $waiter = XXV::OUTPUT::HTML::WAIT->new( + -cgi => $obj->{cgi}, + -handle => $obj->{handle}, + -callback => sub{ + my ($min, $max, $cur, $steps, $nextmessage, $eta) = @_; + my $out = $obj->parseTemplate( + 'wait', + { + msg => $nextmessage || $msg, + minimum => $min, + current => $cur, + maximum => $max, + steps => $steps, + eta => $eta + }, + ); + return $out; + }, + ); + + if($max) { + $waiter->min($min); # Min Value for process Bar + $waiter->max($max); # Max Value for process Bar + $waiter->screen($screen); # Every call of next will redraw the process bar + + } + $waiter->next(1); + + return $waiter; +} + +# ------------------ +sub datei { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $file = shift || return error ('No File!'); + my $typ = shift; + + my %args = (); + + return $obj->status404($file,$!) + if(!-r $file); + + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime,$ctime,$blksize,$blocks) = stat $file; + return $obj->status404($file,$!) + if(!$blocks); + + # header only if caching + $args{'ETag'} = sprintf('%x-%x-%x',$ino, $size, $mtime); + return $obj->statusmsg(304) + if($obj->{browser}->{'Match'} + && $args{'ETag'} eq $obj->{browser}->{'Match'}); + + $typ = $obj->{mime}->{lc((split('\.', $file))[-1])} + if(!$typ); + $typ = "application/octet-stream" + if(!$typ); + + $obj->{nopack} = 1 + if($typ =~ /image\// || $typ =~ /video\//); + + my(@MON)=qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/; + my(@WDAY) = qw/Sun Mon Tue Wed Thu Fri Sat/; + my($sec,$min,$hour,$mday,$mon,$year,$wday) = gmtime($mtime); + $args{'Last-Modified'} = sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", + $WDAY[$wday],$mday,$MON[$mon],$year + 1900,$hour,$min,$sec); + $args{'attachment'} = basename($file); + $args{'Content-Length'} = $size + if($obj->{nopack}); + + if($size > (32768 * 16)) { ## Only files bigger then 512k + + lg sprintf("stream file : '%s' (%s)",$file,convert($size)); + + $obj->{nopack} = 1; + my $handle = $obj->{handle}; + + my $child = fork(); + if ($child < 0) { + error("Can't create process for streaming : " . $!); + return $obj->status404($file,$!); + } + elsif ($child > 0) { + $obj->{sendbytes} += $size; + } + elsif ($child == 0) { + + eval + { + local $SIG{'__DIE__'}; + + my $hdr = $obj->header($typ, \%args); + + my $r = 0; + if(sysopen( FH, $file, O_RDONLY|O_BINARY )) { + $handle->print($hdr); + + my $bytes; + my $data; + do { + $bytes = sysread( FH, $data, 4096 ); + if($bytes) { + $r = $handle->send($data); + } + } while $r && $bytes > 0; + close(FH); + } else { + error sprintf("I can't open file '%s' : %s", $file,$!); + } + $handle->close(); + }; + error($@) if $@; + exit 0; + } + + undef $obj->{handle}; + undef $obj->{output}; + } else { + + my $data = load_file($file) + or return $obj->status404($file,$!); + # send data + $obj->out($data, $typ, %args ); + } +} + +# ------------------ +sub image { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $file = shift || return error ('No File!'); + my $typ = shift; + return $obj->datei($file,$typ); +} + +# ------------------ +sub pod { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $modname = uc(shift) || return error ('No Modname!' ); + $modname = ucfirst($modname) if($modname eq 'GENERAL'); + + my $podfile = sprintf('%s/%s.pod', $obj->{paths}->{PODPATH}, $modname); + return $obj->err(gettext('Module %s not found!'), $modname) + unless(-r $podfile); + + my $u = main::getModule('USER'); + my $tmpdir = $u->userTmp; + my $outfile = sprintf('%s/%s_%d.pod', $tmpdir, $modname, time); + + pod2html( + "--cachedir=$tmpdir", + "--infile=$podfile", + "--outfile=$outfile", + ); + return error('Problem to convert pod2html') + unless(-r $outfile); + + my $html = load_file($outfile); + $html = $1 if($html =~ /\<body.*?\>(.+?)\<\/body\>/si); + $obj->link({ + text => gettext("Back to configuration screen"), + url => $obj->{browser}->{Referer}, + }); + + $obj->message($html); +} + +# ------------------ +sub txtfile { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $filename = shift || return error ('No TxtFile to display!' ); + my $param = shift || {}; + + my $txtfile = sprintf('%s/%s.txt', $obj->{paths}->{DOCPATH}, $filename); + my $gzfile = sprintf('%s/%s.txt.gz', $obj->{paths}->{DOCPATH}, $filename); + + $txtfile = main::getModule('HTTPD')->unzip($gzfile) + if(! -r $txtfile and -r $gzfile); + + my $topic = gettext("File"); + + if($param->{'format'} eq 'txt') { + my $txt = load_file($txtfile); + return $obj->message($txt, {tags => {first => "$topic: $filename.txt"}}); + } + + my $u = main::getModule('USER'); + my $htmlfile = sprintf('%s/temp_txt.html', $u->userTmp); + + $obj->{txt2html}->txt2html( + infile=>[$txtfile], + outfile=>$htmlfile, + title=> $filename, + mail=>1, + ); + my $html = load_file($htmlfile); + $html = $1 if($html =~ /\<body.*?\>(.+?)\<\/body\>/si); + $obj->message($html, {tags => {first => "<h1>$topic: $filename.txt</h1>"}}); +} + +# ------------------ +sub typ { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{TYP}; +} + +# ------------------ +sub setCall { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return error ('No Name!' ); + + $obj->{call} = $name; + return $obj->{call}; +} + +# ------------------ +sub browser { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{browser}; +} + +# Special Version from Message (with error handling) +# ------------------ +sub msg { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || 0; + my $err = shift || 0; + + unless($err) { + $obj->message($data); + } else { + $obj->err($data || $err); + return undef; + } +} + +# ------------------ +sub parseData { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $dta = shift || return ''; + + if(ref $dta eq 'HASH') { + foreach my $name (keys %$dta) { + if(ref $dta->{$name}) { + $obj->parseData($dta->{$name}); + } else { + $dta->{$name} = reentities($dta->{$name}) if($obj->{hasentities}); + $dta->{$name} = entities($dta->{$name}); + } + } + } elsif (ref $dta eq 'ARRAY') { + foreach (@$dta) { + if(ref $_) { + $obj->parseData($_); + } else { + $_ = reentities($_) if($obj->{hasentities}); + $_ = entities($_); + } + } + } + $obj->{hasentities} = 1; + return $dta; +} + + +1; diff --git a/lib/XXV/OUTPUT/NEWS/JABBER.pm b/lib/XXV/OUTPUT/NEWS/JABBER.pm new file mode 100644 index 0000000..119f4c5 --- /dev/null +++ b/lib/XXV/OUTPUT/NEWS/JABBER.pm @@ -0,0 +1,296 @@ +package XXV::OUTPUT::NEWS::JABBER; +use strict; + +use Tools; +use POSIX qw(locale_h); +use Locale::gettext; + +# News Modules have only three methods +# init - for intervall or others +# send - send the informations +# read - read the news and parse it + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'NEWS::JABBER', + Prereq => { + 'Net::XMPP' => 'Jabber protocol for connect and send', + }, + Description => gettext(qq| +This NEWS module generate a Jabber messages for your jabber client. +If come a Message from xxv with a lever >= as Preferences::level then +will this module send this Message to your jabber account +(Preferences::receiveUser). + +The Problem xxv need a extra jabber account to allow to send messages in +the jabber network. This is very simple: + +=over 4 + +=item 1 Start your jabber client, may the exodus (http://exodus.jabberstudio.org/) + +=item 2 Create a new Profile with the name 'xxv' + +=item 3 In the next window input following things: + + - Jabber Id: newsxxv\@jabber.org (in Example!) + - Password: lalala (in Example!) + - save Password: yes + - new Account?: yes + +=back + +Thats all! + +If you want, you can test the connection to send a testmessage with +the following url in the Webinterface: + + http://vdr:8080/?cmd=request&data=jabber + +or Telnet Interface: + + XXV> request jabber + +Then you must receive a message in your running jabber client. + +|), + Version => '0.01', + Date => '31.09.2005', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'n', + type => 'confirm', + required => gettext('This is required!'), + check => sub { + my $value = shift; + my $erg = $obj->init + or return error('Problem to initialize news module') + if($value eq 'y' and not exists $obj->{JCON}); + return $value; + }, + }, + level => { + description => gettext('Minimum level of the messages which can be displayed (1 ... 100)'), + default => 1, + type => 'integer', + required => gettext('This is required!'), + check => sub { + my $value = int(shift) || 0; + unless($value >= 1 and $value <= 100) { + return undef, 'Sorry, but the value must be between 1 and 100'; + } + return $value; + }, + }, + receiveUser => { + description => gettext('User to advise (as Jabberaccount to@jabber.server.org)'), + default => '', + type => 'string', + required => gettext('This is required!'), + }, + user => { + description => gettext('Jabberaccount to send message (from@jabber.server.org)'), + default => '', + type => 'string', + required => gettext('This is required!'), + }, + passwd => { + description => gettext('Password from Jabberaccount'), + default => '', + type => 'password', + required => gettext('This is required!'), + check => sub{ + my $value = shift || return; + + return $value unless(ref $value eq 'ARRAY'); + + # If no password given the take the old password as default + if($value->[0] and $value->[0] ne $value->[1]) { + return undef, gettext("Field with 1st and 2nd password must be equal to confirm!"); + } else { + return $value->[0]; + } + }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # host + $self->{host} = delete $attr{'-host'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_} || $self->{MOD}->{Preferences}->{$_}->{default} + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{TYP} = 'text/plain'; + + # Initiat after load modules ... + main::after(sub{ + # The Initprocess + my $erg = $self->init + or return error('Problem to initialize news module'); + }, "NEWS::JABBER: Start initiate the Jabber module ...") + if($self->{active} eq 'y'); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $url = sprintf("http://%s:%s/", $obj->{host}, main::getModule('HTTPD')->{Port}); + + 1; +} + +# ------------------ +sub jconnect { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + my $jcon = Net::XMPP::Client->new( + debuglevel => 0, + ) || return error('Problem to create an Jabber Client'); + + my ($user, $server) = split('\@', $obj->{user}); + + debug ("Connecting to jabber server: %s ...", $server); + + my @res = $jcon->Connect( + hostname => $server, + ); + return + unless($obj->xmpp_check_result("Connect",\@res,$jcon)); + + debug ("Authentificat with User:%s ...", $user); + + @res = $jcon->AuthSend( + 'hostname'=>$server, + 'username'=>$user, + 'password'=>$obj->{passwd}, + 'resource'=>'xxv' + ); + + return $jcon + if($obj->xmpp_check_result("Login",\@res,$jcon)); +} + +# ------------------ +sub jdisconnect { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $cnx = shift || 0; + + $cnx->Disconnect() + if(ref $cnx); + + 1; +} + + +# ------------------ +sub send { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $vars = shift || return error ('No Vars!' ); + + return undef, lg('This function is deactivated!') + if($obj->{active} ne 'y'); + + my $cnx = $obj->jconnect() + || return error ('No connected JabberClient!' ); + + $cnx->MessageSend( + 'to' => $obj->{receiveUser}, + 'subject'=> $vars->{Title}, + 'body' => ($vars->{Text} || $vars->{Url}), + ); + + $cnx = $obj->jdisconnect($cnx); + + 1; +} + +# ------------------ +sub read { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $vars = shift || return error ('No News!' ); + + return $obj->send($vars); + + 1; +} + +# ------------------ +sub req { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return gettext('The Module NEWS::JABBER is not active!') + if($obj->{active} ne 'y'); + + my $vars = { + AddDate => time, + Title => 'This is a testmessage for NEWS::JABBER ...', + Text => "abcdefghijklmnopqrstuvwxyz\nABCDEFGHIJKLMNOPQRSTUVWXYZ\n0123456789\näüöÄÜÖ!@#$%^&*()_+=-':;<>?/\n", + Level => 100, + }; + + if($obj->send($vars)) { + return sprintf('Message is send to %s at %s', $obj->{receiveUser}, datum($vars->{AddDate}, 'voll')); + } else { + return sprintf('Upps, problem send Message to %s at %s', $obj->{receiveUser}, datum($vars->{AddDate}, 'voll')); + } +} + +# ------------------ +sub xmpp_check_result { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my ($txt,$res,$cnx)=@_; + + return error("Error '$txt': result undefined") + unless($res); + + # result can be true or 'ok' + if ((@$res == 1 && $$res[0]) || $$res[0] eq 'ok') { + return debug "%s: %s", $txt, $$res[0]; + # otherwise, there is some error + } else { + my $errmsg = $cnx->GetErrorCode() || '?'; + $cnx->Disconnect(); + return error("Error %s: %s [%s]", $txt, join (': ',@$res), $errmsg); + } +} + +1; diff --git a/lib/XXV/OUTPUT/NEWS/MAIL.pm b/lib/XXV/OUTPUT/NEWS/MAIL.pm new file mode 100644 index 0000000..5f91e05 --- /dev/null +++ b/lib/XXV/OUTPUT/NEWS/MAIL.pm @@ -0,0 +1,313 @@ +package XXV::OUTPUT::NEWS::MAIL; +use strict; + +use Tools; +use POSIX qw(locale_h); +use Locale::gettext; + +# News Modules have only this methods +# init - for intervall or others +# send - send the informations +# read - read the news and parse it +# req - read the actual news print this out + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'NEWS::MAIL', + Prereq => { + 'Mail::SendEasy' => 'Simple platform independent mailer', + }, + Description => gettext('This NEWS module generate mails for news.'), + Version => '0.01', + Date => '31.09.2005', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'n', + type => 'confirm', + required => gettext('This is required!'), + check => sub { + my $value = shift; + my $erg = $obj->init + or return error('Problem to initialize news module') + if($value eq 'y' and not exists $obj->{INITE}); + return $value; + }, + }, + level => { + description => gettext('Minimum level of the messages which can be displayed (1 ... 100)'), + default => 1, + type => 'integer', + required => gettext('This is required!'), + check => sub { + my $value = int(shift) || 0; + unless($value >= 1 and $value <= 100) { + return undef, 'Sorry, but the value must be between 1 and 100'; + } + return $value; + }, + }, + interval => { + description => gettext('Time in hours to send the next mail'), + default => 12, + type => 'integer', + required => gettext('This is required!'), + check => sub { + my $value = int(shift) || 0; + if($value and ref $obj->{INTERVAL}) { + my $newinterval = $value*3600; + $obj->{INTERVAL}->interval($newinterval); + } + return $value; + }, + }, + address => { + description => gettext('One or more mail addresses for sending the news'), + default => 'unknown@example.com, everybody@example.com', + type => 'string', + required => gettext('This is required!'), + }, + from_address => { + description => gettext('Mail address to senders describe.'), + default => 'xxv@vdr.de', + type => 'string', + }, + smtp => { + description => gettext('Hostname from SMTP mail server'), + default => main::getModule('STATUS')->name, + type => 'host', + required => gettext('This is required!'), + }, + susr => { + description => gettext('Username for mail server access'), + default => 'xxv', + type => 'string', + }, + spwd => { + description => gettext('Password for mail server access'), + default => 'xxv', + type => 'password', + check => sub{ + my $value = shift || return; + + return $value unless(ref $value eq 'ARRAY'); + + # If no password given the take the old password as default + if($value->[0] and $value->[0] ne $value->[1]) { + return undef, gettext("Field with 1st and 2nd password must be equal to confirm!"); + } else { + return $value->[0]; + } + }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # host + $self->{host} = delete $attr{'-host'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_} || $self->{MOD}->{Preferences}->{$_}->{default} + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + # create Template object + $self->{tt} = Template->new( + START_TAG => '\<\?\%', # Tagstyle + END_TAG => '\%\?\>', # Tagstyle + INTERPOLATE => 1, # expand "$var" in plain text + PRE_CHOMP => 1, # cleanup whitespace + EVAL_PERL => 1, # evaluate Perl code blocks + ABSOLUTE => 1, + ); + + my @tmplfiles = glob( + sprintf('%s/%s_*.tmpl', + $self->{paths}->{NEWSTMPL}, + lc((split('::', $self->{MOD}->{Name}))[-1]) + ) + ); + for (@tmplfiles) { + my ($order, $typ) = $_ =~ /_(\d+)_(\S+)\.tmpl$/si; + $self->{TEMPLATES}->{$typ} = $_; + } + + # The Initprocess + my $erg = $self->init + or return error('Problem to initialize news module') + if($self->{active} eq 'y'); + + $self->{TYP} = 'text/plain'; + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{INITE} = 1; + + $obj->{LastReportTime} = time; + + # Interval to send the next mail + $obj->{INTERVAL} = Event->timer( + interval => $obj->{interval}*3600, + prio => 6, # -1 very hard ... 6 very low + cb => sub{ + $obj->send(); + }, + ); + + $obj->{COUNT} = 1; + + 1; +} + +# ------------------ +sub send { +# ------------------ + my $obj = shift || return error ('No Object!' ); + + return error('This function is deactivated!') + if($obj->{active} ne 'y'); + + ++$obj->{COUNT}; + + my $content = $obj->req(); + + my $smod = main::getModule('STATUS'); + my @addresses = split(/\s*,\s*/, $obj->{address}); + + # Send mail + my $status = Mail::SendEasy::send( + smtp => $obj->{smtp}, + user => $obj->{susr}, + pass => $obj->{spwd}, + from => $obj->{from_address}, + from_title => 'XXV MailNewsAgent', + to => shift @addresses , + cc => join(',', @addresses), + subject => "News from your XXV System!" , + msg => $content, + msgid => $obj->{COUNT}, + ) || return error('Problem to send Mail: %s', $Mail::SendEasy::ER); + + $obj->{LastReportTime} = time; + + lg sprintf('News Mail with nr. %d successfully send at %s', $obj->{COUNT}, scalar localtime); + $obj->{NEWSLETTER} = undef; + 1; +} + +# ------------------ +sub parseHeader { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $output = ''; + + my $vars = { + msgnr => $obj->{COUNT}, + date => datum(time, 'voll'), + anzahl=> $obj->{NEWSCOUNT}, + }; + + my $template = $obj->{TEMPLATES}->{'header'}; + $obj->{tt}->process($template, $vars, \$output) + or return error($obj->{tt}->error()); + + return $output; +} + +# ------------------ +sub parseFooter { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $output = ''; + + + my $vars = { + usage => main::getModule('RECORDS')->{CapacityMessage}, + uptime => main::getModule('STATUS')->uptime, + lastreport => datum($obj->{LastReportTime}, 'voll'), + }; + + my $template = $obj->{TEMPLATES}->{'footer'}; + $obj->{tt}->process($template, $vars, \$output) + or return error($obj->{tt}->error()); + + return $output; +} + + +# ------------------ +sub read { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $vars = shift || return error ('No News!' ); + + my $output = ''; + $vars->{count} = ++$obj->{NEWSCOUNT}; + $vars->{host} = $obj->{host}; + $vars->{port} = main::getModule('HTTPD')->{Port}; + + my $template = $obj->{TEMPLATES}->{'content'}; + $obj->{tt}->process($template, $vars, \$output) + or return error($obj->{tt}->error()); + + $obj->{NEWSLETTER} .= $output; + + return $output; +} + +# ------------------ +sub req { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $test = shift || 0; + + return gettext('The Module NEWS::Mail is not active!') + if($obj->{active} ne 'y'); + + my $content = ''; + if($test) { + $obj->send; + $content .= gettext('A mail with the following content is send to your Mailaccount!'); + $content .= "\n\n"; + } + + $content .= $obj->parseHeader(); + $content .= $obj->{NEWSLETTER}; + $content .= $obj->parseFooter(); + + return $content; +} + + +1; diff --git a/lib/XXV/OUTPUT/NEWS/RSS.pm b/lib/XXV/OUTPUT/NEWS/RSS.pm new file mode 100644 index 0000000..82cdbd4 --- /dev/null +++ b/lib/XXV/OUTPUT/NEWS/RSS.pm @@ -0,0 +1,233 @@ +package XXV::OUTPUT::NEWS::RSS; +use strict; + +use Tools; +use POSIX qw(locale_h); +use Locale::gettext; + +# News Modules have only three methods +# init - for intervall or others +# send - send the informations +# read - read the news and parse it + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'NEWS::RSS', + Prereq => { + 'XML::RSS' => 'SMTP Protocol module to connect and send emails', + }, + Description => gettext('This NEWS module generate an RSS Newsfeed for your rss reader.'), + Version => '0.01', + Date => '31.09.2005', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'y', + type => 'confirm', + required => gettext('This is required!'), + check => sub { + my $value = shift; + my $erg = $obj->init + or return error('Problem to initialize news module') + if($value eq 'y' and not exists $obj->{INITE}); + return $value; + }, + }, + level => { + description => gettext('Minimum level of the messages which can be displayed (1 ... 100)'), + default => 1, + type => 'integer', + required => gettext('This is required!'), + check => sub { + my $value = int(shift) || 0; + unless($value >= 1 and $value <= 100) { + return undef, 'Sorry, but the value must be between 1 and 100'; + } + return $value; + }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # host + $self->{host} = delete $attr{'-host'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_} || $self->{MOD}->{Preferences}->{$_}->{default} + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{TYP} = 'application/xhtml+xml'; + + # Initiat after load modules ... + main::after(sub{ + # The Initprocess + my $erg = $self->init + or return error('Problem to initialize News Module'); + }, "NEWS::RSS: Start initiate the RSS Feed ...") + if($self->{active} eq 'y'); + + + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + $obj->{INITE} = 1; + + 1; +} + +# ------------------ +sub createRSS { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $ver = shift || 1; + my $account = sprintf("%s@%s", $ENV{USER}, main::getModule('STATUS')->name); + my $url = sprintf("http://%s:%s/", $obj->{host}, main::getModule('HTTPD')->{Port}); + + my $rss; + if($ver == 1) { + $rss = XML::RSS->new( + version => '1.0', + ) || return error('Problem to create an RSS Object'); + + + $rss->channel( + title => gettext("XXV RSS 1.0"), + 'link' => $url, + description => gettext("Important messages from your vdr/xxv"), + dc => { + date => datum(time,'int'), + subject => gettext("XXV Messages"), + creator => $account, + language => setlocale(POSIX::LC_MESSAGES), + }, + syn => { + updatePeriod => "hourly", + updateFrequency => "1", + updateBase => datum(time, 'int'), + }, + ); + + } elsif($ver == 2) { + my $lastbuild = (exists $obj->{lastBuildDate} ? $obj->{lastBuildDate} : time); + + $rss = XML::RSS->new( + version => '2.0', + ) || return error('Problem to create an RSS Object'); + + $rss->channel( + title => gettext("XXV RSS 2.0"), + 'link' => $url, + description => gettext("Important messages from your vdr/xxv"), + language => setlocale(POSIX::LC_MESSAGES), + pubDate => datum(time, 'rss'), + lastBuildDate => datum($lastbuild, 'rss'), + managingEditor => $account, + ); + } + $obj->{lastBuildDate} = time; + + return $rss; +} + + +# ------------------ +sub send { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $vars = shift || return error ('No Vars!' ); + + ++$obj->{COUNT}; + + push(@{$obj->{STACK}}, [ + entities($vars->{Title}), + entities($vars->{Url}), + entities($vars->{Text}), + datum($vars->{AddDate},'int'), + $vars->{LevelName}, + ]); + + lg sprintf('News RSS with nr. %d successfully send at %s', $obj->{COUNT}, scalar localtime); + 1; +} + +# ------------------ +sub read { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $vars = shift || return error ('No News!' ); + + return undef, lg('This function is deactivated!') + if($obj->{active} ne 'y'); + + + $vars->{count} = ++$obj->{NEWSCOUNT}; + $vars->{host} = $obj->{host}; + $vars->{port} = main::getModule('HTTPD')->{Port}; + + $obj->send($vars); + + return 1; +} + +# ------------------ +sub req { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $params = shift || {}; + + return gettext('The Module NEWS::RSS is not active!') + if($obj->{active} ne 'y'); + + my $rss = $obj->createRSS($params->{version}) + || return error('Problem to create a RSS Object!'); + + foreach my $entry (@{$obj->{STACK}}) { + my ($title, $link, $descr, $adddate, $level) = @{$entry}; + $rss->add_item( + title => $title, + link => $link, + description => $descr, + dc => { + date => $adddate, + subject => $level + }, + ); + } + + return $rss->as_string; +} + + +1; diff --git a/lib/XXV/OUTPUT/NEWS/VDR.pm b/lib/XXV/OUTPUT/NEWS/VDR.pm new file mode 100644 index 0000000..9f56793 --- /dev/null +++ b/lib/XXV/OUTPUT/NEWS/VDR.pm @@ -0,0 +1,165 @@ +package XXV::OUTPUT::NEWS::VDR; +use strict; + +use Tools; +use POSIX qw(locale_h); +use Locale::gettext; + +# News Modules have only three methods +# init - for intervall or others +# send - send the informations +# read - read the news and parse it + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'NEWS::VDR', + Description => gettext('This NEWS module generate a messages for vdr interface.'), + Version => '0.01', + Date => '31.09.2005', + Author => 'xpix', + Preferences => { + active => { + description => gettext('Activate this service'), + default => 'n', + type => 'confirm', + required => gettext('This is required!'), + check => sub { + my $value = shift; + my $erg = $obj->init + or return error('Problem to initialize news module') + if($value eq 'y' and not exists $obj->{INITE}); + return $value; + }, + }, + level => { + description => gettext('Minimum level of the messages which can be displayed (1 ... 100)'), + default => 1, + type => 'integer', + required => gettext('This is required!'), + check => sub { + my $value = int(shift) || 0; + unless($value >= 1 and $value <= 100) { + return undef, 'Sorry, but the value must be between 1 and 100'; + } + return $value; + }, + }, + }, + }; + return $args; +} + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # paths + $self->{paths} = delete $attr{'-paths'}; + + # host + $self->{host} = delete $attr{'-host'}; + + # who am I + $self->{MOD} = $self->module; + + # all configvalues to $self without parents (important for ConfigModule) + map { + $self->{$_} = $attr{'-config'}->{$self->{MOD}->{Name}}->{$_} || $self->{MOD}->{Preferences}->{$_}->{default} + } keys %{$self->{MOD}->{Preferences}}; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{TYP} = 'text/plain'; + + # Initiat after load modules ... + main::after(sub{ + # The Initprocess + my $erg = $self->init + or return error('Problem to initialize news module'); + }, "NEWS::VDR: Start initiate the News vdr module ...") + if($self->{active} eq 'y'); + + return $self; +} + +# ------------------ +sub init { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $url = sprintf("http://%s:%s/", $obj->{host}, main::getModule('HTTPD')->{Port}); + $obj->{INITE} = 1; + + $obj->{SVDRP} = main::getModule('SVDRP'); + + 1; +} + +# ------------------ +sub send { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $vars = shift || return error ('No Vars!' ); + + return undef, lg('This function is deactivated!') + if($obj->{active} ne 'y'); + + return undef, lg('Title is not set!') + unless($vars->{Title}); + + + my $cmd = sprintf('MESG %s', $vars->{Title}); + + my $svdrp = $obj->{SVDRP} || return error ('No SVDRP!' ); + $svdrp->command($cmd); + + 1; +} + +# ------------------ +sub read { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $vars = shift || return error ('No News!' ); + + return $obj->send($vars); + + 1; +} + +# ------------------ +sub req { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $test = shift || 0; + + return gettext('The Module NEWS::VDR is not active!') + if($obj->{active} ne 'y'); + + my $vars = { + AddDate => time, + Title => 'This is only a Test for the xxv news vdr module!', + Text => 'This is only a Test for the xxv news vdr module!', + Cmd => 'request', + Id => 'vdr', + Url => sprintf("http://%s:%s/", $obj->{host}, main::getModule('HTTPD')->{Port}), + Level => 'harmless', + }; + $obj->read($vars); + + return gettext('A message is send to your SVDRPServer!'); + +} + + +1; diff --git a/lib/XXV/OUTPUT/Wml.pm b/lib/XXV/OUTPUT/Wml.pm new file mode 100644 index 0000000..fc110c2 --- /dev/null +++ b/lib/XXV/OUTPUT/Wml.pm @@ -0,0 +1,431 @@ +package XXV::OUTPUT::Wml; + +use strict; + +use vars qw($AUTOLOAD); +use Locale::gettext; +use Tools; +use File::Path; +use Pod::Html; + +# This module method must exist for XXV +# ------------------ +sub module { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $args = { + Name => 'Wml', + Prereq => { + 'Template' => 'Front-end module to the Template Toolkit ', + }, + Description => gettext('This receive and send Wap messages.'), + Version => '0.01', + Date => '27.10.2004', + Author => 'xpix', + }; + return $args; +} + +# ------------------ +sub AUTOLOAD { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || {}; + my $params = shift || 0; + + my $name = (split('::', $AUTOLOAD))[-1]; + return if($name eq 'DESTROY'); + + my $output = $obj->parseTemplate($name, $data, $params); + + $obj->out( $output ); + + $obj->{call} = ''; +} + + +# ------------------ +sub new { +# ------------------ + my($class, %attr) = @_; + my $self = {}; + bless($self, $class); + + # who am I + $self->{MOD} = $self->module; + + # Try to use the Requirments + map { + eval "use $_"; + return panic("\nCan not load Module: $_\nPlease install this module on your System:\nperl -MCPAN -e 'install $_'") if($@); + } keys %{$self->{MOD}->{Prereq}}; + + $self->{handle} = $attr{'-handle'} + || return error('No handle defined!'); + + $self->{paths} = $attr{'-paths'} + || return error('No Paths defined!'); + + $self->{dbh} = $attr{'-dbh'} + || return error('No DBH defined!'); + + $self->{wmldir} = $attr{'-wmldir'} + || return error('No wmldir given!'); + + $self->{cgi} = $attr{'-cgi'} + || return error('No TemplateDir given!'); + + $self->{mime} = $attr{'-mime'} + || return error('No Mimehash given!'); + + $self->{browser} = $attr{'-browser'} + || return error('No Mimehash given!'); + +# $self->{start} = $attr{'-start'} +# || return error('No StartPage given!'); + + $self->{TYP} = 'WML'; + + eval "use Template::Stash::XS"; + $Template::Config::STASH = 'Template::Stash::XS' unless($@); + + # create Template object + $self->{tt} = Template->new( + START_TAG => '\<\?\%', # Tagstyle + END_TAG => '\%\?\>', # Tagstyle + INCLUDE_PATH => $self->{wmldir}, # or list ref + INTERPOLATE => 1, # expand "$var" in plain text + PRE_CHOMP => 1, # cleanup whitespace + EVAL_PERL => 1, # evaluate Perl code blocks + ); + + return $self; +} + +# ------------------ +sub parseTemplate { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return error ('No Name!' ); + my $data = shift || return error ('No Data!' ); + my $params = shift || {}; + + my $t = $obj->{tt}; + my $u = main::getModule('USER'); + + # you can use two templates, first is a user defined template + # and second the standard template + # i.e. call the htmlhelp command the htmlhelp.tmpl + # SpecialTemplate: ./wmlRoot/usage.tmpl + # StandardTemplate: ./wmlRoot/widgets/menu.tmpl + my $widget_first = sprintf('%s.tmpl', (exists $obj->{call}) ? $obj->{call} : 'nothing'); + my $widget_second = sprintf('widgets/%s.tmpl', $name); + my $widget = (-e sprintf('%s/%s', $obj->{wmldir}, $widget_first) ? $widget_first : $widget_second); + my $user = ($u->{active} eq 'y' && $obj->{USER}->{Name} ? $obj->{USER}->{Name} : "nobody" ); + my $output; + my $vars = { + cgi => $obj->{cgi}, + call => $name, + data => $data, + type => ref $data, + info => $obj->browser, + param => $params, + pid => $$, + debug => 1, + user => $user, + allow => sub{ + my($cmdobj, $cmdname, $se, $err) = $u->checkCommand($obj, $_[0],"1"); + return 1 if($cmdobj); + }, + basedir => $obj->{wmldir}, + entities => sub{ return entities($_[0]) }, + # translate string, usage : gettext(foo,truncate) or gettext(foo) + # value for truncate are optional + gettext => sub{ + my $t = gettext($_[0]); + $t = substr($t,0,$_[1]) . "..." + if(defined $_[1] && length($t)>$_[1]); + return entities($t); + }, + version => sub{ return main::getVersion }, + loadfile => sub{ return load_file(@_) }, + writefile => sub{ + my $filename = shift || return error('No Filename to write'); + my $data = shift || return error('Nothing data to write'); + + my $dir = $u->userTmp; + + # absolut Path to file + my $file = sprintf('%s/%s', $dir, $filename); + # absolut Path to file + if(save_file($file, $data)) { + # return the relative Path + my ($relpath) = $file =~ '/(.+?/.+?)$'; + return sprintf('tempimages/%s', $filename); + } + }, + }; + $t->process($widget, $vars, \$output) + or return error($t->error()); + + return $output; +} + +# ------------------ +sub out { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $text = shift || 'no Text for Output'; + my $type = shift || 'text/vnd.wap.wml'; + my %args = @_; + + my $q = $obj->{cgi}; + unless(defined $obj->{header}) { + # HTTP Header + $obj->{handle}->print( + $obj->header($type, \%args) + ); + } + + $obj->{handle}->print( $text,"\r\n" ); +} + +# ------------------ +sub header { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $typ = shift || return error ('No Type!' ); + my $arg = shift || {}; + + $obj->{header} = 1; + return $obj->{cgi}->header( + -type => $typ, + -status => "200 OK", + -expires => ($typ =~ 'text/vnd.wap.wml' || (defined $obj->{nocache} && $obj->{nocache})) ? "now" : "+12h", + %{$arg}, + ); +} + +# ------------------ +sub statusmsg { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $msg = shift || return error ('No Msg!'); + my $status = shift || return error ('No Status!'); + + unless(defined $obj->{header}) { + $obj->{nopack} = 1; + $obj->{header} = 1; + my $data = $obj->{cgi}->header( + -type => 'text/vnd.wap.wml', + -status => $status, + -expires => "now", + ); + $obj->out($data); + } + + my @title = split ('\n', $status); + $obj->start(undef,{ title => $title[0] }); + $obj->err($msg); + $obj->footer(); +} + +# ------------------ +# Send HTTP Status 401 (Authorization Required) +sub login { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $msg = shift || ''; + + $obj->statusmsg($msg,"401 Authorization Required\nWWW-Authenticate: Basic realm=\"xxvd\""); +} + +# ------------------ +# Send HTTP Status 403 (Access Forbidden) +sub status403 { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $msg = shift || ''; + + $obj->statusmsg($msg,"403 Forbidden"); +} + + +# ------------------ +# Send HTTP Status 404 (File not found) +sub status404 { +# ------------------ + my $obj = shift || return error ('No Object!'); + my $file = shift || return error ('No File!'); + my $why = shift || ""; + + warn("I can't read file $file"); + + $file =~ s/$obj->{wmldir}\///g; # Don't post wml root, avoid spy out + + $obj->statusmsg(sprintf(gettext("Can't open file '%s' : %s"),$file,$why),"404 File not found"); +} + +# ------------------ +sub question { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $titel = shift || 'undef'; + my $questions = shift || return error ('No Data!' ); + my $erg = shift || 0; + + my $q = $obj->{cgi}; + my $quest; + + # Check Data + if(ref $erg eq 'HASH' and ref $questions eq 'ARRAY' and exists $erg->{action}) { + my $error; + @$quest = @$questions; + while (my ($name, $data) = splice(@$quest, 0, 2)) { + # Required value ... + $error = $data->{req} + if($data->{req} and not $erg->{$name}); + + # Check Callback + if(exists $data->{check} and ref $data->{check} eq 'CODE' and not $error) { + ($erg->{$name}, $error) = $data->{check}($erg->{$name}, $data); + } + + # Check on directory + if($data->{typ} eq 'dir' and $data->{required} and not -d $erg->{$name}) { + ($erg->{$name}, $error) = (undef, sprintf(gettext("Directory '%s' is doesn't exist!"), $erg->{$name})); + } + + # Check on file + if($data->{typ} eq 'file' and $data->{required} and not -e $erg->{$name}) { + ($erg->{$name}, $error) = (undef, sprintf(gettext("File '%s' is doesn't exist!"), $erg->{$name})); + } + + if($error) { + $obj->err(sprintf(gettext("Error at field '%s' (%s) : %s"), $data->{msg}, $name, $error)); + last; + } + } + unless($error) { + delete $erg->{action}; + return $erg; + } + } + + $obj->formStart($titel); + if(ref $questions eq 'ARRAY') { + my $q = $obj->{cgi}; + @$quest = @$questions; + while (my ($name, $data) = splice(@$quest, 0, 2)) { + my $type = delete $data->{typ}; + $data->{msg} =~ s/\n/<br \/>/sig if($data->{msg}); + $data->{NAME} = '__'.$name; + $type ||= 'string'; + $obj->$type($data); + } + } else { + my $type = delete $questions->{typ}; + $questions->{NAME} = '__'.$type; + $type ||= 'string'; + $obj->$type($questions); + } + $obj->formEnd; + return undef; +} + +# ------------------ +sub image { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $file = shift || return error ('No File!' ); + my $typ = shift || $obj->{mime}->{lc((split('\.', $file))[-1])} + or return error("No Type in Mimehash or File: $file"); + + my $data = load_file($file) + or return $obj->status404($file,$!); + + $obj->out($data, $typ); +} + +# ------------------ +sub datei { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $file = shift || return error ('No File!' ); + + my $data = load_file($file) + or return $obj->status404($file,$!); + + $obj->out($data, 'text/vnd.wap.wml'); +} + +# ------------------ +sub pod { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $modname = shift || return error ('No Modname!' ); + $modname = ucfirst($modname) if($modname eq 'GENERAL'); + + my $podfile = sprintf('%s/%s.pod', $obj->{paths}->{PODPATH}, $modname); + my $tmpdir = main::getModule('USER')->userTmp; + my $outfile = sprintf('%s/%s_%d.pod', $tmpdir, $modname, time); + + pod2html( + "--cachedir=$tmpdir", + "--infile=$podfile", + "--outfile=$outfile", + ); + return error('Problem to convert pod2html') + unless(-r $outfile); + + my $html = load_file($outfile); + $html = $1 if($html =~ /\<body.*?\>(.+?)\<\/body\>/si); + $obj->link({ + text => gettext("Back to configuration screen"), + url => $obj->{browser}->{Referer}, + }); + $obj->message($html); +} + +# ------------------ +sub typ { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{TYP}; +} + +# ------------------ +sub setCall { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $name = shift || return error ('No Name!' ); + + $obj->{call} = $name; + return $obj->{call}; +} + +# ------------------ +sub browser { +# ------------------ + my $obj = shift || return error ('No Object!' ); + return $obj->{browser}; +} + +# Special Version from Message (with error handling) +# ------------------ +sub msg { +# ------------------ + my $obj = shift || return error ('No Object!' ); + my $data = shift || {}; + my $err = shift; + + unless($err) { + $obj->message($data); + } else { + $obj->err($data); + } +} + + + +1; |