pDLNA/0000700000175000017500000000000013366532501010724 5ustar geumageumapDLNA/CHANGELOG0000700000175000017500000004755613366532501012162 0ustar geumageumapDLNA CHANGELOG (c) 2010-2018 Stefan Heumader-Rainer email: stefan@heumader.at webpage: https://www.pdlna.org Licened under GPLv3 (see LICENSE file) ----------------------------------------- Version 0.70.2 01-11-2018 - fixed a typo in PDLNA::Status::check_update function - fixed bugs related to delivering CSS and JS files for the WebUI - updated external links to use HTTPS instead of HTTP - WebUI has a favicon - updated copyright year Version 0.70.1 06-01-2015 - fixed a bug regarding getting the correct modelName for a specific DLNA device - updated copyright year Version 0.70.0 16-08-2014 - added the name and line of the file, which called the fatal() or log() subroutine, to the log messages (based on the idea of marc) - added LogFileRotation configuration parameter, so pDLNA is now able to rotate logfiles on his own (based on the idea of marc) - added masking special characters in WebUI - moved WebUI to UTF-8 - fixed a bug in WebUI regarding uninitialized values in WebUI (thanks to marc) - additional fix for issue #21 (https://github.com/geuma/pDLNA/issues/21) -aka- special characters in filenames break some regular expressions (thanks to marc) - the Yamaha RX-V3067 seems to use a different XML structure (implemented a more generic way to find elements in XML) (thanks to marc) - added codec information for DTS sound - improved codec and container detection via FFmpeg - new database schema (includes performance and various other improvements) - added support for PostgreSQL - fixed issue #25 (https://github.com/geuma/pDLNA/issues/25) -aka- invalid BrowseMetadata response - added EnableDBStatistics configuration parameter (NOT FOR PRODUCTIVE ENVIRONMENT) - REMOVED transcoding support (will be reimplemented) Version 0.64.3 29-12-2013 - modified WebUI to open Changelog link to project website in a new browser tab/window - improved regular expression to determine valid FFmpeg installations (thanks to marc) - added encoding of special characters in XML Version 0.64.2 09-12-2013 - modified domain from pdlna.com to pdlna.org - fixed issue #24 (https://github.com/geuma/pDLNA/issues/24) -aka- directory listings not working, when data fields not set Version 0.64.1 25-11-2013 - fixed issue #23 (https://github.com/geuma/pDLNA/issues/23) -aka- removed using old dependency Movie::Info from PDLNA::Media Version 0.64.0 03-11-2013 - moved from Movie::Info to using FFmpeg natively to determine media information (based on the idea of lombao) - using FFmpeg instead of Mplayer to create VideoThumbnails - using FFmpeg instead of Mplayer to gather media streams - added default values for FILEINFO database and increased PROGRAM_DBVERSION - indexing files is now about 4 to 5 times faster (by disabling AutoCommit) - storing media information is now 0.5 times faster (by disabling AutoCommit) - added support for MySQL - added amount of directories to WebUI - added $VERSION, $HOSTNAME and $OS variables to the FriendlyName configuration - fixed issue #21 (https://github.com/geuma/pDLNA/issues/21) -aka- special characters in filenames break some regular expressions (under some circumstances) - improved handling of ExcludedItems configuration parameter - directories with no subdirectories or subfiles will be deleted from ContentLibrary - Length of all Media Items in WebUI will only be shown when LowResourceMode is disabled - added FFmpeg information to WebUI to provide easier access to Transcoding possibilities Version 0.63.0 08-07-2013 - removed Devel::Size Perl module from dependencies - added a new DBVERSION meta-information to database - it allows pDLNA to only recreate the database if a new version of pDLNA comes with a new database structure (not every time a new version of pDLNA is installed) - improved check to detect valid Mplayer installation (since Mplayer seems to change the location of the Mplayer string often) (thanks to lombao) - enabled EnableGeneralStatistics feature for FreeBSD and readded process information on FreeBSD in the WebUI - improved error handling in database module - error log messages will get LogLevel 0 and will always be logged (changed LogLevel in various error messages over some Perl Modules) - fixed a bug regarding the ConnectionManager HTTP response (thanks to lombao) - moved from Ogg::Vorbis::Header to Ogg::Vorbis::Header::PurePerl and finally added code for tags from ogg files - moved (again) from Net::Interface to IO::Interface (thx to shantanubhadoria) (issue #17) - removed usage of Net::Address::Ethernet (handled by IO::Interface too) - fixed a bug regarding delivering preview images - moved from Digest::SHA1 to Digest::SHA and improved the PDLNA::Utils::get_randid function by using timestamp with milliseconds Version 0.62.0 05-05-2013 - fixed issue #13 (https://github.com/geuma/pDLNA/issues/13) -aka- uninitialized value $request_line - added support for transcoding all supported types of audio files to WMAv1 - added code to remove newly added ExcludeDirs and ExcludeItems from ContentLibrary - added execution time to SQL query logging - added configuration option EnableGeneralStatistics and code to gather statistics (memory usage, media items) every minute and added graphs in WebUI for the EnableGeneralStatistics configuration parameter (currently not available on FreeBSD) - modified Check4Updates LogCategory to default, since LogCategory update was not available at all - fixed a bug regarding UPnP Services, where only one service is available (PDLNA::Devices) - FunFeature: added configuration option Check4UpdatesNotification: a message to a connected urn:samsung.com:serviceId:MessageBoxService service will be sent if a new version of pDLNA is available (if Check4Updates is enabled) - some general improvements regarding database connections, which lowers memory consumption Version 0.61.0 07-03-2013 - fixed issue #7 (https://github.com/geuma/pDLNA/issues/7) -aka- Uninitialized value in SSDP.pm - reworked/improved the code for parsing received SSDP messages - PDLNA::DeviceList object has been moved to database (feature/issue #11 (https://github.com/geuma/pDLNA/issues/11)) - added a Check4Updates button to the WebUI (feature/issue #12 (https://github.com/geuma/pDLNA/issues/12)) - added transcoding LogCategory for information about the Transcoding Profile selection - changed way of configuring Transcoding Profiles - fixed a bug regarding not-mplayer-info-data in media library database - transcoding audio files to aac, ac3, flac, mp3, vorbis, wav and wmav2 is now available - added support for wmav1 encoded audio files - some minor changes to the directory listing code - fix/workaround for issue #4 (auto detection on FreeBSD) - Net::Interface might have problems to find the matching interface sometimes - added more information to WebUI - fixed a bug regarding escaping brackets in directory names Version 0.60.1 14-02-2013 - fixed issue #8 (https://github.com/geuma/pDLNA/issues/8) -aka- database preparation problem Version 0.60.0 13-02-2013 - using a database instead of the whole huge in memory object for the ContentLibrary - fixed issue #6 (https://github.com/geuma/pDLNA/issues/6) -aka- the default size for the logfile rotation - updated copyright year - added even more information to the WebUI - external media items are shown in WebUI too - transcoding is now avaiable to be configured per client seperately - added the configuration option TempDir in configuration file to configure the directory for temporary files Version 0.53.0 15-08-2012 - added LowResourceMode configuration parameter for small devices like NAS and so on, audio and video files will not be openend and analyzed via Mplayer - added some general functions to Content object for calculation total indexed amount of files, their size and the total indexing time - changed the webgui's URL to http://IP:HTTPPort/webui/ and renamed the perl module itself too - changed check for Mplayer - it is necessary when LowResourceMode is disabled and/or VideoThumbnails is enabled - changed check for FFmpeg - it is necessary when TranscodingProfiles are configured Version 0.52.0 05-08-2012 - fixed a small typo in INSTALL file, thanks to CrisAnderson - rewrote a lot of PDLNA::DeviceList database stuff for storing more informations about the devices to maintain better compatibility and features in the future (added PDLNA::DeviceUDN, PDLNA::DeviceService and PDLNA::DeviceServiceAction Perl modules) - added manufacturerURL for DeviceDescription XML Version 0.51.2 21-07-2012 - improved regex to detect valid FFmpeg installation - added some additional media formats to PDLNA::Media perl module - improved regex to detect VLC version 2.0 - added SIZE to ContentDirectory Object, which is the size of all included items - improved WebUI (more beautiful listings) - added connected devices information to WebUI - added some general process statistics to WebUI - removed transcoding profile from default configuration file Version 0.51.1 31-05-2012 - added halfdaily configuration parameter for RescanMediaInterval - added some additional media formats to PDLNA::Media perl module Version 0.51.0 16-May-2012 - added support for additional playlist files (audio/x-ms-asx, video/x-ms-asf, application/xspf+xml) - fixed a bug regarding ignoring SSDP messages from not allowed clients - added configuration parameter RescanMediaInterval to define, when pDLNA should rebuild the media database - expired devices will be deleted from PDLNA::DeviceList database - the running pDLNA installation will not be added to the PDLNA::DeviceList database Version 0.50.0 28-Mar-2012 - added support for video/x-theora+ogg, audio/x-wav, audio/ac3, audio/x-aiff and video/x-flv Mime-Types - removed PDLNA::ContentExternal Perl Module and integrated external scripts into PDLNA::ContentItem Perl Modul - modified configuring External blocks (see sample configuration or configuration guide) - added configuring network streams in External blocks (StreamingURL) - refractured PDLNA::HTTPServer::stream_media() function - added FFmpegBinaryPath configuration parameter for path to installed FFmpeg binary - added Transcoding Profiles for audio files (see configuration guide for supported profiles) - added support for network streams as elements of Playlist files - added dummy responses for GetSearchCapabilities, GetSortCapabilities and GetSystemUpdateID SOAP requests - added checking for valid MPlayer and FFmpeg installation - added generation of DLNA contentfeature parameter Version 0.46.0 13-Mar-2012 - added UUID configuration parameter for choosing method to generate UUID - fixed a bug ignoring lost+found directories - added support for .srt subtitle files (SubRip or application/x-subrip) for Samsung TV - improvements to DirectoryListings (interpreting some of the filters) - PROGRAM_BETA to CONFIG hash and print_version() to PDLNA::Config module - changed default value for EnableImageThumbnails from enabled to disabled to be conform to EnableVideoThumbnails - default value for AllowedClients is set to the local subnet - fixed a bug regarding default value for LogFileMaxSize Version 0.45.0 19-Jan-2012 - thumbnails for external content are disabled - added AllowPlaylists configuration parameter for Directory configuration block - added support for Playlists (audio/x-scpls and audio/x-mpegurl) with local files - added LogFileMaxSize configuration parameter for rotating the logfile - fixed a bug (Device.pm line 139) regarding missing response content - fixed a bug regarding the validation of the CacheControl configuration parameter - added support for logging to syslog (SYSLOG option of LogFile configuration parameter) - added configuration parameter DateFormat to define date format in logging, debug output and library - changes to PDLNA::Library.pm HTML code Version 0.44.1 11-Jan-2012 - improved and fixed some bugs in the installation script - fixed a bug in ContentItem.pm: parent_id() function return {PARENT_ID} value instead of {DATE} value - fixed a similar bug in ContentDirectory.pm regarding the parent_id() function - added history for DirectoryListings to PDLNA::Device object - fixed a problem regarding the different duration notations of audio and video files - added support for audio mime-types: audio/x-flac - fixed 'Upper Folder' problem with Samsung TV (handling @parentID filter value in XML request) - small bugfixes regarding external media items (merged https://github.com/jjYBdx4IL/pDLNA/commit/557c692480fc3dfeb6f20d56997e6d41712c4136 by jjYBdx4IL) - small changes in documentation regarding external media items (merged https://github.com/jjYBdx4IL/pDLNA/commit/75220bec5e05fcd83664a92cd9a0a45612862988 by jjYBdx4IL) - added AudioCodec and VideoCodec to ContentItem - this information might be relevant for transcoding issues Version 0.44.0 04-Jan-2012 - changed ContentItem detection from file extension to mime type - PDLNA::Device.pm improvements regarding fetching the XML description (just once and not our own) - items are sorted in directory listing - added support for the following image mime-types: image/gif - added support for the following audio mime-types: audio/mp4, audio/x-ms-wma - added support for the following video mime-types: video/mp4, video/mpeg - fixed 'die' in line 809 of PDLNA::HTTPServer package - updated copyright year Version 0.43.0 30-Dec-2011 - added MKV video streaming support - modified PDLNA::DeviceList and PDLNA::Device to be shared among different threads - added PDLNA::DeviceList to PDLNA::HTTPServer thread to detect device type for Samsung specific Mime-Type of MKV files (video/x-mkv instead of video/x-matrovska) - added ExcludeDirs and ExcludeItems to define specific directories or items to be added to the ContentLibrary - modified binary configuration by enabling different values in the conifguration file (1, on, true, enable, enabled, yes) - another small change to initscript and install.pl to execute initscript directly from git repo - added function model_name() to PDLNA::Device.pm, which gets the XML description from a UPnP device and reads in the modelName Version 0.42.0 28-Dec-2011 - added support for external streaming sources (e.g. VDR-Streamer - see https://github.com/jjYBdx4IL/VDR-Streamer) (thanks to jjYBdx4IL) - added full streaming functionality (tested with Samsung LED TV (UE40B8090)) (thanks to jjYBdx4IL again) - reformated jjYBdx4IL code to match coding style and readded configuration support via BufferSize - added error handling for missing MPlayer and fixed a bug regarding duration of videos - adapted install.pl for external streaming scripts - added VERSION file - added TODO list to GIT repo - solved issue #1 (https://github.com/geuma/pDLNA/issues/1) -aka- signal handling - changed default BufferSize value to 32768 bytes since this value seems to work (thanks to jjYBdx4IL again) - fixed a path related problem in the initscript Version 0.41.0 22-Dec-2011 - added EnableImageThumbnails and EnableVideoThumbnails configuration parameters to define whether thumbnails of videos or images should be created and delivered - added MPlayerBinaryPath configuration parameter to define the location of the MPlayer binary - added detaching of HTTPServer and Check4Update threads - changed SSDP function to SSDP Perl Objects, where SSDP threads get created inside of SSDP object - changed PDLNA::Daemon.pm, seems SSDP Object messed up Perl Signal Handling - added information of video files (length, width, height and bitrate) to ContentDirectory Object via Movie::Info and adapted install.pl for requirements - fixed transparency of PDLNA logo in PDLNA::HTTPServer - played with HTML and CSS for PDLNA::Library - enabled in ContentItem description XML for video files Version 0.40.0 17-Nov-2011 - improved PDLNA::HTTPServer::stream_media() function to support the limited streaming functionality (streaming media to the configured BufferSize) for even more DLNA aware devices Version 0.39.0 07-Nov-2011 - added BufferSize configuration parameter, to configure the maximum size of chunks, which are used for streaming content - improved PDLNA::HTTPServer::stream_media() function and deleted some old code in the same function Version 0.38.0 04-Nov-2011 - added functionality, that Samsung TV (and in the future for other capable devices) wants the SpecificViews instead of the BaseView of the Content Database from pDLNA - added SpecificViews to configuration file, wether pDLNA should tell the Samsung TV to use these SpecificViews - added image and video thumbnail preview support for Windows Media Player 12 - added support for streaming images to Windows Media Player 12 Version 0.37.1 03-Nov-2011 - added INSTALL file (instructions for installation) - added install.pl, a small script, which checks for requirements and installs pDLNA - added PDLNA::Status Perl Module to check for a new version of pDLNA (if configured) Version 0.37 27-Oct-2011 - fixed a problem and added default value for duration of ContentItems (thx to mrproper) - added BaseView DirectoryListing support for VLC and Windows Media Player 12 Version 0.36 25-Oct-2011 - general improvements to UPnP and SSDP discovery (i.e. added ContentDirectory and ConnectionManager XML file) - added BaseView of Content Database which is supported by all (or even mostly all) DLNA clients (added PDLNA::ContentDirectory Perl module) - added configuration value for crawling directories recursively or not - fixed deformed thumbnails - added another LogCategory (httpgeneric) - removed and improved a lot of old code from PDLNA::HTTPServer - added PDLNA::HTTPXML Perl module - added pDLNA logo icon Version 0.35 21-Oct-2011 - added initial ContentDirectory and ConnectionManager XML files - moved from Net::Interface to IO::Interface (thx to mrproper) - moved from Sys::Info::OS to Sys::Hostname and Config (thx to mrproper) - added support for subnets to AllowedClients configuration (thx to mrproper) - moved from Image::Resize to GD (thx to mrproper) - added some small fixes to Content Database (thx to mrproper) - added some small fixes to PDLNA::HTTPServer Perl module (thx to mrproper) Version 0.34 09-Oct-2011 - added AllowedClients to the configuration to define IP addresses, which should be able to communicate with pDLNA - reworked some streaming code Version 0.33 30-Jan-2011 - added support for logging to a file - added an INIT script - pDLNA is able to run as a daemon Version 0.30 10-Jan-2011 - added LogCategories for better debugging - added support for streaming images to the Samsung TV Version 0.26 02-Oct-2010 - added support for previewing thumbnails for videos (get generated dynamically by mplayer) - configuration file parsing improvements - automatic detection of listening interface and IP address - some changes to the streaming part of pDLNA Version 0.25 29-Sep-2010 - using Sys::Info::OS for operating system version and hostname - generating a random UDN at startup - added some config file validation - made debugging of Content Database more beautiful - added support for fatal logging - added a DATE_FORMAT for Date::Format Perl module in PDLNA::Config - added some debugging messages in PDLNA::SSDP Perl module Version 0.24 28-Sep-2010 - changed project website URL - code cleanup in PDLNA::SSDP Perl Module - added PDLNA::Device and PDLNA::DeviceList Perl modules to store information about already known UPnP clients Version 0.23 23-Sep-2010 - added preview/thumbnails of images, works in Samsung TV Version 0.22 23-Sep-2010 - some general improvements to the Content Database code - DirectoryListings for images, videos and audio files is supported on Samsung TV - some additional code to the streaming functionality Version 0.20 20-Sep-2010 - some fixes and improvements to the Content Database - some additional code to the streaming functionality - added initial PDLNA::Library Perl module - added configuration of media directories to the config file Version 0.19 20-Sep-2010 - moved from HTTP::Server::Simple::CGI to Socket and IO::Select - added LogLevel 2 Version 0.15 12-Sep-2010 - changed default friendly name - added initial Content Database - added PDLNA::Utils Perl module Version 0.13 10-Sep-2010 - added configuration file Version 0.12 09-Sep-2010 - discovery via SSDP for Samsung TV is working pDLNA/external_programs/0000700000175000017500000000000012127600402014446 5ustar geumageumapDLNA/external_programs/mpegstream_src.pl0000700000175000017500000001306212127600402020023 0ustar geumageuma#!/usr/bin/env perl # (c) by https://github.com/jjYBdx4IL/VDR-Streamer # re-mux -- otherwise Pana TV DLNA complains about unsupported file when starting # in the middle of a stream # (not perfect... maybe it is better to manually skip to the next GOP/I-frame) # Additionally, re-starts ffmpeg wihtout restarting http transfer if initial # input format detection by ffmpeg fails... BEGIN { # disable EPOLL backend $ENV{LIBEV_FLAGS} = 3; } use strict; use warnings; use EV; use IPC::Open3; use Fcntl qw(:DEFAULT); use Symbol; require bytes; system('killall curl'); $EV::DIED = sub { EV::unloop; die @_; }; sub async_fh { my($fh)=@_; binmode($fh) or die; my $flags = fcntl($fh, F_GETFL, 0); fcntl($fh, F_SETFL, $flags | O_NONBLOCK); } sub log_ev_evt_flags { my ($evt,$desc) = @_; my @flags = (); $desc //= ''; push @flags, 'EV::READ' if ($evt & EV::READ); push @flags, 'EV::WRITE' if ($evt & EV::WRITE); print STDERR 'EV EVT FLAGS = '.join(', ',@flags).($desc eq '' ? '' : ', '.$desc).$/; } my $buf_stop_size = 32768; my $blocksize = 32768; my $w_ffmpeg_stdin; my $w_ffmpeg_stdout; my $w_ffmpeg_stderr; my $w_ffmpeg_child; my ($ffmpeg_stdin,$ffmpeg_stdout); my $ffmpeg_stderr = gensym; my $ffmpeg_pid; my $stdout_buf = ''; my $w_stdout; my $fh_curl; my $w_curl; my $curl_output_buf = ''; open $fh_curl, '-|', 'curl', 'http://i5:3001/playback' or die $!; async_fh($fh_curl); $w_curl = EV::io $fh_curl, EV::READ, sub { my($w,$flags) = @_; log_ev_evt_flags($flags, '$w_curl'); return unless ($flags & EV::READ); sysread($fh_curl,$curl_output_buf,$blocksize,bytes::length($curl_output_buf)) or die $!; print STDERR 'length($curl_output_buf)='.bytes::length($curl_output_buf).$/; if(bytes::length($curl_output_buf) >= $buf_stop_size) { $w_curl->stop if $w_curl->is_active; print STDERR '$w_curl->stop'.$/; } if(bytes::length($curl_output_buf) > 0) { $w_ffmpeg_stdin->start unless $w_ffmpeg_stdin->is_active; print STDERR '$w_ffmpeg_stdin->start'.$/; } }; sub start_ffmpeg { print STDERR 'start_ffmpeg()'.$/; undef $w_ffmpeg_child; undef $w_ffmpeg_stdin; undef $w_ffmpeg_stdout; undef $w_ffmpeg_stderr; $ffmpeg_pid = open3($ffmpeg_stdin, $ffmpeg_stdout, $ffmpeg_stderr, "ffmpeg -f mpegts -i - -vcodec copy -acodec copy -f mpegts -"); async_fh($ffmpeg_stdin); async_fh($ffmpeg_stdout); async_fh($ffmpeg_stderr); $w_ffmpeg_child = EV::child $ffmpeg_pid, 0, sub { my ($w, $flags) = @_; log_ev_evt_flags($flags, '$w_ffmpeg_child'); my $status = $w->rstatus; start_ffmpeg(); }; $w_ffmpeg_stdin = EV::io $ffmpeg_stdin, EV::WRITE, sub { my($w,$flags) = @_; log_ev_evt_flags($flags, '$w_ffmpeg_stdin'); return unless ($flags & EV::WRITE); if(bytes::length($curl_output_buf) == 0) { $w_curl->start unless $w_curl->is_active; print STDERR '$w_curl->start'.$/; $w_ffmpeg_stdin->stop if $w_ffmpeg_stdin->is_active; print STDERR '$w_ffmpeg_stdin->stop'.$/; return; } my $wlen = syswrite($ffmpeg_stdin,$curl_output_buf,bytes::length($curl_output_buf)); if($wlen) { $curl_output_buf = substr($curl_output_buf,$wlen); print STDERR 'length($curl_output_buf)='.bytes::length($curl_output_buf).$/; } if(bytes::length($curl_output_buf) < $buf_stop_size) { $w_curl->start unless $w_curl->is_active; print STDERR '$w_curl->start'.$/; } }; $w_ffmpeg_stdout = EV::io $ffmpeg_stdout, EV::READ, sub { my($w,$flags) = @_; log_ev_evt_flags($flags, '$w_ffmpeg_stdout'); return unless ($flags & EV::READ); if(!sysread($ffmpeg_stdout,$stdout_buf,$blocksize,bytes::length($stdout_buf))) { # $w_ffmpeg_stdout->stop; # print STDERR '$w_ffmpeg_stdout->stop'.$/; return; } print STDERR 'length($stdout_buf)='.bytes::length($stdout_buf).$/; if(bytes::length($stdout_buf) >= $buf_stop_size) { $w_ffmpeg_stdout->stop if $w_ffmpeg_stdout->is_active; print STDERR '$w_ffmpeg_stdout->stop'.$/; } if(bytes::length($stdout_buf) > 0) { $w_stdout->start unless $w_stdout->is_active; print STDERR '$w_stdout->start'.$/; } }; $w_ffmpeg_stderr = EV::io $ffmpeg_stderr, EV::READ, sub { my($w,$flags) = @_; log_ev_evt_flags($flags, '$w_ffmpeg_stderr'); return unless ($flags & EV::READ); my $buf; if(sysread($ffmpeg_stderr,$buf,1024)) { print STDERR $buf; } }; } async_fh(*STDOUT); $w_stdout = EV::io *STDOUT, EV::WRITE, sub { my($w,$flags) = @_; log_ev_evt_flags($flags, '$w_stdout'); return unless ($flags & EV::WRITE); if(bytes::length($stdout_buf) == 0) { $w_stdout->stop if $w_stdout->is_active; print STDERR '$w_stdout->stop'.$/; $w_ffmpeg_stdout->start unless $w_ffmpeg_stdout->is_active; print STDERR '$w_ffmpeg_stdout->start'.$/; return; } my $wlen = syswrite(STDOUT,$stdout_buf,bytes::length($stdout_buf)); die unless defined $wlen; if($wlen) { $stdout_buf = substr($stdout_buf,$wlen); print STDERR 'length($stdout_buf)='.bytes::length($stdout_buf).$/; } if(bytes::length($stdout_buf) < $buf_stop_size) { $w_ffmpeg_stdout->start unless $w_ffmpeg_stdout->is_active; print STDERR '$w_ffmpeg_stdout->start'.$/; } }; start_ffmpeg(); EV::loop; pDLNA/install.pl0000700000175000017500000001520313366115033012730 0ustar geumageuma#!/usr/bin/perl -w # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Getopt::Long::Descriptive; my ($opt, $usage) = describe_options( '%c %o ', [ 'prefix|p:s', 'define prefix for installation path of libraries', { default => '/opt' }, ], [ 'install|i', 'checks for necessary requirements and installs pDLNA' ], [ 'update|u', 'checks for necessary requirements and updates pDLNA installation (does not overwrite existing /etc/pdlna.conf file)' ], [ 'checkrequirements|c', 'checks for necessary requirements' ], [], # just an empty line for the usage message [ 'help|h', 'print usage method and exit' ], ); print($usage->text()), exit if $opt->help(); my $PREFIX = '/opt'; $PREFIX = $opt->prefix() if (defined($opt->prefix())); $PREFIX .= '/' unless $PREFIX =~ /\/$/; if (!$opt->checkrequirements() && !$opt->install() && !$opt->update()) { print($usage->text()); exit; } use Test::More; print "------------------------------------------------------\n"; print "Step 1:\n"; print "Testing for necessary Perl Modules ...\n"; print "------------------------------------------------------\n"; use_ok ('Audio::FLAC::Header'); use_ok ('Audio::Wav'); use_ok ('Audio::WMA'); use_ok ('Config'); use_ok ('Config::ApacheFormat'); use_ok ('Data::Dumper'); use_ok ('Date::Format'); use_ok ('DBD::mysql'); use_ok ('DBD::Pg'); use_ok ('DBD::SQLite'); use_ok ('DBI'); use_ok ('Digest::MD5'); use_ok ('Digest::SHA'); use_ok ('Fcntl'); use_ok ('File::Basename'); use_ok ('File::Glob'); use_ok ('File::MimeInfo'); use_ok ('GD'); use_ok ('GD::Graph::area'); use_ok ('Getopt::Long::Descriptive'); use_ok ('HTML::Entities'); use_ok ('Image::Info'); use_ok ('IO::Interface::Simple'); use_ok ('IO::Select'); use_ok ('IO::Socket'); use_ok ('IO::Socket::INET'); use_ok ('IO::Socket::Multicast'); use_ok ('LWP::UserAgent'); use_ok ('MP3::Info'); use_ok ('MP4::Info'); use_ok ('Net::IP'); use_ok ('Net::Netmask'); use_ok ('Ogg::Vorbis::Header::PurePerl'); use_ok ('POSIX'); use_ok ('Proc::ProcessTable'); use_ok ('SOAP::Lite'); use_ok ('Socket'); use_ok ('Sys::Hostname'); use_ok ('Sys::Syslog'); use_ok ('threads'); use_ok ('threads::shared'); use_ok ('Time::HiRes'); use_ok ('URI::Split'); use_ok ('XML::Simple'); if (!$opt->install() && !$opt->update()) { done_testing(); exit; } print "------------------------------------------------------\n"; print "Step 2:\n"; print "Testing for necessary Perl Modules for installation ...\n"; print "------------------------------------------------------\n"; use_ok ('File::Copy'); use_ok ('File::Copy::Recursive'); print "------------------------------------------------------\n"; print "Step 3:\n"; print "Installing files ...\n"; print "------------------------------------------------------\n"; use File::Copy::Recursive qw(rcopy); $PREFIX .= 'pDLNA/'; unless (-d $PREFIX) { mkdir($PREFIX, 0755); } my %installation_files = ( 'etc/init.d/pdlna' => ['f', '/', 0755, 'i'], 'usr/sbin/pDLNA.pl' => ['f', $PREFIX, 0755, 'i'], 'etc/pdlna.conf' => ['f', '/', 0644, 'u'], 'usr/lib/perl5/PDLNA' => ['d', $PREFIX, 0755, 'i'], 'external_programs' => ['d', $PREFIX, 0755, 'i'], 'README' => ['f', $PREFIX, 0644, 'i'], 'LICENSE' => ['f', $PREFIX, 0644, 'i'], 'VERSION' => ['f', $PREFIX, 0644, 'i'], ); foreach my $key (keys %installation_files) { if (-d $installation_files{$key}->[1]) { if ($installation_files{$key}->[0] eq 'f' || $installation_files{$key}->[0] eq 'd') { unless ($opt->update() && $installation_files{$key}->[3] eq 'u' && -f $installation_files{$key}->[1].$key) { if (rcopy('./'.$key, $installation_files{$key}->[1].$key)) { pass("Installed './$key' to '$installation_files{$key}->[1]$key'."); if (chmod($installation_files{$key}->[2], $installation_files{$key}->[1].$key)) { pass("Set rights for '$installation_files{$key}->[1]$key'."); } else { fail("Unable to set rights for '$installation_files{$key}->[1]$key': $!"); } } else { fail("Unable to install './$key' to '$installation_files{$key}->[1]$key': $!"); } } else { pass("Did not install './$key' to '$installation_files{$key}->[1]$key', since we are only upgrading the installation."); } } else { fail("Unknown filetype for file named '$key'."); } } else { fail("$installation_files{$key}->[1] is NOT existing. Unable to install necessary files."); } } print "------------------------------------------------------\n"; print "Step 4:\n"; print "Setting of relevant paths ...\n"; print "------------------------------------------------------\n"; my $regex = '+DIR="../../usr/sbin/"+DIR="'.$PREFIX.'usr/sbin/"'; if (system("sed -i -e s'$regex'+ /etc/init.d/pdlna") == 0) { pass("Changed path for binary in '/etc/init.d/pdlna'."); } else { fail("Failed to change path for binary in '/etc/init.d/pdlna': $!."); } $regex = "+use lib ('../lib/perl5');+use lib ('$PREFIX"."usr/lib/perl5');+"; if (system('sed -i -e s"'.$regex.'" '.$PREFIX.'usr/sbin/pDLNA.pl') == 0) { pass("Changed path for lib in '".$PREFIX."usr/sbin/pDLNA.pl'."); } else { fail("Failed to change path for lib in '".$PREFIX."usr/sbin/pDLNA.pl': $!."); } print "------------------------------------------------------\n"; print "Step 5:\n"; print "Checking for pDLNA Perl Modules ...\n"; print "------------------------------------------------------\n"; # delete local directory from PATH for (my $i = 0; $i < @INC; $i++) { splice(@INC, $i, 1) if $INC[$i] eq '.'; } push(@INC, $PREFIX.'usr/lib/perl5/'); # push the new LIB directory to PATH use_ok ('PDLNA::Config'); use_ok ('PDLNA::ContentLibrary'); use_ok ('PDLNA::Daemon'); use_ok ('PDLNA::Database'); use_ok ('PDLNA::Devices'); use_ok ('PDLNA::FFmpeg'); use_ok ('PDLNA::HTTPServer'); use_ok ('PDLNA::HTTPXML'); use_ok ('PDLNA::Log'); use_ok ('PDLNA::Media'); use_ok ('PDLNA::SOAPClient'); use_ok ('PDLNA::SOAPMessages'); use_ok ('PDLNA::SpecificViews'); use_ok ('PDLNA::SSDP'); use_ok ('PDLNA::Statistics'); use_ok ('PDLNA::Status'); use_ok ('PDLNA::Utils'); use_ok ('PDLNA::WebUI'); done_testing(); pDLNA/INSTALL0000700000175000017500000000225013366123740011760 0ustar geumageumapDLNA (c) 2010-2018 Stefan Heumader-Rainer email: stefan@heumader.at webpage: https://www.pdlna.org Licened under GPLv3 (see LICENSE file) For detailed information regarding the installation, please read the 'pDLNA Installation, Configuration and Debugging Guide' available under https://www.pdlna.org/cgi-bin/index.pl?menu=download&type=icdguide&version=latest INSTALLATION REQUIREMENTS ------------------------- Since pDLNA requires some Perl modules, please see chapter 2 of the 'pDLNA Installation, Configuration and Debugging Guide' available under https://www.pdlna.org/cgi-bin/index.pl?menu=download&type=icdguide&version=latest You are also able to execute 'install.pl -c' to see, which Perl modules are needed and which are already installed. INSTALL --------------- Just run the script called 'install.pl -h' to get initial help for setting the right parameters for your installation. The script will also check for requirements, copies the files to the correct directories and sets the necessary rights. At the end, if all tests passed, you should be able to edit '/etc/pdlna.conf' and start pDLNA with the initscript located at '/etc/init.d/pdlna'. Stefan Heumader-Rainer pDLNA/etc/0000700000175000017500000000000012345333001011465 5ustar geumageumapDLNA/etc/default/0000700000175000017500000000000013366530320013120 5ustar geumageumapDLNA/etc/default/pdlna0000700000175000017500000000024112262025516014141 0ustar geumageuma# Defaults for pDLNA initscript (/etc/init.d/pDLNA) # # This is a POSIX shell fragment # # Additional options that are passed to the daemon(s). DAEMON_ARGS="" pDLNA/etc/init.d/0000700000175000017500000000000013366115033012661 5ustar geumageumapDLNA/etc/init.d/pdlna0000700000175000017500000000423013366115033013704 0ustar geumageuma#!/bin/sh # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # DIR="../../usr/sbin/" BIN="pDLNA.pl" PRG="pDLNA" CFGFILE="/etc/pdlna.conf" if [ "x$CFGFILE" = "x" ]; then CFGFILE="/etc/pdlna.conf" fi PIDFILE=`grep ^PIDFile $CFGFILE | awk {'print $2'}` if [ "x$PIDFILE" = "x" ]; then PIDFILE="/var/run/pdlna.pid" fi start() { PRG_PID="" if [ -f $PIDFILE ]; then PRG_PID=`cat $PIDFILE` if [ "x$PRG_PID" = "x" ]; then echo "Starting $PRG ..." cd $DIR && ./$BIN -f $CFGFILE else if [ -d "/proc/$PRG_PID" ]; then echo "$PRG is already running with PID $PRG_PID"; else echo "Starting $PRG ..." cd $DIR && ./$BIN -f $CFGFILE fi fi else echo "Starting $PRG ..." cd $DIR && ./$BIN -f $CFGFILE fi } stop() { PRG_PID="" if [ -e $PIDFILE ]; then PRG_PID=`cat $PIDFILE` fi if [ "x$PRG_PID" = "x" ]; then echo "$PRG is NOT running." else if [ -d "/proc/$PRG_PID" ]; then echo "Stopping $PRG ..." /bin/rm -f $PIDFILE kill $PRG_PID else /bin/rm -f $PIDFILE fi fi } status () { PRG_PID="" if [ -e $PIDFILE ]; then PRG_PID=`cat $PIDFILE` fi if [ "x$PRG_PID" = "x" ]; then echo "$PRG is NOT running." else if [ -d "/proc/$PRG_PID" ]; then echo "$PRG is running with PID $PRG_PID"; else /bin/rm -f $PIDFILE echo "$PRG is NOT running." fi fi } case "$1" in start) start ;; stop) stop ;; restart) stop sleep 10 start ;; status) status ;; *) echo "usage: $0 {start|stop|restart|status}" exit esac pDLNA/etc/pdlna.conf0000700000175000017500000002653612344022566013463 0ustar geumageuma# # GLOBAL PARAMETERS # # FriendlyName # the name of the server, which will be displayed on the clients # currently the following variables are available # $VERSION - for instance 'v1.00.0' # $HOSTNAME - the systems hostname # $OS - the operating system's name # the maximum length of the FriendlyName is limited to 32 characters # allowed characters are: letters, numbers, spaces, dots, dashes and underscores # if none is specified, it will be set to 'pDLNA $VERSION on $HOSTNAME' #FriendlyName 'pDLNA $VERSION on $HOSTNAME' # Check4Updates # specify if pDLNA should check for new updates daily # therefore a HTTP request to www.pdlna.org will be done # if not specified, it will be enabled Check4Updates On # Check4UpdatesNotification # specify if pDLNA should send a message to a connected # urn:samsung.com:serviceId:MessageBoxService if a new # version of pDLNA is available Check4UpdatesNotification On # EnableGeneralStatistics # specify if pDLNA should store statistics about the running pDLNA installation # - memory usage # - amount of media items # if not specified, it will be enabled EnableGeneralStatistics On # EnableDBStatistics (NOT FOR PRODUCTIVE ENVIRONMENT) # specify if pDLNA should gather statistics about its DB queries # enabling this feature will decrease the performance of your pDLNA installation # and should only be used to do some investigations to improve database performance # if not specified, it will be disabled EnableDBStatistics Off # PIDFile # the full path of the PID file # if none is specified, it will be set to /var/run/pdlna.pid PIDFile /var/run/pdlna.pid # TempDir # specify a temporary directoriy, where pDLNA is able to store some temporary files # if none is specified, it will be set to /tmp #TempDir /tmp # # DATABASE CONFIGURATION # # DatabaseType # the type of the database, which should be used by pDLNA # available options # SQLITE3 - it will use a SQLITE3 database # MYSQL - it will use a MySQL database # PGSQL - it will use a PostgreSQL database # if none is specified, it will be set to SQLITE3 #DatabaseType SQLITE3 # DatabaseName # define the name of the database, which should be used # in case of SQLITE3, specify the location of SQLITE3 file # # if none is specified and the DatabaseType is SQLITE3, it will be set to /tmp/pdlna.db # if none is specified and the DatabaseType is MYSQL, it will be set to pdlna # if none is specified and the DatabaseType is PGSQL, it will be set to pdlna #DatabaseName /tmp/pdlna.db # DatabaseUsername # define a valid username for the MySQL or PostgreSQL server, which has all privileges to the configured DatabaseName # # if none is specified, it will be set to pdlna #DatabaseUsername pdlna # DatabasePassword # define the valid password for the configured DatabaseUsername # # if none is specified, no password will be used to authenticate to the database #DatabasePassword # # NETWORK CONFIGURATION # # ListenInterface # the interface of the server, which is going to be used by the server # if none is specified, the first non loopback device with an ip address # will be chosen #ListenInterface eth0 # ListenIPAddress # the ip address of the server, which is going to be used by the server # if none is specified the first ip address of the ListenInterface will be chosen #ListenIPAddress 192.168.1.1 # HTTPPort # The TCP Port, the webserver is going to listen on # if none is specified, it will be set to 8001 #HTTPPort 8001 # AllowedClients # specify a list of IP addresses and/or subnets, which should be able to communicate with the pDLNA server # if none is specified, no client will be able to communicate with the server # They can be specified in the following formats: 192.168.1.1/24, 192.168.1.1/255.255.255.0 or 192.168.1.1 # Multiples can be seperated by commas # if not specified, the local subnet will be configured #AllowedClients 192.168.0.1,192.168.1.0/24,192.168.2.0/255.255.255.0 # # SSDP CONFIGURATION # # CacheControl # the time in seconds, clients will cache the server's information # it also has impact on the interval the server is going to send out his SSDP alive messages # if none is specified, it will be set to 1800 #CacheControl 1800 # UUID # specify the method to generate the UUID, please see http://www.ietf.org/rfc/rfc4122.txt # IMPORTANT NOTE: the method for generating the UUIDs are NOT RFC compliant and are NOT # be truly random # available options # Version3 - MD5 hash of name based UUID # Version4 - random UUID # Version4MAC - random UUID (with the MAC address in the end) # Version5 - SHA1 hash of name based UUID # - specify a static UUID (i.e.: 56657273-696f-6e34-4d41-000c29bcfcda) # if not specified, Version4 will be configured #UUID Version4 # # DLNA CONFIGURATION # # BufferSize # specify the buffer's maximum size. this buffer is used for the size of chunks, which are used for streaming content # be sure to set the parameter to an acceptable value for your hardware (especially your memory) configuration # ATTENTION: customizing this value may result in malfunction of pDLNA # if none is specified, it will be set to 32768 #BufferSize 32768 # SpecificViews # specify, if for known devices their more specific directory listings should be enabled # if not specified, it will be disabled #SpecificViews Off # EnableImageThumbnails # specify if thumbnails of images in the ContentDirectory should be # created and delivered to capable devices # enabling this feature will result in slower directory listings # if none is specified, it will be set to 0 #EnableImageThumbnails On # EnableVideoThumbnails # specify if thumbnails of videos in the ContentDirectory should be # created and delivered to capable devices # enabling this feature will result in slower directory listings # if none is specified, it will be set to 0 #EnableVideoThumbnails On # LowResourceMode # specify if pDLNA is running an a system with low resources (like memory or cpu) # decreases usability in directory listings because less information about audio/video # files is available, but increases indexing/crawling the media directories incredibly # if none is specified, it will be set to 0 #LowResourceMode On # FFmpegBinaryPath # specify the path to the FFmpeg binary # if none is specified, it will be set to '/usr/bin/ffmpeg' #FFmpegBinaryPath /usr/bin/ffmpeg # # LOGGING # # LogFile # specify the type of logging # available options # STDERR - it will log to stderr # SYSLOG - it will log via syslog # - it will log to the specified file # if none is specified, it will be set to STDERR #LogFile STDERR #LogFile SYSLOG #LogFile /var/log/pdlna.log # LogFileMaxSize # specify the maximum filesize in megabytes for the logfile # if the specified size is reached, the logfile will be cleared # valid values are: 0 < LogFileMaxSize < 100 # if none is specified, it will be set to 10 megabytes #LogFileMaxSize 10 # LogFileRotation # specify how many logfiles will be stored, if the logfile's size # exceeds the LogFileMaxSize configuration parameter # the value zero disables this functionality # this parameter will only be relevant, if a file for logging is # configured # if none is specified, it will be set to 0 #LogFileRotation 4 # LogLevel # specify the loglevel # available options # 0 - normal # 1 - debug # 2 - debug^2 # 3 - debug^3 # if none is specified, it will be set to 0 #LogLevel 1 # LogCategory # specify the category # available options # seperate multiple with a comma # discovery - log messages from the SSDP # httpdir - log the messages from the HTTP directory listing # httpstream - log the messages from the streaming via HTTP # library - log the messages from building the media library # httpgeneric - log generic HTTP messages # database - log database messages # transcoding - log transcoding messages # soap - log SOAP messages LogCategory discovery,httpdir,httpstream,library,httpgeneric,database,transcoding,soap # DateFormat # specify the date's format # available characters # %m month number # %d numeric day of the month # %H hour, 24 hour clock # %I hour, 12 hour clock # %p AM or PM # %M minute # %S seconds # %s seconds since the Epoch, UCT (aka unixtimestamps) # %o ornate day of month -- "1st", "2nd", "25th", etc. # %Y year # %Z timezone in ascii. eg: PST # ,-_: and spaces # if none is specified, it will be set to '%Y-%m-%d %H:%M:%S' #DateFormat '%Y-%m-%d %H:%M:%S' # # MEDIA CONFIGURATION # # RescanMediaInterval # specify the interval, when pDLNA should recrawl and rebuild # the media directories # available parameters # never # hourly # halfdaily # daily # if none is specified, it will be set to daily #RescanMediaInterval daily # Directory # specify directories which should be added to library, which will be crawled for supported Mime Types # additionally the following parameters for each block are available # MediaType # video - files with Mime Type video/x-msvideo, video/x-matroska, video/mp4 or video/mpeg # audio - files with Mime Type audio/mpeg, audio/mp4, audio/x-ms-wma or audio/x-flac # image - files with Mime Type image/jpeg or image/gif # all - all of them above # Recursion # specify if pDLNA should crawl those directories recursively (by 'yes' or 'no') # ExcludeDirs # exclude a comma seperated list of directory names from being crawled # ExcludeItems # exclude a comma seperated list of file names from being crawled # AllowPlaylists # enable AllowPlaylists configuration parameter to initialize playlist files with Mime Types: audio/x-scpls or audio/x-mpegurl # # some configuration examples are listed below MediaType video Recursion yes MediaType audio ExcludeDirs "Justin Bieber,Lady Gaga" ExcludeItems "justin_bieber.mp3,lady_gaga.mp3" AllowPlaylists true Mediatype image MediaType all Recursion no AllowPlaylists off # External # specify external media items, like scripts or streams, which will be added to the root # currently, there are two options # Executable for a specified script, which needs to be executable # StreamingURL for a http:// or mms:// streams # for Executables, a MediaType needs to be specified - currently only the following two are allowed # audio # video # # some configuration examples are listed below # # MediaType video # Executable external_programs/mpegstream_src.pl # StreamingURL http://mp3stream1.apasf.apa.at:8000/ # # TRANSCODING PROFILES # # Transcode # specify transcoding profiles, which will be used for audio files, which are in the configured format # and will be transcoded to the specified format too # For more details, please see the "pDLNA Installation, Configuration and Debugging Guide" # # the following keywords are available # ContainerIn # ContainerOut # AudioCodecIn # AudioCodecOut # VideoCodecIn # VideoCodecOut # ClientIPs # specify a list of IP addresses and/or subnets, on which the transcoding profile should be used # multiples can be seperated by commas # this can be specified in the following formats: 192.168.1.1/24, 192.168.1.1/255.255.255.0 or 192.168.1.1 # # a configuration examples is listed below # # ContainerIn ogg # ContainerOut audio # AudioCodecIn vorbis # AudioCodecOut flac # ClientIPs 192.168.0.1,192.168.1.0/24,192.168.2.0/255.255.255.0 # pDLNA/README0000700000175000017500000000153613366123634011617 0ustar geumageumapDLNA (c) 2010-2018 Stefan Heumader-Rainer email: stefan@heumader.at webpage: https://www.pdlna.org Licensed under GPLv3 (see LICENSE file) INTRODUCTION ------------ pDLNA is an UPnP and DLNA service which serves multimedia content to compatible clients on the network and is written in Perl. See http://www.perl.org for more details on Perl and http://www.upnp.org/ for more details on UPnP and http://www.dlna.org/ for mode details on DLNA. INSTALLATION ------------------------- For the installation see the INSTALL file or the 'pDLNA Installation, Configuration and Debugging Guide' available under https://www.pdlna.org/cgi-bin/index.pl?menu=download&type=icdguide&version=latest BUGS & FEATURES --------------- Email me or contact me on GitHub if you find bugs or if you have some ideas for improvements. Stefan Heumader-Rainer pDLNA/usr/0000700000175000017500000000000012261776706011547 5ustar geumageumapDLNA/usr/sbin/0000700000175000017500000000000013366115033012465 5ustar geumageumapDLNA/usr/sbin/pDLNA.pl0000700000175000017500000000604113366115033013724 0ustar geumageuma#!/usr/bin/perl # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use threads; use threads::shared; use Getopt::Long::Descriptive; use lib ('../lib/perl5'); use PDLNA::Config; use PDLNA::ContentLibrary; use PDLNA::Daemon; use PDLNA::Database; use PDLNA::HTTPServer; use PDLNA::Log; use PDLNA::SSDP; use PDLNA::Statistics; use PDLNA::Status; # # STARTUP PARAMETERS # my ($opt, $usage) = describe_options( '%c %o ', [ 'config|f:s', 'path to the configuration file', { default => '/etc/pdlna.conf' }, ], [], # just an empty line for the usage message [ 'help|h', 'print usage method and exit' ], ); print($usage->text), exit if $opt->help(); my @config_file_error = (); unless (PDLNA::Config::parse_config($opt->config, \@config_file_error)) { PDLNA::Log::fatal(join("\n", @config_file_error)) } PDLNA::Log::log("Starting $CONFIG{'PROGRAM_NAME'}/v".PDLNA::Config::print_version()." on $CONFIG{'OS'}/$CONFIG{'OS_VERSION'} with FriendlyName '$CONFIG{'FRIENDLY_NAME'}' with UUID $CONFIG{'UUID'}.", 0, 'default'); PDLNA::Database::initialize_db(); my $ssdp = PDLNA::SSDP->new(); # initialize SSDP object # forking PDLNA::Daemon::daemonize(\%SIG, \$ssdp); PDLNA::Daemon::write_pidfile($CONFIG{'PIDFILE'}, $$); # starting thread to periodically index the configured media directories my $thread1 = threads->create('PDLNA::ContentLibrary::index_directories_thread'); $thread1->detach(); # starting up PDLNA::Log::log("Server is going to listen on $CONFIG{'LOCAL_IPADDR'} on interface $CONFIG{'LISTEN_INTERFACE'}.", 1, 'default'); my $thread2 = threads->create('PDLNA::HTTPServer::start_webserver'); # starting the HTTP server in a thread $thread2->detach(); $ssdp->add_send_socket(); # add the socket for sending SSDP messages $ssdp->add_receive_socket(); # add the socket for receiving SSDP messages $ssdp->send_byebye(2); # send some byebye messages $ssdp->start_listening_thread(); # start to listen for SEARCH messages in a thread $ssdp->send_alive(6); # and now we are joing the group $ssdp->start_sending_periodic_alive_messages_thread(); # start to send out periodic alive messages in a thread if ($CONFIG{'CHECK_UPDATES'}) { my $thread3 = threads->create('PDLNA::Status::check_update_periodic'); $thread3->detach(); } if ($CONFIG{'ENABLE_GENERAL_STATISTICS'}) { my $thread4 = threads->create('PDLNA::Statistics::write_statistics_periodic'); $thread4->detach(); } while(1) { sleep(100); } pDLNA/usr/lib/0000700000175000017500000000000013366124316012304 5ustar geumageumapDLNA/usr/lib/perl5/0000700000175000017500000000000013366124321013327 5ustar geumageumapDLNA/usr/lib/perl5/PDLNA/0000700000175000017500000000000013366531022014165 5ustar geumageumapDLNA/usr/lib/perl5/PDLNA/WebUI.pm0000700000175000017500000006325113366414514015516 0ustar geumageumapackage PDLNA::WebUI; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Date::Format; use GD::Graph::area; use HTML::Entities; use LWP::UserAgent; use XML::Simple; use PDLNA::Config; use PDLNA::ContentLibrary; use PDLNA::Database; use PDLNA::Daemon; use PDLNA::FFmpeg; use PDLNA::Statistics; use PDLNA::Status; use PDLNA::Utils; sub show { my $get_param = shift; my $dbh = PDLNA::Database::connect(); my @nav = parse_nav($get_param); my $response = PDLNA::HTTPServer::http_header({ 'statuscode' => 200, 'content_type' => 'text/html; charset=UTF-8', }); $response .= ''."\n"; $response .= ''; $response .= ''; $response .= ''.encode_entities($CONFIG{'FRIENDLY_NAME'}).''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= '
'; $response .= ''; $response .= ''; # # CONTENT ITSELF # $response .= '
'; if ($nav[0] eq 'content') { $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; my (undef, $size) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'parent_id', $nav[1]); $response .= ''; $response .= ''; $response .= ''; my @files = (); PDLNA::ContentLibrary::get_items_by_parentid($dbh, $nav[1], undef, undef, 1, \@files); foreach my $id (@files) { $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; } $response .= ''; $response .= '
FilenameSizeDate
 '.encode_entities(PDLNA::Utils::convert_bytes($size)).' 
'.encode_entities(PDLNA::Utils::string_shortener($id->{title}, 30)).''.encode_entities(PDLNA::Utils::convert_bytes($id->{size})).''.encode_entities(time2str($CONFIG{'DATE_FORMAT'}, $id->{date})).'
'; } elsif ($nav[0] eq 'device') { if (defined($nav[1]) && !defined($nav[2])) { my @device_ip = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ip, user_agent, last_seen FROM device_ip WHERE id = ?', 'parameters' => [ $nav[1], ], }, \@device_ip, ); if (defined($device_ip[0]->{ip})) { $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= '' if defined($device_ip[0]->{user_agent}); $response .= ''; $response .= ''; $response .= '
 Information
IP'.encode_entities($device_ip[0]->{ip}).'
HTTP UserAgent'.encode_entities($device_ip[0]->{user_agent}).'
Last seen at'.encode_entities(time2str($CONFIG{'DATE_FORMAT'}, $device_ip[0]->{last_seen})).'
'; } else { $response .= '

No information available.

'; } } elsif (defined($nav[1]) && defined($nav[2])) { my @device_udn = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT udn, ssdp_banner, friendly_name, model_name, type, desc_url FROM device_udn WHERE id = ?', 'parameters' => [ $nav[2], ], }, \@device_udn, ); if (defined($device_udn[0]->{udn})) { $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= '' if defined($device_udn[0]->{ssdp_banner}); $response .= '' if defined($device_udn[0]->{friendly_name}); $response .= '' if defined($device_udn[0]->{model_name}); $response .= '' if defined($device_udn[0]->{type}); $response .= '' if defined($device_udn[0]->{desc_url}); $response .= ''; $response .= '
 Information
UDN'.encode_entities($device_udn[0]->{udn}).'
SSDP Banner'.encode_entities($device_udn[0]->{ssdp_banner}).'
Friendly Name'.encode_entities($device_udn[0]->{friendly_name}).'
Model Name'.encode_entities($device_udn[0]->{model_name}).'
Device Type'.encode_entities($device_udn[0]->{type}).'
Device Description URL'.encode_entities($device_udn[0]->{desc_url}).'
'; $response .= '

 

'; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; my @device_nts = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT type, expire FROM device_nts WHERE device_udn_ref = ?', 'parameters' => [ $nav[2], ], }, \@device_nts, ); foreach my $nts (@device_nts) { $response .= ''; } $response .= ''; $response .= '
NTSexpires at
'.encode_entities($nts->{type}).''.encode_entities(time2str($CONFIG{'DATE_FORMAT'}, $nts->{expire})).'
'; } else { $response .= '

No information available.

'; } } } elsif ($nav[0] eq 'info' && $nav[1] eq 'pi') { my $pid = PDLNA::Daemon::read_pidfile($CONFIG{'PIDFILE'}); my %proc_info = PDLNA::Statistics::get_proc_information(); $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; if ($CONFIG{'OS'} ne 'freebsd') { $response .= ''; } $response .= ''; $response .= ''; if ($CONFIG{'OS'} ne 'freebsd') { $response .= ''; } $response .= ''; $response .= '
 Information
'.encode_entities($CONFIG{'PROGRAM_NAME'}).' running with PID'.encode_entities($pid).'
Parent PID of '.encode_entities($CONFIG{'PROGRAM_NAME'}).''.encode_entities($proc_info{'ppid'}).'
'.encode_entities($CONFIG{'PROGRAM_NAME'}).' started at'.encode_entities(time2str($CONFIG{'DATE_FORMAT'}, $proc_info{'start'})).'
'.encode_entities($CONFIG{'PROGRAM_NAME'}).' running with priority'.encode_entities($proc_info{'priority'}).'
CPU Utilization Since Process Started'.encode_entities($proc_info{'pctcpu'}).' %
Current Virtual Memory Size (VMS)'.encode_entities(PDLNA::Utils::convert_bytes($proc_info{'vmsize'})).'
Current Memory Utilization in RAM (RSS)'.encode_entities(PDLNA::Utils::convert_bytes($proc_info{'rssize'})).'
Current Memory Utilization'.encode_entities($proc_info{'pctmem'}).' %
'; if ($CONFIG{'ENABLE_GENERAL_STATISTICS'}) { $response .= show_graph(\@nav); } } elsif ($nav[0] eq 'info' && $nav[1] eq 'cl') { $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; my $timestamp = PDLNA::Database::select_db_field_int( $dbh, { 'query' => 'SELECT value FROM metadata WHERE param = ?', 'parameters' => [ 'TIMESTAMP', ], }, ); $response .= ''; my ($files_amount, $files_size) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'item_type', 1); my ($directories_amount, undef) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'item_type', 0); $response .= ''; my $duration = PDLNA::ContentLibrary::get_duration_items($dbh); $response .= '' if !$CONFIG{'LOW_RESOURCE_MODE'}; $response .= ''; foreach my $type ('image', 'audio', 'video') { my ($type_amount, $type_size) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'media_type', $type); $response .= ''; } $response .= ''; $response .= '
 Information
Timestamp'.time2str($CONFIG{'DATE_FORMAT'}, $timestamp).'
Media Items'.encode_entities($files_amount).' ('.encode_entities(PDLNA::Utils::convert_bytes($files_size)).') in '.encode_entities($directories_amount).' directories
Length of all Media Items'.encode_entities(PDLNA::Utils::convert_duration($duration, 1)).' ('.$duration.' seconds)
 
'.encode_entities(ucfirst($type)).' Items'.encode_entities($type_amount).' ('.encode_entities(PDLNA::Utils::convert_bytes($type_size)).')
'; if ($CONFIG{'ENABLE_GENERAL_STATISTICS'}) { $response .= show_graph(\@nav); } } elsif ($nav[0] eq 'info' && $nav[1] eq 'pdlna') { $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= '
 Information
pDLNA Version'.encode_entities(PDLNA::Config::print_version()).'
pDLNA Release Date'.encode_entities($CONFIG{'PROGRAM_DATE'}).'
'; $response .= '
'; $response .= '
'; $response .= ''; $response .= '
'; $response .= '
'; if (defined($nav[2]) && $nav[2] eq 'check4update') { my $http_response = PDLNA::Status::do_http_request(); if ($http_response->is_success) { my $xml_obj = XML::Simple->new(); my $xml = $xml_obj->XMLin($http_response->decoded_content()); if ($xml->{'response'}->{'resultID'} == 1 || $xml->{'response'}->{'resultID'} == 2) { $response .= '

Check4Updates was not successful: Invalid Request.

'; } elsif ($xml->{'response'}->{'resultID'} == 3) { $response .= '

You are running the latest version of '.encode_entities($CONFIG{'PROGRAM_NAME'}).'.

'; } elsif ($xml->{'response'}->{'resultID'} == 4) { $response .= '
'; $response .= '

A new version of '.encode_entities($CONFIG{'PROGRAM_NAME'}).' is available: '.encode_entities($xml->{'response'}->{'NewVersion'}).'.

'; $response .= '

Check the Changelog section on the project website for detailed information.

'; $response .= '
'; } } else { $response .= '

Check4Updates was not successful: HTTP Status Code '.encode_entities($http_response->status_line()).'.

'; } } } elsif ($nav[0] eq 'info' && $nav[1] eq 'ffmpeg' && !$CONFIG{'LOW_RESOURCE_MODE'}) { $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; $response .= ''; my @results = (); foreach (@{$CONFIG{'FORMATS_DECODE'}}) { if (my $format = PDLNA::FFmpeg::get_beautiful_decode_format($_)) { push(@results, encode_entities($format)); } } $response .= ''; @results = (); foreach (@{$CONFIG{'FORMATS_ENCODE'}}) { if (my $format = PDLNA::FFmpeg::get_beautiful_encode_format($_)) { push(@results, encode_entities($format)); } } $response .= ''; $response .= ''; @results = (); foreach (@{$CONFIG{'AUDIO_CODECS_DECODE'}}) { if (my $codec = PDLNA::FFmpeg::get_beautiful_audio_decode_codec($_)) { push(@results, encode_entities($codec)); } } $response .= ''; @results = (); foreach (@{$CONFIG{'AUDIO_CODECS_ENCODE'}}) { if (my $codec = PDLNA::FFmpeg::get_beautiful_audio_encode_codec($_)) { push(@results, encode_entities($codec)); } } $response .= ''; $response .= ''; $response .= '
 Information
FFmpeg Version'.encode_entities($CONFIG{'FFMPEG_VERSION'}).'
 
Supported decoding formats'.join(', ', @results).'
Supported encoding formats'.join(', ', @results).'
 
Supported decoding audio codecs'.join(', ', @results).'
Supported encoding audio codecs'.join(', ', @results).'
'; } $response .= '
'; $response .= ''; $response .= '
'; $response .= ''; $response .= ''; PDLNA::Database::disconnect($dbh); return $response; } sub javascript { my @javascript = ( 'stripe = function() {', 'var tables = document.getElementsByTagName("table");', 'for(var x=0;x!=tables.length;x++){', 'var table = tables[x];', 'if (! table) { return; }', 'var tbodies = table.getElementsByTagName("tbody");', 'for (var h = 0; h < tbodies.length; h++) {', 'var even = true;', 'var trs = tbodies[h].getElementsByTagName("tr");', 'for (var i = 0; i < trs.length; i++) {', 'trs[i].onmouseover=function(){', 'this.className += " ruled"; return false', '}', 'trs[i].onmouseout=function(){', 'this.className = this.className.replace("ruled", ""); return false', '}', 'if(even)', 'trs[i].className += " even";', 'even = !even;', '}', '}', '}', '}', 'window.onload = stripe;', ); return join("\n", @javascript); } sub css { my @css = ( 'body{', 'font-family: "lucida grande", verdana, sans-serif;', 'font-size: 10pt;', 'color: #3d80df;', '}', '#container{', 'width: 960px;', 'margin-left: auto;', 'margin-right: auto;', 'border: 1px solid #3d80df;', 'margin-top: 50px;', '}', '#content{', 'float: left;', 'width: 620px;', 'padding-bottom: 20px;', '}', '#sidebar{', 'float: left;', 'width: 340px;', 'background-color: #3d80df;', 'padding-bottom: 20px;', '}', '#footer{', 'clear:both;', 'height: 40px;', 'color: #fff;', 'background-color: #3d80df;', 'text-align: center;', 'line-height: 3em;', '}', 'div.graph{', 'margin-top: 20px;', 'margin-left: 10px;', 'padding: 10px 10px 10px 10px;', 'width: 580px;', 'border: 1px solid #3d80df;', '}', 'div.graphnav{', 'margin-top: 0px;', 'margin-left: 10px;', 'background-color: #3d80df;', 'padding: 0px 10px 0px 10px;', 'width: 580px;', 'height: 20px;', 'border: 1px solid #3d80df;', 'text-align: right;', '}', 'div.graphnav p{', 'color: #fff;', 'margin-top: 1px;', '}', 'h3{', 'font-size: 12pt;', 'text-align: center;', '}', 'h5{', 'color: #fff;', 'font-size: 12pt;', 'text-align: center;', 'margin-bottom: -10px;', '}', 'a{', 'color: #fff;', '}', 'div.info p a{', 'color: #3d80df;', '}', 'table{', 'width: 600px;', 'border: 1px solid #7DAAEA;', 'margin-left: auto;', 'margin-right: auto;', '}', 'tr td{', 'padding: 3px 8px;', 'background: #fff;', '}', 'thead td{', 'color: #fff;', 'background-color: #3d80df;', 'font-weight: bold;', 'border-bottom: 0px solid #999;', 'text-align: center;', '}', 'tfoot td{', 'color: #fff;', 'background-color: #3d80df;', 'font-weight: bold;', 'border-bottom: 0px solid #999;', 'text-align: center;', '}', 'tbody td{', 'border-left: 0px solid #3d80df;', '}', 'tbody td a{', 'color: #3d80df;', '}', 'tbody tr.even td{', 'background: #eee;', '}', 'tbody tr.ruled td{', 'color: #000;', 'background-color: #C6E3FF;', '}', 'li{', 'display: block;', 'margin-left: -15px;', '}', 'div.info, div.success, div.error{', 'width: 600px;', 'border: 1px solid;', 'margin-left: auto;', 'margin-right: auto;', '}', 'div.success{', 'color: #4F8A10;', 'background-color: #DFF2BF;', '}', 'div.info{', 'color: #00529B;', 'background-color: #BDE5F8;', '}', 'div.error{', 'color: #D8000C;', 'background-color: #ffbaba;', '}', 'div.info p, div.success p, div.error p{', 'padding-left: 20px;', 'padding-right: 20px;', '}', 'div.element{', '}', 'div.element.button{', 'height: 60px;', 'width: 600px;', 'text-align: right;', '}', 'div.element.button input{', 'margin-top: 15px;', 'background-color: #3d80df;', 'color: #ffffff;', 'font-weight: bold;', 'height: 28px;', 'text-align: center;', 'width: 165px;', '}', ); return join("\n", @css); } # # NAVIGATION # sub parse_nav { my $param = shift; my @nav = split('/', $param); if (!defined($nav[0]) || $nav[0] !~ /^(content|device|info)$/) { $nav[0] = 'content'; $nav[1] = 0; } if ($nav[0] eq 'content' && (!defined($nav[1]) || $nav[1] !~ /^\d+$/)) { $nav[1] = 0; } if ($CONFIG{'ENABLE_GENERAL_STATISTICS'}) { $nav[2] = 'memory' if $nav[1] eq 'pi'; $nav[2] = 'media' if $nav[1] eq 'cl'; $nav[3] = 'day' unless defined($nav[3]); } return @nav; } sub build_directory_tree { my $dbh = shift; my $start_id = shift; my $end_id = shift; $end_id = 0 if $end_id !~ /^(\d+)$/; my $response = ''; my @results = (); PDLNA::ContentLibrary::get_items_by_parentid($dbh, $start_id, undef, undef, 0, \@results); $response .= '
    '; foreach my $result (@results) { my ($amount, undef) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'parent_id', $result->{id}); $response .= '
  • '.encode_entities($result->{title}).' ('.encode_entities($amount).')
    • '; if (PDLNA::ContentLibrary::is_itemid_under_parentid($dbh, $result->{id}, $end_id)) { $response .= build_directory_tree($dbh, $result->{id}, $end_id); } } $response .= '
'; return $response; } sub build_connected_devices { my $dbh = shift; my $response = ''; my @devices_ip = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, ip FROM device_ip', 'parameters' => [ ], }, \@devices_ip, ); $response .= '
    '; foreach my $device_ip (@devices_ip) { $response .= '
  • '.encode_entities($device_ip->{ip}).'
    • '; my @devices_udn = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, udn FROM device_udn WHERE device_ip_ref = ?', 'parameters' => [ $device_ip->{id}, ], }, \@devices_udn, ); $response .= ''; } $response .= '
'; return $response; } sub show_graph { my $nav = shift; my $response = ''; $response .= '
'; $response .= ''; $response .= '
'; $response .= '
'; $response .= '

|'; foreach my $period ('day', 'month', 'year') { $response .= ' '; if ($period eq $$nav[3]) { $response .= ''.encode_entities($period).' |'; } else { $response .= encode_entities($period).' |'; } } $response .= '

'; $response .= '
'; return $response; } sub graph { my $param = shift; my ($type, $period) = split(/_/, $param); if ($type !~ /^(memory|media)$/) { return PDLNA::HTTPServer::http_header({ 'statuscode' => 404, }); } if ($period !~ /^(day|month|year)$/) { return PDLNA::HTTPServer::http_header({ 'statuscode' => 404, }); } # # DATA DEFINITION # my %data_options = (); $data_options{'dateformatstring'} = '%Y-%m-%d %H:00' if $period eq 'day'; $data_options{'dateformatstring'} = '%Y-%m-%d' if $period eq 'month'; $data_options{'dateformatstring'} = '%Y-%m' if $period eq 'year'; if ($CONFIG{'DB_TYPE'} eq 'PGSQL') { $data_options{'dateformatstring'} = 'YYYY-MM-DD HH24:00' if $period eq 'day'; $data_options{'dateformatstring'} = 'YYYY-MM-DD' if $period eq 'month'; $data_options{'dateformatstring'} = 'YYYY-MM' if $period eq 'year'; } $data_options{'title'} = 'Memory usage' if $type eq 'memory'; $data_options{'title'} = 'Media items' if $type eq 'media'; $data_options{'dbtable'} = 'stat_mem' if $type eq 'memory'; $data_options{'dbtable'} = 'stat_items' if $type eq 'media'; $data_options{'title'} .= ' by last '.$period; $data_options{'dbfields'} = [ 'AVG(vms) AS avgvms', 'AVG(rss) AS avgrss', ] if $type eq 'memory'; $data_options{'datafields'} = [ 'avgvms', 'avgrss', ] if $type eq 'memory'; $data_options{'datadesc'} = [ 'vms', 'rss', ] if $type eq 'memory'; $data_options{'dbfields'} = [ 'AVG(audio) AS avgaudio', 'AVG(image) AS avgimage', 'AVG(video) AS avgvideo', ] if $type eq 'media'; $data_options{'datafields'} = [ 'avgaudio', 'avgimage', 'avgvideo', ] if $type eq 'media'; $data_options{'datadesc'} = [ 'audio', 'image', 'video', ] if $type eq 'media'; $data_options{'y_label'} = 'Bytes' if $type eq 'memory'; # # GD GRAPH DEFINITION # my %options = ( textclr => '#3d80df', labelclr => '#3d80df', axislabelclr => '#3d80df', fgclr => '#3d80df', boxclr => '#ffffff', dclrs => [ # '#8ab2eb', # '#77a6e8', # '#6399e5', # '#508ce2', '#3d80df', # '#3673c8', '#3066b2', # '#2a599c', '#244c85', # '#1e406f', '#183359', # '#122642', '#0c192c', # '#060c16', ], long_ticks => 1, y_min_value => 0, x_labels_vertical => 1, title => $data_options{'title'}, y_label => $data_options{'y_label'}, ); my $graph = GD::Graph::area->new(580, 300); $graph->set(%options); $graph->set_legend_font(GD::gdMediumBoldFont); $graph->set_title_font(GD::gdMediumBoldFont); $graph->set_x_axis_font(GD::gdMediumBoldFont); $graph->set_y_axis_font(GD::gdMediumBoldFont); $graph->set_legend(@{$data_options{'datadesc'}}); # # DATA GATHERING # my $dbh = PDLNA::Database::connect(); my %queries = ( 'SQLITE3' => "SELECT strftime('".$data_options{'dateformatstring'}."', datetime(date, 'unixepoch', 'localtime')) AS datetime, ".join(', ', @{$data_options{'dbfields'}})." FROM ".$data_options{'dbtable'}." WHERE date > strftime('%s', 'now', '-1 ".$period."', 'utc') GROUP BY datetime", 'MYSQL' => "SELECT date_format(FROM_UNIXTIME(date), '".$data_options{'dateformatstring'}."') as datetime, ".join(', ', @{$data_options{'dbfields'}})." FROM ".$data_options{'dbtable'}." WHERE date > UNIX_TIMESTAMP(DATE_SUB(now(), INTERVAL 1 ".$period.")) GROUP BY datetime", 'PGSQL' => "SELECT to_char(to_timestamp(date), '".$data_options{'dateformatstring'}."') AS datetime, ".join(', ', @{$data_options{'dbfields'}})." FROM ".$data_options{'dbtable'}." WHERE to_timestamp(date) > (now() - interval '1 ".$period."') GROUP BY datetime", ); my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => $queries{$CONFIG{'DB_TYPE'}}, 'parameters' => [ ], }, \@results, ); my @data = (); for (my $i = 0; $i < @results; $i++) { $data[0][$i] = $results[$i]->{datetime}; my $j = 1; foreach my $field (@{$data_options{'datafields'}}) { $data[$j][$i] = $results[$i]->{$field}; $j++; } } PDLNA::Database::disconnect($dbh); # # deliver the graph to the browser # my $image = undef; if ($image = $graph->plot(\@data)) { my $response = PDLNA::HTTPServer::http_header({ 'statuscode' => 200, 'content_type' => 'image/png', }); $response .= $image->png(); return $response; } else { PDLNA::Log::log('ERROR: Unable to generate graph: '.$graph->error(), 0, 'library'); return PDLNA::HTTPServer::http_header({ 'statuscode' => 404, }); } } 1; pDLNA/usr/lib/perl5/PDLNA/SOAPClient.pm0000700000175000017500000000573413366114774016453 0ustar geumageumapackage PDLNA::SOAPClient; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use SOAP::Lite; use XML::Simple; use PDLNA::Log; # constructor sub new { my $class = shift; my $params = shift; my $self = { PROXY => $$params{'proxy'}, URI => $$params{'uri'}, METHOD => undef, ARGUMENTS => [], }; bless($self, $class); return $self; } sub method { my $self = shift; my $method = shift; $self->{METHOD} = $method; } sub add_argument { my $self = shift; my $params = shift; push(@{$self->{ARGUMENTS}}, SOAP::Data->type($$params{'type'})->name($$params{'name'})->value($$params{'value'})); } sub send { my $self = shift; my $params = shift; my $request = SOAP::Lite->new( proxy => $self->{PROXY}, uri => $self->{URI}, ); PDLNA::Log::log('Doing request to '.$self->{PROXY}.' with method '.$self->{METHOD}.'.', 1, 'soap'); my $response = undef; eval { $response = $request->call($self->{METHOD} => $self->{ARGUMENTS}) }; if ($@) { PDLNA::Log::log('ERROR: Unable to perform SOAP request: '.$@, 0, 'soap'); } else { PDLNA::Log::log('HTTP status code: '.$response->{'_context'}->{'_transport'}->{'_proxy'}->{'_status'}, 2, 'soap'); if ($response->{'_context'}->{'_transport'}->{'_proxy'}->{'_is_success'}) { PDLNA::Log::log('HTTP response: '.$response->{'_context'}->{'_transport'}->{'_proxy'}->{'_http_response'}->{'_content'}, 3, 'soap'); if ($$params{'return_value'}) { my $xmlsimple = XML::Simple->new(); my $xml = undef; eval { $xml = $xmlsimple->XMLin($response->{'_context'}->{'_transport'}->{'_proxy'}->{'_http_response'}->{'_content'}) }; if ($@) { PDLNA::Log::log('ERROR: Unable to convert response with XML::Simple: '.$@, 0, 'soap'); } else { PDLNA::Log::log('Finished converting response with XML::Simple.', 3, 'soap'); PDLNA::Log::log('Return value in response: '.$xml->{'s:Body'}->{'u:'.$self->{METHOD}.'Response'}->{$$params{'return_value'}}, 3, 'soap'); return $xml->{'s:Body'}->{'u:'.$self->{METHOD}.'Response'}->{$$params{'return_value'}}; } } else { return 1; } } else { PDLNA::Log::log('ERROR: Unable to understand response (unknwon _is_success value): '.$response->{'_context'}->{'_transport'}->{'_proxy'}->{'_is_success'}, 0, 'soap'); } } return 0; } 1; pDLNA/usr/lib/perl5/PDLNA/Database.pm0000700000175000017500000003123313366114774016247 0ustar geumageumapackage PDLNA::Database; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use DBI; use PDLNA::Config; use PDLNA::Log; my %DBSTRING_AUTOINCREMENT = ( 'SQLITE3' => 'INTEGER PRIMARY KEY AUTOINCREMENT', 'MYSQL' => 'INTEGER PRIMARY KEY AUTO_INCREMENT', 'PGSQL' => 'SERIAL PRIMARY KEY', ); my %DBSTRING_CHARACTERSET = ( 'SQLITE3' => '', 'MYSQL' => 'DEFAULT CHARACTER SET=utf8', 'PGSQL' => '', ); sub connect { my $dsn = undef; my %settings = ( PrintError => 1, RaiseError => 1, ); if ($CONFIG{'DB_TYPE'} eq 'SQLITE3') { $dsn = 'dbi:SQLite:dbname='.$CONFIG{'DB_NAME'}; $settings{sqlite_unicode} = 1; } elsif ($CONFIG{'DB_TYPE'} eq 'MYSQL') { $dsn = 'dbi:mysql:dbname='.$CONFIG{'DB_NAME'}.';host=localhost'; $settings{mysql_enable_utf8} = 1; } elsif ($CONFIG{'DB_TYPE'} eq 'PGSQL') { $dsn = 'dbi:Pg:dbname='.$CONFIG{'DB_NAME'}.';host=localhost'; $settings{pg_enable_utf8} = 1; } my $dbh = DBI->connect($dsn, $CONFIG{'DB_USER'}, $CONFIG{'DB_PASS'}, \%settings); unless (defined($dbh)) { PDLNA::Log::fatal('Unable to connect to Database: '.$DBI::errstr); } if ($CONFIG{'DB_TYPE'} eq 'SQLITE3') { $dbh->do('PRAGMA encoding="UTF-8";'); } elsif ($CONFIG{'DB_TYPE'} eq 'PGSQL') { $dbh->do('set client_encoding = "utf-8";'); $dbh->do('set client_encoding = "iso8859-2";'); # a crapy workaround to get our umlaute working for now - setting client encoding to Latin2 # TODO FIX ME } return $dbh; } sub disconnect { my $dbh = shift; $dbh->disconnect() || PDLNA::Log::log('ERROR: Unable to disconnect from database: '.$DBI::errstr, 0, 'database'); } sub initialize_db { my $dbh = PDLNA::Database::connect(); my @tables = select_db_tables($dbh); if (grep(/^metadata$/, @tables)) { my @results = (); select_db( $dbh, { 'query' => 'SELECT value FROM metadata WHERE param = ?', 'parameters' => [ 'DBVERSION', ], 'perfdata' => 0, # disable writing perfdata }, \@results, ); # check if DB was build with a different database version of pDLNA if (!defined($results[0]->{value}) || $results[0]->{value} ne $CONFIG{'PROGRAM_DBVERSION'}) { $dbh->do('DELETE FROM metadata;'); _insert_metadata($dbh, 'DBVERSION', $CONFIG{'PROGRAM_DBVERSION'}); _insert_metadata($dbh, 'VERSION', PDLNA::Config::print_version()); _insert_metadata($dbh, 'TIMESTAMP', time()); $dbh->do('DROP TABLE items;') if grep(/^items$/, @tables); $dbh->do('DROP TABLE device_ip;') if grep(/^device_ip$/, @tables); $dbh->do('DROP TABLE device_bm;') if grep(/^device_bm$/, @tables); $dbh->do('DROP TABLE device_udn;') if grep(/^device_udn$/, @tables); $dbh->do('DROP TABLE device_nts;') if grep(/^device_nts$/, @tables); $dbh->do('DROP TABLE device_service;') if grep(/^device_service$/, @tables); $dbh->do('DROP TABLE stat_mem;') if grep(/^stat_mem$/, @tables); $dbh->do('DROP TABLE stat_items;') if grep(/^stat_items$/, @tables); $dbh->do('DROP TABLE stat_db;') if grep(/^stat_db$/, @tables); @tables = (); } } else { $dbh->do("CREATE TABLE metadata ( param VARCHAR(128) PRIMARY KEY, value VARCHAR(128) ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); _insert_metadata($dbh, 'DBVERSION', $CONFIG{'PROGRAM_DBVERSION'}); _insert_metadata($dbh, 'VERSION', PDLNA::Config::print_version()); _insert_metadata($dbh, 'TIMESTAMP', time()); } unless (grep(/^items$/, @tables)) { $dbh->do("CREATE TABLE items ( id $DBSTRING_AUTOINCREMENT{$CONFIG{'DB_TYPE'}}, parent_id INTEGER, ref_id INTEGER, media_attributes INTEGER DEFAULT 0, item_type INTEGER DEFAULT 0, media_type VARCHAR(12), mime_type VARCHAR(128), fullname VARCHAR(2048), title VARCHAR(2048), file_extension VARCHAR(4), date BIGINT, size BIGINT, width INTEGER DEFAULT 0, height INTEGER DEFAULT 0, duration INTEGER DEFAULT 0, bitrate INTEGER DEFAULT 0, vbr INTEGER DEFAULT 0, container VARCHAR(128), audio_codec VARCHAR(128), video_codec VARCHAR(128) ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); # CREATE INDEX TO IMPROVE DB PERFORMANCE $dbh->do('CREATE INDEX parent_id ON items (parent_id)'); $dbh->do('CREATE INDEX ref_id ON items (ref_id)'); $dbh->do('CREATE INDEX item_type ON items (item_type)'); $dbh->do('CREATE INDEX fullname ON items (fullname)'); $dbh->do('CREATE INDEX title ON items (title)'); } # # item_type VALUES # 0 - directory # 1 - media item (audio, video, image) # 2 - subtitles # unless (grep(/^device_ip$/, @tables)) { $dbh->do("CREATE TABLE device_ip ( id $DBSTRING_AUTOINCREMENT{$CONFIG{'DB_TYPE'}}, ip VARCHAR(15), user_agent VARCHAR(128), last_seen BIGINT ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } unless (grep(/^device_bm$/, @tables)) { $dbh->do("CREATE TABLE device_bm ( id $DBSTRING_AUTOINCREMENT{$CONFIG{'DB_TYPE'}}, device_ip_ref INTEGER, item_id_ref INTEGER, pos_seconds INTEGER ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } unless (grep(/^device_udn$/, @tables)) { $dbh->do("CREATE TABLE device_udn ( id $DBSTRING_AUTOINCREMENT{$CONFIG{'DB_TYPE'}}, device_ip_ref INTEGER, udn VARCHAR(64), ssdp_banner VARCHAR(256), desc_url VARCHAR(512), rela_url VARCHAR(512), base_url VARCHAR(512), type VARCHAR(256), model_name VARCHAR(256), friendly_name VARCHAR(256) ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } unless (grep(/^device_nts$/, @tables)) { $dbh->do("CREATE TABLE device_nts ( id $DBSTRING_AUTOINCREMENT{$CONFIG{'DB_TYPE'}}, device_udn_ref INTEGER, type VARCHAR(128), expire BIGINT ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } unless (grep(/^device_service$/, @tables)) { $dbh->do("CREATE TABLE device_service ( id $DBSTRING_AUTOINCREMENT{$CONFIG{'DB_TYPE'}}, device_udn_ref INTEGER, service_id VARCHAR(256), type VARCHAR(256), control_url VARCHAR(512), event_url VARCHAR(512), scpd_url VARCHAR(512) ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } unless (grep(/^stat_mem$/, @tables)) { $dbh->do("CREATE TABLE stat_mem ( date BIGINT PRIMARY KEY, vms BIGINT, rss BIGINT ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } unless (grep(/^stat_items$/, @tables)) { $dbh->do("CREATE TABLE stat_items ( date BIGINT PRIMARY KEY, audio INTEGER, audio_size BIGINT, video INTEGER, video_size BIGINT, image INTEGER, image_size BIGINT ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } unless (grep(/^stat_db$/, @tables)) { $dbh->do("CREATE TABLE stat_db ( date BIGINT, query_type VARCHAR(6), query VARCHAR(512), exec_time INTEGER ) $DBSTRING_CHARACTERSET{$CONFIG{'DB_TYPE'}};" ); } PDLNA::Database::disconnect($dbh); } sub select_db_tables { my $dbh = shift; my %queries = ( 'SQLITE3' => "SELECT name FROM sqlite_master WHERE type = 'table'", 'MYSQL' => "SELECT table_name FROM information_schema.tables WHERE table_type = 'base table'", 'PGSQL' => "SELECT table_name FROM information_schema.tables WHERE table_schema = 'public'", ); my @tables = (); select_db_array( $dbh, { 'query' => $queries{$CONFIG{'DB_TYPE'}}, 'parameters' => [ ], 'perfdata' => 0, # disable writing perfdata }, \@tables, ); return @tables; } sub select_db_array { my $dbh = shift; my $params = shift; my $result = shift; my $perfdata = defined($$params{'perfdata'}) ? 0 : 1; my $starttime = PDLNA::Utils::get_timestamp_ms(); my $sth = $dbh->prepare($$params{'query'}) || PDLNA::Log::log('ERROR: Cannot prepare database query: '.$DBI::errstr, 0, 'database'); $sth->execute(@{$$params{'parameters'}}) || PDLNA::Log::log('ERROR: Cannot execute database query: '.$DBI::errstr, 0, 'database'); while (my $data = $sth->fetchrow_array()) { push(@{$result}, $data); } PDLNA::Log::log('ERROR: Data fetching terminated early by error: '.$DBI::errstr, 0, 'database') if $DBI::err; _log_query($dbh, $params, $starttime, $perfdata); } sub select_db_field_int { my $dbh = shift; my $params = shift; my $perfdata = defined($$params{'perfdata'}) ? 0 : 1; my $starttime = PDLNA::Utils::get_timestamp_ms(); my $sth = $dbh->prepare($$params{'query'}) || PDLNA::Log::log('ERROR: Cannot prepare database query: '.$DBI::errstr, 0, 'database'); $sth->execute(@{$$params{'parameters'}}) || PDLNA::Log::log('ERROR: Cannot execute database query: '.$DBI::errstr, 0, 'database'); my $result = $sth->fetchrow_array(); _log_query($dbh, $params, $starttime, $perfdata); return $result || 0; } sub select_db { my $dbh = shift; my $params = shift; my $result = shift; my $perfdata = defined($$params{'perfdata'}) ? 0 : 1; my $starttime = PDLNA::Utils::get_timestamp_ms(); my $sth = $dbh->prepare($$params{'query'}) || PDLNA::Log::log('ERROR: Cannot prepare database query: '.$DBI::errstr, 0, 'database'); $sth->execute(@{$$params{'parameters'}}) || PDLNA::Log::log('ERROR: Cannot execute database query: '.$DBI::errstr, 0, 'database'); while (my $data = $sth->fetchrow_hashref) { push(@{$result}, $data); } PDLNA::Log::log('ERROR: Data fetching terminated early by error: '.$DBI::errstr, 0, 'database') if $DBI::err; _log_query($dbh, $params, $starttime, $perfdata); } sub insert_db { my $dbh = shift; my $params = shift; my $perfdata = defined($$params{'perfdata'}) ? 0 : 1; my $starttime = PDLNA::Utils::get_timestamp_ms(); my $sth = $dbh->prepare($$params{'query'}) || PDLNA::Log::log('ERROR: Cannot prepare database query: '.$DBI::errstr, 0, 'database'); $sth->execute(@{$$params{'parameters'}}) || PDLNA::Log::log('ERROR: Cannot execute database query: '.$DBI::errstr, 0, 'database'); _log_query($dbh, $params, $starttime, $perfdata); } sub update_db { my $dbh = shift; my $params = shift; my $perfdata = defined($$params{'perfdata'}) ? 0 : 1; my $starttime = PDLNA::Utils::get_timestamp_ms(); my $sth = $dbh->prepare($$params{'query'}) || PDLNA::Log::log('ERROR: Cannot prepare database query: '.$DBI::errstr, 0, 'database'); $sth->execute(@{$$params{'parameters'}}) || PDLNA::Log::log('ERROR: Cannot execute database query: '.$DBI::errstr, 0, 'database'); _log_query($dbh, $params, $starttime, $perfdata); } sub delete_db { my $dbh = shift; my $params = shift; my $perfdata = defined($$params{'perfdata'}) ? 0 : 1; my $starttime = PDLNA::Utils::get_timestamp_ms(); my $sth = $dbh->prepare($$params{'query'}) || PDLNA::Log::log('ERROR: Cannot prepare database query: '.$DBI::errstr, 0, 'database'); $sth->execute(@{$$params{'parameters'}}) || PDLNA::Log::log('ERROR: Cannot execute database query: '.$DBI::errstr, 0, 'database'); _log_query($dbh, $params, $starttime, $perfdata); } # # HELPER FUNCTIONS # sub _insert_performance_data { my $dbh = shift; my $query = shift; my $time = shift; my $query_type = substr($query, 0, 6); insert_db( $dbh, { 'query' => 'INSERT INTO stat_db (date, query_type, query, exec_time) VALUES (?,?,?,?)', 'parameters' => [ time(), $query_type, $query, $time, ], 'perfdata' => 0, # disable writing perfdata }, ); } sub _insert_metadata { my $dbh = shift; my $param = shift; my $value = shift; insert_db( $dbh, { 'query' => 'INSERT INTO metadata (param, value) VALUES (?,?)', 'parameters' => [ $param, $value, ], 'perfdata' => 0, # disable writing perfdata }, ); } sub _log_query { my $dbh = shift; my $params = shift; my $starttime = shift || 0; my $perfdata = shift; my $endtime = PDLNA::Utils::get_timestamp_ms(); my $time = $endtime - $starttime; my $parameters = ''; foreach my $param (@{$$params{'parameters'}}) { if (defined($param)) { $parameters .= $param.', '; } else { $parameters .= 'undefined, '; } } substr($parameters, -2) = ''; if ($perfdata && $CONFIG{'ENABLE_DATABASE_STATISTICS'}) { _insert_performance_data($dbh, $$params{'query'}, $time); } PDLNA::Log::log('(Query took '.$time.'ms): '. $$params{'query'}.' - '.$parameters, 1, 'database'); } 1; pDLNA/usr/lib/perl5/PDLNA/Status.pm0000700000175000017500000000632213366114774016027 0ustar geumageumapackage PDLNA::Status; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use LWP::UserAgent; use XML::Simple; use PDLNA::Config; use PDLNA::Database; use PDLNA::Log; use PDLNA::SOAPMessages; sub check_update_periodic { PDLNA::Log::log('Starting thread for checking periodically for a new version of pDLNA.', 1, 'default'); while(1) { check_update(); sleep 86400; } } sub do_http_request { my $ua = LWP::UserAgent->new(); $ua->agent($CONFIG{'PROGRAM_NAME'}."/".PDLNA::Config::print_version()); my $xml_obj = XML::Simple->new(); my $xml = { 'deviceinformation' => { 'udn' => $CONFIG{'UUID'}, }, 'statusinformation' => { 'version' => $CONFIG{'PROGRAM_VERSION'}, 'beta' => $CONFIG{'PROGRAM_BETA'}, }, }; my $response = $ua->post( $CONFIG{'PROGRAM_WEBSITE'}.'/cgi-bin/status.pl', Content_Type => 'text/xml', Content => $xml_obj->XMLout( $xml, XMLDecl => '', NoAttr => 1, ), ); return $response; } sub check_update { my $response = do_http_request(); if ($response->is_success) { my $xml_obj = XML::Simple->new(); my $xml = $xml_obj->XMLin($response->decoded_content()); PDLNA::Log::log('Check4Updates was successful: '.$xml->{'response'}->{'result'}.' ('.$xml->{'response'}->{'resultID'}.').', 1, 'default'); if ($xml->{'response'}->{'resultID'} == 4) { PDLNA::Log::log($CONFIG{'PROGRAM_NAME'}.' is available in version '.$xml->{'response'}->{'NewVersion'}.'. Please update your installation.', 1, 'default'); if ($CONFIG{'CHECK_UPDATES_NOTIFICATION'}) { PDLNA::Log::log('Sending notification to currently connected urn:samsung.com:serviceId:MessageBoxService services.', 1, 'default'); my $dbh = PDLNA::Database::connect(); my @device_services = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT type, control_url FROM device_service WHERE service_id = ?', 'parameters' => [ 'urn:samsung.com:serviceId:MessageBoxService' ], }, \@device_services, ); PDLNA::Database::disconnect($dbh); foreach my $service (@device_services) { PDLNA::Log::log('Sending sms to '.$service->{control_url}.'.', 1, 'default'); my $message = 'A new version of '.$CONFIG{'PROGRAM_NAME'}.' is available: '.$xml->{'response'}->{'NewVersion'}; PDLNA::SOAPMessages::send_sms($service->{type}, $service->{control_url}, $message); } } } } else { PDLNA::Log::log('Check4Updates was NOT successful: HTTP Status Code '.$response->status_line().'.', 1, 'default'); } } 1; pDLNA/usr/lib/perl5/PDLNA/Log.pm0000700000175000017500000000725213366114774015270 0ustar geumageumapackage PDLNA::Log; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Date::Format; use Fcntl ':flock'; use Sys::Syslog qw(:standard :macros); use PDLNA::Config; sub log { my $message = shift; my $debuglevel = shift || 0; my $category = shift || undef; my (undef, $filename, $line) = caller(); if ( $debuglevel == 0 || ( $debuglevel <= $CONFIG{'DEBUG'} && (defined($category) && grep(/^$category$/, @{$CONFIG{'LOG_CATEGORY'}})) ) ) { $message = add_message_info($message, $debuglevel, $category, $filename, $line); write_log_msg($message, $debuglevel, $category); } } sub fatal { my $message = shift; my $debuglevel = shift || 0; my $category = shift || undef; my (undef, $filename, $line) = caller(); print STDERR add_message_info($message, $debuglevel, $category, $filename, $line)."\n"; print STDERR "Going to terminate $CONFIG{'PROGRAM_NAME'}/v".PDLNA::Config::print_version()." on $CONFIG{'OS'}/$CONFIG{'OS_VERSION'} with FriendlyName '$CONFIG{'FRIENDLY_NAME'}' ...\n"; exit 1; } sub add_message_info { my $message = shift; my $debuglevel = shift; my $category = shift; my $filename = shift || undef; my $line = shift || undef; $message = '('.$filename.':'.$line.'): '.$message if defined($filename); return $message if $CONFIG{'LOG_FILE'} eq 'SYSLOG'; $message = $category.'('.$debuglevel.') '.$message if defined($category); return time2str($CONFIG{'DATE_FORMAT'}, time()).' '.$message; } sub write_log_msg { my $message = shift; my $debuglevel = shift; my $category = shift; if ($CONFIG{'LOG_FILE'} eq 'STDERR') { print STDERR $message."\n"; } elsif ($CONFIG{'LOG_FILE'} eq 'SYSLOG') { openlog($CONFIG{'PROGRAM_NAME'}.' ('.$category.')', 'ndelay', LOG_LOCAL0); syslog(LOG_INFO, $message); } else { append_logfile($message); } } sub append_logfile { my $message = shift; my $filesize = (stat($CONFIG{'LOG_FILE'}))[7] || 0; if ($filesize > $CONFIG{'LOG_FILE_MAX_SIZE'}) { if ($CONFIG{'LOG_FILE_ROTATION_AMOUNT'}) { # delete the oldest log file from rotation if (-f $CONFIG{'LOG_FILE'}.'.'.$CONFIG{'LOG_FILE_ROTATION_AMOUNT'}) { unlink($CONFIG{'LOG_FILE'}.'.'.$CONFIG{'LOG_FILE_ROTATION_AMOUNT'}) || &log('ERROR: Unable to remove LogFile: '.$!, 0, 'default') } # increase number of already rotated logfiles for (my $i = $CONFIG{'LOG_FILE_ROTATION_AMOUNT'}; $i > 0; $i--) { my $j = $i-1; if (-f $CONFIG{'LOG_FILE'}.'.'.$j) { rename($CONFIG{'LOG_FILE'}.'.'.$j, $CONFIG{'LOG_FILE'}.'.'.$i) || &log('ERROR: Unable to rename LogFile: '.$!, 0, 'default'); } } # rename current logfile rename($CONFIG{'LOG_FILE'}, $CONFIG{'LOG_FILE'}.'.1') || &log('ERROR: Unable to rename LogFile: '.$!, 0, 'default'); } # if no ROTATION configured, just overwrite the old file open(FILE, '>:encoding(UTF-8)', $CONFIG{'LOG_FILE'}); } else { open(FILE, '>>:encoding(UTF-8)', $CONFIG{'LOG_FILE'}); } flock(FILE, LOCK_EX); print FILE $message."\n"; flock(FILE, LOCK_UN); close(FILE); } 1; pDLNA/usr/lib/perl5/PDLNA/DeviceServiceAction.pm0000700000175000017500000001000413366114774020412 0ustar geumageumapackage PDLNA::DeviceServiceAction; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use threads; use threads::shared; # constructor sub new { my $class = shift; my $params = shift; my %self : shared = ( ACTION => $$params{'action'}, ); my %parameters : shared = (); foreach my $parameter (keys %{$$params{'parameters'}}) { my %parameter_definition : shared = (); foreach my $param ('direction', 'retval', 'relatedStateVariable') { $parameter_definition{$param} = $$params{'parameters'}{$parameter}{$param} if defined($$params{'parameters'}{$parameter}{$param}); } $parameters{$parameter} = \%parameter_definition; } $self{PARAMETERS} = \%parameters; my %variables : shared = (); foreach my $variable (keys %{$$params{'variables'}}) { my %variable_definition : shared = (); foreach my $param ('dataType', 'sendEvents') { $variable_definition{$param} = $$params{'variables'}{$variable}{$param} if defined($$params{'variables'}{$variable}{$param}); } unless (ref($$params{'variables'}{$variable}{'defaultValue'}) eq 'HASH') { $variable_definition{'defaultValue'} = $$params{'variables'}{$variable}{'defaultValue'} if defined($$params{'variables'}{$variable}{'defaultValue'}); } if (ref($$params{'variables'}{$variable}{'allowedValueList'}->{'allowedValue'}) eq 'ARRAY') { my @allowed_values : shared = (); foreach my $value (@{$$params{'variables'}{$variable}{'allowedValueList'}->{'allowedValue'}}) { push(@allowed_values, $value); } $variable_definition{'allowedValueList'} = \@allowed_values; } if (ref($$params{'variables'}{$variable}{'allowedValueRange'}) eq 'HASH') { my %allowed_value_range : shared = (); foreach my $key (keys %{$$params{'variables'}{$variable}{'allowedValueRange'}}) { $allowed_value_range{$key} = $$params{'variables'}{$variable}{'allowedValueRange'}{$key}; } $variable_definition{'allowedValueRange'} = \%allowed_value_range; } $variables{$variable} = \%variable_definition; } $self{VARIABLES} = \%variables; bless(\%self, $class); return \%self; } # prints the object information sub print_object { my $self = shift; my $string = ''; $string .= "\t\t\t\t\tObject PDLNA::DeviceServiceAction\n"; $string .= "\t\t\t\t\t\tAction: ".$self->{ACTION}."\n" if defined($self->{ACTION}); $string .= "\t\t\t\t\t\tParameters: \n"; foreach my $parameter (keys %{$self->{PARAMETERS}}) { $string .= "\t\t\t\t\t\t\tParameterName: ".$parameter."\n"; foreach my $def (keys %{$self->{PARAMETERS}{$parameter}}) { $string .= "\t\t\t\t\t\t\t\t".$def." ".$self->{PARAMETERS}{$parameter}{$def}."\n"; } $string .= "\t\t\t\t\t\t\t\tVariableDefinition:\n"; foreach my $def (keys %{$self->{VARIABLES}{$parameter}}) { if ($def eq 'allowedValueList') { $string .= "\t\t\t\t\t\t\t\t\t".$def." ".join(', ', @{$self->{VARIABLES}{$parameter}{$def}})."\n"; } elsif ($def eq 'allowedValueRange') { foreach my $key (keys %{$self->{VARIABLES}{$parameter}{$def}}) { $string .= "\t\t\t\t\t\t\t\t\tallowedValueRange_".$key." ".$self->{VARIABLES}{$parameter}{$def}{$key}."\n"; } } else { $string .= "\t\t\t\t\t\t\t\t\t".$def." ".$self->{VARIABLES}{$parameter}{$def}."\n"; } } } $string .= "\t\t\t\t\tObject PDLNA::DeviceServiceAction END\n"; return $string; } 1; pDLNA/usr/lib/perl5/PDLNA/ContentLibrary.pm0000700000175000017500000012157413366114774017512 0ustar geumageumapackage PDLNA::ContentLibrary; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use DBI; use Date::Format; use File::Basename; use File::Glob qw(bsd_glob); use File::MimeInfo; use PDLNA::Config; use PDLNA::Database; use PDLNA::FFmpeg; use PDLNA::Log; use PDLNA::Media; use PDLNA::Utils; sub index_directories_thread { PDLNA::Log::log('Starting PDLNA::ContentLibrary::index_directories_thread().', 1, 'library'); while(1) { my $dbh = PDLNA::Database::connect(); $dbh->{AutoCommit} = 0; my $timestamp_start = time(); foreach my $directory (@{$CONFIG{'DIRECTORIES'}}) # we are not able to run this part in threads - since glob seems to be NOT thread safe { _process_directory( $dbh, { 'fullname' => $directory->{'path'}, 'media_type' => $directory->{'type'}, 'recursion' => $directory->{'recursion'}, 'exclude_dirs' => $directory->{'exclude_dirs'}, 'exclude_items' => $directory->{'exclude_items'}, 'allow_playlists' => $directory->{'allow_playlists'}, 'parent_id' => 0, }, ); } # my $i = 0; # foreach my $external (@{$CONFIG{'EXTERNALS'}}) # { # add_file_to_db( # $dbh, # { # 'element' => $external->{'command'} || $external->{'streamurl'}, # 'media_type' => $external->{'type'}, # 'mime_type' => '', # need to determine # 'element_basename' => $external->{'name'}, # 'element_dirname' => '', # set the directory to nothing - no parent # 'external' => 1, # 'sequence' => $i, # 'root' => 1, # }, # ); # $i++; # } $dbh->commit(); my $timestamp_end = time(); # update our timestamp when finished PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE metadata SET value = ? WHERE param = ?', 'parameters' => [ $timestamp_end, 'TIMESTAMP', ], }, ); $dbh->commit(); my $duration = $timestamp_end - $timestamp_start; PDLNA::Log::log('Indexing configured media directories took '.$duration.' seconds.', 1, 'library'); my ($amount, $size) = get_amount_size_items_by($dbh, 'item_type', 1); PDLNA::Log::log('Configured media directories include '.$amount.' items with '.PDLNA::Utils::convert_bytes($size).' of size.', 1, 'library'); _cleanup_contentlibrary($dbh); $dbh->commit(); $timestamp_start = time(); _fetch_media_attributes($dbh); $dbh->commit(); $timestamp_end = time(); $duration = $timestamp_end - $timestamp_start; PDLNA::Log::log('Getting media attributes for indexed media items took '.$duration.' seconds.', 1, 'library'); PDLNA::Database::disconnect($dbh); sleep $CONFIG{'RESCAN_MEDIA'}; } } sub process_directory { my $dbh = shift; my $params = shift; $$params{'path'} =~ s/\/$//; add_directory_to_db($dbh, $$params{'path'}, $$params{'rootdir'}, 0); $dbh->commit(); $$params{'path'} = PDLNA::Utils::escape_brackets($$params{'path'}); PDLNA::Log::log('Globbing directory: '.PDLNA::Utils::create_filesystem_path([ $$params{'path'}, '*', ]).'.', 2, 'library'); my @elements = bsd_glob(PDLNA::Utils::create_filesystem_path([ $$params{'path'}, '*', ])); foreach my $element (sort @elements) { my $element_basename = basename($element); if (-d "$element" && $element =~ /lost\+found$/) { PDLNA::Log::log('Skipping '.$element.' directory.', 2, 'library'); next; } elsif (-d "$element" && $$params{'recursion'} eq 'yes' && !grep(/^\Q$element_basename\E$/, @{$$params{'exclude_dirs'}})) { PDLNA::Log::log('Processing directory '.$element.'.', 2, 'library'); process_directory( $dbh, { 'path' => $element, 'type' => $$params{'type'}, 'recursion' => $$params{'recursion'}, 'exclude_dirs' => $$params{'exclude_dirs'}, 'exclude_items' => $$params{'exclude_items'}, 'allow_playlists' => $$params{'allow_playlists'}, 'rootdir' => 0, } ); } elsif (-f "$element" && !grep(/^\Q$element_basename\E$/, @{$$params{'exclude_items'}})) { my $mime_type = mimetype($element); PDLNA::Log::log('Processing '.$element.' with MimeType '.$mime_type.'.', 2, 'library'); if (PDLNA::Media::is_supported_mimetype($mime_type)) { my $media_type = PDLNA::Media::return_type_by_mimetype($mime_type); if ($media_type && ($media_type eq $$params{'type'} || $$params{'type'} eq "all")) { PDLNA::Log::log('Adding '.$media_type.' element '.$element.'.', 2, 'library'); my $fileid = add_file_to_db( $dbh, { 'element' => $element, 'media_type' => $media_type, 'mime_type' => $mime_type, 'element_basename' => $element_basename, 'element_dirname' => dirname($element), 'external' => 0, 'root' => 0, }, ); if ($media_type eq 'video') { my $tmp = $1 if $element =~ /^(.+)\.\w{3,4}$/; foreach my $extension ('srt') { if (-f $tmp.'.'.$extension) { my $subtitle_mimetype = mimetype($tmp.'.'.$extension); if (PDLNA::Media::is_supported_subtitle($subtitle_mimetype)) { add_subtitle_to_db( $dbh, { 'file_id' => $fileid, 'path' => $tmp.'.'.$extension, 'mimetype' => $subtitle_mimetype, 'type' => $extension, }, ); } } } } } } elsif (PDLNA::Media::is_supported_playlist($mime_type)) { PDLNA::Log::log('Adding playlist '.$element.' as directory.', 2, 'library'); add_directory_to_db($dbh, $element, $$params{'rootdir'}, 1); my @items = PDLNA::Media::parse_playlist($element, $mime_type); for (my $i = 0; $i < @items; $i++) { if (PDLNA::Media::is_supported_stream($items[$i]) && $CONFIG{'LOW_RESOURCE_MODE'} == 0) { add_file_to_db( $dbh, { 'element' => $items[$i], 'media_type' => '', # need to determine 'mime_type' => '', # need to determine 'element_basename' => $items[$i], 'element_dirname' => $element, # set the directory to the playlist file itself 'external' => 1, 'sequence' => $i, 'root' => 0, }, ); } else { unless (PDLNA::Utils::is_path_absolute($items[$i])) { $items[$i] = PDLNA::Utils::create_filesystem_path([ dirname($element), $items[$i], ]); } if (-f $items[$i]) { my $mime_type = mimetype($items[$i]); my $media_type = PDLNA::Media::return_type_by_mimetype($mime_type); add_file_to_db( $dbh, { 'element' => $items[$i], 'media_type' => $media_type, 'mime_type' => $mime_type, 'element_basename' => basename($items[$i]), 'element_dirname' => $element, # set the directory to the playlist file itself 'external' => 0, 'sequence' => $i, 'root' => 0, }, ); } } } # delete not (any more) configured - media files from playlists my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID, NAME, FULLNAME FROM FILES WHERE PATH = ?', 'parameters' => [ $element, ], }, \@results, ); foreach my $result (@results) { unless (grep(/^\Q$result->{NAME}\E$/, @items) || grep(/^\Q$result->{FULLNAME}\E$/, @items)) { delete_all_by_itemid($dbh, $result->{ID}); } } } else { PDLNA::Log::log('Element '.$element.' skipped. Unsupported MimeType '.$mime_type.'.', 2, 'library'); } } else { PDLNA::Log::log('Element '.$element.' skipped. Inlcuded in ExcludeList.', 2, 'library'); } } } sub add_directory_to_db { my $dbh = shift; my $path = shift; my $rootdir = shift; my $type = shift; # check if directoriy is in db my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM DIRECTORIES WHERE PATH = ?', 'parameters' => [ $path, ], }, \@results, ); unless (defined($results[0]->{ID})) { # add directory to database PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO DIRECTORIES (NAME, PATH, DIRNAME, ROOT, TYPE) VALUES (?,?,?,?,?)', 'parameters' => [ basename($path), $path, dirname($path), $rootdir, $type ], }, ); PDLNA::Log::log('Added directory '.$path.' to ContentLibrary.', 2, 'library'); } } sub add_subtitle_to_db { my $dbh = shift; my $params = shift; # check if file is in db my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, date, size FROM subtitles WHERE fullname = ? AND fileid_ref = ? AND mime_type = ?', 'parameters' => [ $$params{'path'}, $$params{'file_id'}, $$params{'mimetype'}, ], }, \@results, ); my @fileinfo = stat($$params{'path'}); if (defined($results[0]->{id})) { if ($results[0]->{size} != $fileinfo[7] || $results[0]->{date} != $fileinfo[9]) { # update the datbase entry (something changed) PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE subtitles SET date = ?, size = ? WHERE id = ?;', 'parameters' => [ $fileinfo[9], $fileinfo[7], $results[0]->{ID}, ], }, ); } } else # element not in database { PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO subtitles (fileid_ref, fullname, name, type, mime_type, date, size) VALUES (?,?,?,?,?,?,?)', 'parameters' => [ $$params{'file_id'}, $$params{'path'}, basename($$params{'path'}), $$params{'type'}, $$params{'mimetype'}, $fileinfo[9], $fileinfo[7], ], }, ); } } sub add_file_to_db { my $dbh = shift; my $params = shift; my @fileinfo = (); $fileinfo[9] = 0; $fileinfo[7] = 0; my $file_extension = ''; if ($$params{'external'} == 0) { @fileinfo = stat($$params{'element'}); $file_extension = $1 if $$params{'element'} =~ /(\w{3,4})$/; } $$params{'sequence'} = 0 if !defined($$params{'sequence'}); # check if file is in db my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID, DATE, SIZE, MIME_TYPE, PATH, SEQUENCE FROM FILES WHERE FULLNAME = ? AND PATH = ?', 'parameters' => [ $$params{'element'}, $$params{'element_dirname'}, ], }, \@results, ); if (defined($results[0]->{ID})) { if ( $results[0]->{SIZE} != $fileinfo[7] || $results[0]->{DATE} != $fileinfo[9] || # $results[0]->{MIME_TYPE} ne $$params{'mime_type'} || $results[0]->{SEQUENCE} != $$params{'sequence'} ) { # update the datbase entry (something changed) PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILES SET DATE = ?, SIZE = ?, MIME_TYPE = ?, TYPE = ?, SEQUENCE = ? WHERE ID = ?;', 'parameters' => [ $fileinfo[9], $fileinfo[7], $$params{'mime_type'}, $$params{'media_type'}, $$params{'sequence'}, $results[0]->{ID} ], }, ); # set FILEINFO entry to INVALID data PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILEINFO SET VALID = ? WHERE FILEID_REF = ?;', 'parameters' => [ 0, $results[0]->{ID}, ], }, ); } } else { # insert file to db PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO FILES (NAME, PATH, FULLNAME, FILE_EXTENSION, DATE, SIZE, MIME_TYPE, TYPE, EXTERNAL, ROOT, SEQUENCE) VALUES (?,?,?,?,?,?,?,?,?,?,?)', 'parameters' => [ $$params{'element_basename'}, $$params{'element_dirname'}, $$params{'element'}, $file_extension, $fileinfo[9], $fileinfo[7], $$params{'mime_type'}, $$params{'media_type'}, $$params{'external'}, $$params{'root'}, $$params{'sequence'}, ], }, ); # select ID of newly added element @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM FILES WHERE FULLNAME = ? AND PATH = ?', 'parameters' => [ $$params{'element'}, $$params{'element_dirname'}, ], }, \@results, ); # insert entry to FILEINFO table PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO FILEINFO (FILEID_REF, VALID) VALUES (?,?)', 'parameters' => [ $results[0]->{ID}, 0, ], }, ); } return $results[0]->{ID}; } sub cleanup_contentlibrary { my $dbh = shift; PDLNA::Log::log('Started to remove non existant files.', 1, 'library'); my @files = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID, FULLNAME FROM FILES WHERE EXTERNAL = 0', 'parameters' => [ ], }, \@files, ); foreach my $file (@files) { unless (-f "$file->{FULLNAME}") { delete_all_by_itemid($dbh, $file->{ID}); } } my @directories = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID, PATH, TYPE FROM DIRECTORIES', 'parameters' => [ ], }, \@directories, ); foreach my $directory (@directories) { if ( ($directory->{TYPE} == 0 && !-d "$directory->{PATH}") || ($directory->{TYPE} == 1 && !-f "$directory->{PATH}") ) { PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM DIRECTORIES WHERE ID = ?', 'parameters' => [ $directory->{ID}, ], }, ); } } my @subtitles = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, fullname FROM subtitles', 'parameters' => [ ], }, \@subtitles, ); foreach my $subtitle (@subtitles) { unless (-f $subtitle->{fullname}) { PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM subtitles WHERE id = ?', 'parameters' => [ $subtitle->{id}, ], }, ); } } # delete not (any more) configured - directories from database my @rootdirs = (); get_subdirectories_by_id($dbh, 0, undef, undef, \@rootdirs); my @conf_directories = (); foreach my $directory (@{$CONFIG{'DIRECTORIES'}}) { push(@conf_directories, $directory->{'path'}); } foreach my $rootdir (@rootdirs) { unless (grep(/^$rootdir->{PATH}\/$/, @conf_directories)) { delete_subitems_recursively($dbh, $rootdir->{ID}); } } # delete not (any more) configured - external from database my @externals = (); get_subfiles_by_id($dbh, 0, undef, undef, \@externals); my @conf_externals = (); foreach my $external (@{$CONFIG{'EXTERNALS'}}) { push(@conf_externals, $external->{'name'}); } foreach my $external (@externals) { unless (grep(/^$external->{NAME}$/, @conf_externals)) { delete_all_by_itemid($dbh, $external->{ID}); } } # delete external media items from database, if LOW_RESOURCE_MODE has been enabled if ($CONFIG{'LOW_RESOURCE_MODE'} == 1) { my @externalfiles = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM FILES WHERE EXTERNAL = 1', 'parameters' => [ ], }, \@externalfiles, ); foreach my $externalfile (@externalfiles) { delete_all_by_itemid($dbh, $externalfile->{ID}); } } foreach my $directory (@{$CONFIG{'DIRECTORIES'}}) { # delete excluded directories and their items foreach my $excl_directory (@{$$directory{'exclude_dirs'}}) { my @directories = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM DIRECTORIES WHERE NAME = ? AND PATH LIKE ?', 'parameters' => [ $excl_directory, $directory->{'path'}.'%', ], }, \@directories, ); foreach my $dir (@directories) { delete_subitems_recursively($dbh, $dir->{ID}); } } # delete excluded items foreach my $excl_items (@{$$directory{'exclude_items'}}) { my @items = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM FILES WHERE (NAME = ? AND PATH LIKE ?) OR (FULLNAME = ?)', 'parameters' => [ $excl_items, $directory->{'path'}.'%', $directory->{'path'}.$excl_items, ], }, \@items, ); foreach my $item (@items) { delete_all_by_itemid($dbh, $item->{ID}); } } } # delete directories from database with no subdirectories or subfiles @directories = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM DIRECTORIES', 'parameters' => [ ], }, \@directories, ); foreach my $dir (@directories) { my $amount = get_amount_elements_by_id($dbh, $dir->{ID}); if ($amount == 0) { delete_subitems_recursively($dbh, $dir->{ID}); } } } sub delete_all_by_itemid { my $dbh = shift; my $object_id = shift; PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM FILES WHERE ID = ?', 'parameters' => [ $object_id, ], }, ); PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM FILEINFO WHERE FILEID_REF = ?', 'parameters' => [ $object_id, ], }, ); PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM subtitles WHERE fileid_ref = ?', 'parameters' => [ $object_id, ], }, ); } sub delete_subitems_recursively { my $dbh = shift; my $object_id = shift; my @subfiles = (); get_subfiles_by_id($dbh, $object_id, undef, undef, \@subfiles); foreach my $file (@subfiles) { delete_all_by_itemid($dbh, $file->{ID}); } my @subdirs = (); get_subdirectories_by_id($dbh, $object_id, undef, undef, \@subdirs); foreach my $directory (@subdirs) { delete_subitems_recursively($dbh, $directory->{ID}); PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM DIRECTORIES WHERE ID = ?', 'parameters' => [ $directory->{ID}, ], }, ); } PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM DIRECTORIES WHERE ID = ?', 'parameters' => [ $object_id, ], }, ); } sub get_fileinfo { my $dbh = shift; PDLNA::Log::log('Started to fetch metadata for media items.', 1, 'library'); my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT FILEID_REF FROM FILEINFO WHERE VALID = ?', 'parameters' => [ 0, ], }, \@results, ); my $counter = 0; foreach my $id (@results) { my @file = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT FULLNAME, TYPE, MIME_TYPE, EXTERNAL FROM FILES WHERE ID = ?', 'parameters' => [ $id->{FILEID_REF}, ], }, \@file, ); if ($file[0]->{EXTERNAL}) { my %info = (); PDLNA::FFmpeg::get_media_info($file[0]->{FULLNAME}, \%info); if (defined($info{MIME_TYPE})) { PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILES SET FILE_EXTENSION = ?, MIME_TYPE = ?, TYPE = ? WHERE ID = ?', 'parameters' => [ $info{FILE_EXTENSION}, $info{MIME_TYPE}, $info{TYPE}, $id->{FILEID_REF}, ], }, ); $file[0]->{TYPE} = $info{TYPE}; $file[0]->{MIME_TYPE} = $info{MIME_TYPE}; } else { PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILES SET FILE_EXTENSION = ? WHERE ID = ?', 'parameters' => [ 'unkn', $id->{FILEID_REF}, ], }, ); } } unless (defined($file[0]->{MIME_TYPE})) { next; } # # FILL METADATA OF IMAGES # if ($file[0]->{TYPE} eq 'image') { my ($width, $height) = PDLNA::Media::get_image_fileinfo($file[0]->{FULLNAME}); PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILEINFO SET WIDTH = ?, HEIGHT = ?, VALID = ? WHERE FILEID_REF = ?', 'parameters' => [ $width, $height, 1, $id->{FILEID_REF}, ], }, ); next; } if ($CONFIG{'LOW_RESOURCE_MODE'} == 1) { next; } # # FILL FFmpeg DATA OF VIDEO OR AUDIO FILES # my %info = (); if ($file[0]->{TYPE} eq 'video' || $file[0]->{TYPE} eq 'audio') { PDLNA::FFmpeg::get_media_info($file[0]->{FULLNAME}, \%info); PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILEINFO SET WIDTH = ?, HEIGHT = ?, DURATION = ?, BITRATE = ?, CONTAINER = ?, AUDIO_CODEC = ?, VIDEO_CODEC = ? WHERE FILEID_REF = ?', 'parameters' => [ $info{WIDTH}, $info{HEIGHT}, $info{DURATION}, $info{BITRATE}, $info{CONTAINER}, $info{AUDIO_CODEC}, $info{VIDEO_CODEC}, $id->{FILEID_REF}, ], }, ); if (defined($info{TYPE}) && defined($info{MIME_TYPE}) && defined($info{FILE_EXTENSION})) { PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILES SET MIME_TYPE = ?, TYPE = ?, FILE_EXTENSION = ? WHERE ID = ?', 'parameters' => [ $info{MIME_TYPE}, $info{TYPE}, $info{FILE_EXTENSION}, $id->{FILEID_REF}, ], }, ); } if ($file[0]->{TYPE} eq 'video') { PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILEINFO SET VALID = ? WHERE FILEID_REF = ?', 'parameters' => [ 1, $id->{FILEID_REF}, ], }, ); } } # # FILL METADATA OF AUDIO FILES # if ($file[0]->{TYPE} eq 'audio' && defined($info{AUDIO_CODEC})) { my %audioinfo = ( 'ARTIST' => '', 'ALBUM' => '', 'TRACKNUM' => '', 'TITLE' => '', 'GENRE' => '', 'YEAR' => '', ); PDLNA::Media::get_audio_fileinfo($file[0]->{FULLNAME}, $info{AUDIO_CODEC}, \%audioinfo); PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE FILEINFO SET ARTIST = ?, ALBUM = ?, TITLE = ?, GENRE = ?, YEAR = ?, TRACKNUM = ?, VALID = ? WHERE FILEID_REF = ?', 'parameters' => [ $audioinfo{ARTIST}, $audioinfo{ALBUM}, $audioinfo{TITLE}, $audioinfo{GENRE}, $audioinfo{YEAR}, $audioinfo{TRACKNUM}, 1, $id->{FILEID_REF}, ], }, ); } $counter++; unless ($counter % 50) # after 50 files, we are doing a commit { $dbh->commit(); } } } sub get_subdirectories_by_id { my $dbh = shift; my $object_id = shift; my $starting_index = shift; my $requested_count = shift; my $directory_elements = shift; my $sql_query = 'SELECT ID, NAME, PATH FROM DIRECTORIES WHERE '; my @sql_param = (); if ($object_id == 0) { $sql_query .= 'ROOT = 1'; } else { $sql_query .= 'DIRNAME IN ( SELECT PATH FROM DIRECTORIES WHERE ID = ? )'; push(@sql_param, $object_id); } $sql_query .= ' ORDER BY NAME'; if (defined($starting_index) && defined($requested_count)) { $sql_query .= ' LIMIT '.$starting_index.', '.$requested_count; } PDLNA::Database::select_db( $dbh, { 'query' => $sql_query, 'parameters' => \@sql_param, }, $directory_elements, ); } sub get_directory_type_by_id { my $dbh = shift; my $object_id = shift; my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT TYPE FROM DIRECTORIES WHERE ID = ?', 'parameters' => [ $object_id, ], }, ); return $results[0]->{TYPE}; } sub get_subfiles_by_id { my $dbh = shift; my $object_id = shift; my $starting_index = shift; my $requested_count = shift; my $file_elements = shift; my $sql_query = 'SELECT ID, NAME, SIZE, DATE FROM FILES WHERE '; my @sql_param = (); if ($object_id == 0) { $sql_query .= 'ROOT = 1'; } else { $sql_query .= 'PATH IN ( SELECT PATH FROM DIRECTORIES WHERE ID = ? )'; push(@sql_param, $object_id); } $sql_query .= ' ORDER BY SEQUENCE, NAME'; if (defined($starting_index) && defined($requested_count)) { $sql_query .= ' LIMIT '.$starting_index.', '.$requested_count; } PDLNA::Database::select_db( $dbh, { 'query' => $sql_query, 'parameters' => \@sql_param, }, $file_elements, ); } sub get_subfiles_size_by_id { my $dbh = shift; my $object_id = shift; my @result = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT SUM(SIZE) AS FULLSIZE FROM FILES WHERE PATH IN ( SELECT PATH FROM DIRECTORIES WHERE ID = ? )', 'parameters' => [ $object_id, ], }, \@result, ); return $result[0]->{FULLSIZE}; } sub get_amount_subdirectories_by_id { my $dbh = shift; my $object_id = shift; my @directory_amount = (); my $sql_query = 'SELECT COUNT(ID) AS AMOUNT FROM DIRECTORIES WHERE '; my @sql_param = (); if ($object_id == 0) { $sql_query .= 'ROOT = 1'; } else { $sql_query .= 'DIRNAME IN ( SELECT PATH FROM DIRECTORIES WHERE ID = ? )'; push(@sql_param, $object_id); } PDLNA::Database::select_db( $dbh, { 'query' => $sql_query, 'parameters' => \@sql_param, }, \@directory_amount, ); return $directory_amount[0]->{AMOUNT}; } sub get_amount_subfiles_by_id { my $dbh = shift; my $object_id = shift; my @files_amount = (); my $sql_query = 'SELECT COUNT(ID) AS AMOUNT FROM FILES WHERE PATH IN ( SELECT PATH FROM DIRECTORIES WHERE ID = ?)'; my @sql_param = ( $object_id, ); PDLNA::Database::select_db( $dbh, { 'query' => $sql_query, 'parameters' => \@sql_param, }, \@files_amount, ); return $files_amount[0]->{AMOUNT}; } sub get_amount_elements_by_id { my $dbh = shift; my $object_id = shift; my $directory_amount = 0; $directory_amount += get_amount_subdirectories_by_id($dbh, $object_id); $directory_amount += get_amount_subfiles_by_id($dbh, $object_id); return $directory_amount; } sub get_parent_of_directory_by_id { my $dbh = shift; my $object_id = shift; my @directory_parent = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM DIRECTORIES WHERE PATH IN ( SELECT DIRNAME FROM DIRECTORIES WHERE ID = ? )', 'parameters' => [ $object_id, ], }, \@directory_parent, ); $directory_parent[0]->{ID} = 0 if !defined($directory_parent[0]->{ID}); return $directory_parent[0]->{ID}; } sub get_parent_of_item_by_id { my $dbh = shift; my $object_id = shift; my @item_parent = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT ID FROM DIRECTORIES WHERE PATH IN ( SELECT PATH FROM FILES WHERE ID = ? )', 'parameters' => [ $object_id, ], }, \@item_parent, ); $item_parent[0]->{ID} = 0 if !defined($item_parent[0]->{ID}); return $item_parent[0]->{ID}; } # # HELPER FUNCTIONS # # # NEW: returns array with subtitle items based on their ref_id # sub get_subtitles_by_refid { my $dbh = shift; my $ref_id = shift; my @subtitles = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, media_type, fullname, file_extension FROM items WHERE item_type = ? AND ref_id = ?', 'parameters' => [ 2, $ref_id, ], }, \@subtitles, ); return @subtitles; } # # NEW: fills array reference with items based on their parent_id and their item_type # sub get_items_by_parentid { my $dbh = shift; my $item_id = shift; my $starting_index = shift; my $requested_count = shift; my $item_type = shift; my $elements = shift; my $sql_query = 'SELECT id, fullname, title, size, date FROM items WHERE parent_id = ? AND item_type = ? ORDER BY title'; if (defined($starting_index) && defined($requested_count)) { $sql_query .= ' LIMIT '.$starting_index.', '.$requested_count; } PDLNA::Database::select_db( $dbh, { 'query' => $sql_query, 'parameters' => [ $item_id, $item_type, ] }, $elements, ); } # # NEW: returns specified DB columns of an item based on its id # sub get_item_by_id { my $dbh = shift; my $item_id = shift; my $dbfields = shift; my @items = (); # SANITY CHECK - otherwise we are VULNERABLE to SQL Injections (if somebody is able to manipulate dbfields values) foreach my $dbfield (@{$dbfields}) { unless ($dbfield =~ /^(parent_id|item_type|media_type|mime_type|fullname|title|file_extension|date|size|width|height|duration)$/) { PDLNA::Log::log('ERROR: Parameter '.$dbfield.' as DB column is NOT valid. Possible SQL Injection attempt.', 0, 'default'); return @items; } } PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT '.join(', ', @{$dbfields}).' FROM items WHERE id = ?', 'parameters' => [ $item_id ], }, \@items, ); return @items; } # # NEW: returns amount and total_size of items based on their (parent_id|item_type|media_type) # sub get_amount_size_items_by { my $dbh = shift; my $dbfield = shift; my $dbvalue = shift; # SANITY CHECK - otherwise we are VULNERABLE to SQL Injections (if somebody is able to manipulate dbfields values) unless ($dbfield =~ /^(parent_id|item_type|media_type)$/) { PDLNA::Log::log('ERROR: Parameter '.$dbfield.' as DB column is NOT valid. Possible SQL Injection attempt.', 0, 'default'); return (0,0); } my @result = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT COUNT(id) AS amount, SUM(size) as size FROM items WHERE '.$dbfield.' = ?', 'parameters' => [ $dbvalue, ], }, \@result, ); my ($amount, $size) = 0; $amount = $result[0]->{amount} if $result[0]->{amount}; $size = $result[0]->{size} if $result[0]->{size}; return ($amount, $size); } # # NEW: returns amount of items based on their parent_id and item_type # sub get_amount_items_by_parentid_n_itemtype { my $dbh = shift; my $parent_id = shift; my $item_type = shift; my @result = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT COUNT(id) AS amount FROM items WHERE parent_id = ? AND item_type = ?', 'parameters' => [ $parent_id, $item_type, ], }, \@result, ); return $result[0]->{amount} || 0; } # # NEW: returns total duration of items # sub get_duration_items { my $dbh = shift; my $duration = PDLNA::Database::select_db_field_int( $dbh, { 'query' => 'SELECT SUM(duration) FROM items', 'parameters' => [ ], }, ); return $duration; } # # NEW: returns the parent_id of an item by id # sub get_parentid_by_id { my $dbh = shift; my $item_id = shift; my $parent_id = PDLNA::Database::select_db_field_int( $dbh, { 'query' => 'SELECT parent_id FROM items WHERE id = ?', 'parameters' => [ $item_id, ], }, ); return $parent_id; } # # NEW: return true if an item_id is under a parent_id # sub is_itemid_under_parentid { my $dbh = shift; my $parent_id = shift; my $item_id = shift; while ($item_id != 0) { return 1 if $parent_id eq $item_id; $item_id = get_parentid_by_id($dbh, $item_id); } return 0; } # # HELPER FUNCTIONS END # # # INTERNAL HELPER FUNCTIONS # sub _process_directory { my $dbh = shift; my $params = shift; $$params{'fullname'} = PDLNA::Utils::delete_trailing_slash($$params{'fullname'}); my $directory_id = _add_directory_item($dbh, $params); $dbh->commit(); $$params{'fullname'} = PDLNA::Utils::escape_brackets($$params{'fullname'}); PDLNA::Log::log('Globbing directory: '.PDLNA::Utils::create_filesystem_path([ $$params{'fullname'}, '*', ]).'.', 2, 'library'); my @items = bsd_glob(PDLNA::Utils::create_filesystem_path([ $$params{'fullname'}, '*', ])); foreach my $item (sort @items) { my $item_basename = basename($item); if (-d $item && $item =~ /lost\+found$/) { PDLNA::Log::log('Skipping '.$item.' directory.', 2, 'library'); } elsif (-d $item && $$params{'recursion'} eq 'yes' && !grep(/^\Q$item_basename\E$/, @{$$params{'exclude_dirs'}})) { PDLNA::Log::log('Processing directory '.$item.'.', 2, 'library'); $$params{'parent_id'} = $directory_id; $$params{'fullname'} = $item; _process_directory($dbh, $params); } elsif (-f $item && !grep(/^\Q$item_basename\E$/, @{$$params{'exclude_items'}})) { my $mime_type = mimetype($item); PDLNA::Log::log('Processing '.$item.' with MimeType '.$mime_type.'.', 2, 'library'); if (PDLNA::Media::is_supported_mimetype($mime_type)) { my $media_type = PDLNA::Media::return_type_by_mimetype($mime_type); if ($media_type && ($media_type eq $$params{'media_type'} || $$params{'media_type'} eq 'all')) { PDLNA::Log::log('Adding '.$media_type.' item '.$item.'.', 2, 'library'); my $item_id = _add_media_item( $dbh, { 'fullname' => $item, 'parent_id' => $directory_id, 'item_type' => 1, 'mime_type' => $mime_type, 'media_type' => $media_type, }, ); # subtitles for video files if ($media_type eq 'video') { my $tmp = $1 if $item =~ /^(.+)\.\w{3,4}$/; foreach my $extension ('srt') { if (-f $tmp.'.'.$extension) { my $subtitle_mimetype = mimetype($tmp.'.'.$extension); if (PDLNA::Media::is_supported_subtitle($subtitle_mimetype)) { my $subtitle_id = _add_media_item( $dbh, { 'fullname' => $tmp.'.'.$extension, 'parent_id' => $directory_id, 'ref_id' => $item_id, 'item_type' => 2, 'mime_type' => $subtitle_mimetype, 'media_type' => $extension, }, ); } } } } } } elsif (PDLNA::Media::is_supported_playlist($mime_type)) { PDLNA::Log::log('Adding playlist '.$item.' as directory.', 2, 'library'); # TODO playlists } else { PDLNA::Log::log('Item '.$item.' skipped. Unsupported MimeType '.$mime_type.'.', 2, 'library'); } } else { PDLNA::Log::log('Item '.$item.' skipped. Inlcuded in ExcludeList.', 2, 'library'); } } } sub _add_media_item { my $dbh = shift; my $params = shift; # gather size and date for item my @fileinfo = stat($$params{'fullname'}); my $file_extension = $1 if $$params{'fullname'} =~ /(\w{3,4})$/; # select from database my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, size, date FROM items WHERE fullname = ?', 'parameters' => [ $$params{'fullname'}, ], }, \@results, ); if (defined($results[0]->{id})) # check if item is already in db { if ($results[0]->{size} != $fileinfo[7] || $results[0]->{date} != $fileinfo[9]) # item has changed { # TODO - CHECK IF I'M WORKING PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE items SET media_attributes = ?, size = ?, date = ? WHERE id = ?', 'parameters' => [ 0, $fileinfo[7], $fileinfo[9], $results[0]->{id}, ], }, ); PDLNA::Log::log('Updated media item '.$$params{'fullname'}.' in ContentLibrary.', 2, 'library'); } else # item has not changed { PDLNA::Log::log('No need to update media item '.$$params{'fullname'}.' in ContentLibrary.', 3, 'library'); } } else # item not in database { # add item to database PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO items (parent_id, ref_id, item_type, media_type, mime_type, fullname, title, size, date, file_extension) VALUES (?,?,?,?,?,?,?,?,?,?)', 'parameters' => [ $$params{'parent_id'}, $$params{'ref_id'}, $$params{'item_type'}, $$params{'media_type'}, $$params{'mime_type'}, $$params{'fullname'}, basename($$params{'fullname'}), $fileinfo[7], $fileinfo[9], $file_extension, ], }, ); PDLNA::Log::log('Added media item '.$$params{'fullname'}.' to ContentLibrary.', 2, 'library'); } return _get_itemid_by_fullname($dbh, $$params{'fullname'}); } sub _add_directory_item { my $dbh = shift; my $params = shift; unless (_get_itemid_by_fullname($dbh, $$params{'fullname'})) # check if item is already in db { # add directory to database PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO items (parent_id, fullname, title) VALUES (?,?,?)', 'parameters' => [ $$params{'parent_id'}, $$params{'fullname'}, basename($$params{'fullname'}), ], }, ); PDLNA::Log::log('Added directory item '.$$params{'fullname'}.' to ContentLibrary.', 2, 'library'); } return _get_itemid_by_fullname($dbh, $$params{'fullname'}); } sub _delete_item_by_id { my $dbh = shift; my $item_id = shift; PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM items WHERE id = ?', 'parameters' => [ $item_id, ], }, ); } sub _get_itemid_by_fullname { my $dbh = shift; my $fullname = shift; my @results = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id FROM items WHERE fullname = ?', 'parameters' => [ $fullname, ], }, \@results, ); return $results[0]->{id} if defined($results[0]->{id}); return undef; } sub _cleanup_contentlibrary { my $dbh = shift; PDLNA::Log::log('Started to clean up ContentLibrary.', 1, 'library'); # # delete items, which aren't present any more (if any) # my @items = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, fullname, item_type FROM items', 'parameters' => [ ], }, \@items, ); foreach my $item (@items) { if ($item->{item_type} == 0) # directory { unless (-d $item->{fullname}) { _delete_item_by_id($dbh, $item->{id}); } } elsif ($item->{item_type} == 1) # file (audio, video, image) { unless (-f $item->{fullname}) { _delete_item_by_id($dbh, $item->{id}); } } elsif ($item->{item_type} == 2) # subtitles { unless (-f $item->{fullname}) { _delete_item_by_id($dbh, $item->{id}); } } } # # delete directory items, which aren't configured any more (if any) # @items = (); get_items_by_parentid($dbh, 0, undef, undef, 0, \@items); my @conf_directories = (); foreach my $directory (@{$CONFIG{'DIRECTORIES'}}) { push(@conf_directories, $directory->{'path'}); } foreach my $item (@items) { unless (grep(/^$item->{fullname}$/, @conf_directories)) { # TODO subitems _delete_item_by_id($dbh, $item->{id}); } } # # delete external items, if LOW_RESOURCE_MODE is enabled (if any) # if ($CONFIG{'LOW_RESOURCE_MODE'} == 1) { } # # delete external items, which aren't configured any more (if any) # # # delete items, which are excluded (if any) # foreach my $directory (@{$CONFIG{'DIRECTORIES'}}) { my $directory_id = _get_itemid_by_fullname($dbh, $directory->{'path'}); if (defined($directory_id)) { foreach my $excl_directory (@{$$directory{'exclude_dirs'}}) { @items = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, title FROM items WHERE title = ? AND item_type = ?', 'parameters' => [ $excl_directory, 0, ], }, \@items, ); foreach my $item (@items) { if (is_itemid_under_parentid($dbh, $directory_id, $item->{id})) { # TODO subitems _delete_item_by_id($dbh, $item->{id}); } } } # TODO media items foreach my $excl_item (@{$$directory{'exclude_items'}}) { } } } # # delete directory items, which don't have any subitems (if any) # @items = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, fullname FROM items WHERE item_type = ?', 'parameters' => [ 0, ], }, \@items, ); foreach my $item (@items) { my ($amount, undef) = get_amount_size_items_by($dbh, 'parent_id', $item->{id}); if ($amount == 0) { _delete_item_by_id($dbh, $item->{id}); } } } sub _fetch_media_attributes { my $dbh = shift; PDLNA::Log::log('Started to fetch attributes for media items.', 1, 'library'); my @items = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, media_type, fullname FROM items WHERE media_attributes = ? AND item_type = ?', 'parameters' => [ 0, 1, ], }, \@items, ); my $counter = 0; foreach my $item (@items) { # # FILL METADATA OF IMAGES # if ($item->{media_type} eq 'image') { my ($width, $height) = PDLNA::Media::get_image_fileinfo($item->{fullname}); PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE items SET width = ?, height = ?, media_attributes = ? WHERE id = ?', 'parameters' => [ $width, $height, 1, $item->{id}, ], }, ); next; } # # IN LOW_RESOURCE_MODE WE ARE NOT GOING TO OPEN EVERY SINGLE FILE # if ($CONFIG{'LOW_RESOURCE_MODE'} == 1) { next; } # # FILL FFmpeg DATA OF VIDEO OR AUDIO FILES # if ($item->{media_type} eq 'video' || $item->{media_type} eq 'audio') { my %info = (); PDLNA::FFmpeg::get_media_info($item->{fullname}, \%info); PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE items SET width = ?, height = ?, duration = ?, media_attributes = ? WHERE id = ?', 'parameters' => [ $info{WIDTH}, $info{HEIGHT}, $info{DURATION}, 1, $item->{id}, ], }, ); } $counter++; unless ($counter % 50) # after 50 files, we are doing a commit { $dbh->commit(); } } } # # INTERNAL HELPER FUNCTIONS END # 1; # if ($CONFIG{'SPECIFIC_VIEWS'}) # { # $self->{DIRECTORIES}->{'A_A'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Audio sorted by Artist', # 'id' => 'A_A', # 'parent_id' => '', # }); # $self->{DIRECTORIES}->{'A_F'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Audio sorted by Folder', # 'id' => 'A_F', # 'parent_id' => '', # }); # $self->{DIRECTORIES}->{'A_G'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Audio sorted by Genre', # 'id' => 'A_G', # 'parent_id' => '', # }); # $self->{DIRECTORIES}->{'A_M'} = PDLNA::ContentDirectory->new({ # moods: WTF (dynamic) # 'type' => 'meta', # 'name' => 'Audio sorted by Mood', # 'id' => 'A_M', # 'parent_id' => '', # }); # $self->{DIRECTORIES}->{'A_T'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Audio sorted by Title (Alphabet)', # 'id' => 'A_M', # 'parent_id' => '', # }); # # $self->{DIRECTORIES}->{'I_F'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Images sorted by Folder', # 'id' => 'I_F', # 'parent_id' => '', # }); # $self->{DIRECTORIES}->{'I_T'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Images sorted by Date', # 'id' => 'I_T', # 'parent_id' => '', # }); # # $self->{DIRECTORIES}->{'V_D'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Videos sorted by Date', # 'id' => 'V_D', # 'parent_id' => '', # }); # $self->{DIRECTORIES}->{'V_F'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Videos sorted by Folder', # 'id' => 'V_F', # 'parent_id' => '', # }); # $self->{DIRECTORIES}->{'V_T'} = PDLNA::ContentDirectory->new({ # 'type' => 'meta', # 'name' => 'Videos sorted by Title (Alphabet)', # 'id' => 'V_T', # 'parent_id' => '', # }); # } pDLNA/usr/lib/perl5/PDLNA/Utils.pm0000700000175000017500000001064313366114774015645 0ustar geumageumapackage PDLNA::Utils; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Digest::SHA; use LWP::UserAgent; use Time::HiRes qw(gettimeofday); use XML::Simple; use PDLNA::Config; use PDLNA::Log; sub http_date { my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(); my @months = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec',); my @days = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat',); $year += 1900; $hour = add_leading_char($hour, 2, '0'); $min = add_leading_char($min, 2, '0'); $sec = add_leading_char($sec, 2, '0'); return "$days[$wday], $mday $months[$mon] $year $hour:$min:$sec GMT"; } sub add_leading_char { my $string = shift || ''; my $length = shift; my $char = shift; while (length($string) < $length) { $string = $char . $string; } return $string; } sub remove_leading_char { my $string = shift || ''; my $char = shift; while ($string =~ /^$char/) { substr($string, 0, 1) = ''; } return $string; } sub convert_bytes { my $bytes = shift || 0; my @size = ('B', 'kB', 'MB', 'GB', 'TB'); my $ctr = 0; for ($ctr = 0; $bytes > 1024; $ctr++) { $bytes /= 1024; } return sprintf("%.2f", $bytes).' '.$size[$ctr]; } # TODO make it more beautiful sub convert_duration { my $duration_seconds = shift || 0; my $detailed = shift || 0; my ($seconds, $minutes, $hours) = (0, 0, 0); $seconds = $duration_seconds; $minutes = int($seconds / 60) if $seconds > 59; $seconds -= $minutes * 60 if $seconds; $hours = int($minutes / 60) if $minutes > 59; $minutes -= $hours * 60 if $hours; my $string = ''; if ($detailed) { my ($days, $weeks) = (0, 0); $days = int($hours / 24) if $hours > 23; $hours -= $days * 24 if $days; $weeks = int($days / 7) if $days > 6; $days -= $weeks * 7 if $weeks; $string .= $weeks.'w ' if $weeks; $string .= $days.'d ' if $days; } $string .= add_leading_char($hours,2,'0').':'; $string .= add_leading_char($minutes,2,'0').':'; $string .= add_leading_char($seconds,2,'0'); return $string; } # well, it is not real random ... but it's adequate sub get_randid { my $sha = Digest::SHA->new(); $sha->add(get_timestamp_ms()); return $sha->hexdigest(); } sub string_shortener { my $string = shift; my $length = shift; if (length($string) > $length) { return substr($string, 0, $length-3).'...'; } return $string; } sub fetch_http { my $url = shift; my $ua = LWP::UserAgent->new(); $ua->agent($CONFIG{'PROGRAM_NAME'}."/".PDLNA::Config::print_version()); my $request = HTTP::Request->new(GET => $url); my $response = $ua->request($request); if ($response->is_success()) { PDLNA::Log::log('Fetching URL '.$url.' was successful.', 3, 'httpgeneric'); return $response->content(); } else { PDLNA::Log::log('Fetching URL '.$url.' was NOT successful ('.$response->status_line().').', 3, 'httpgeneric'); } return undef; } sub get_timestamp_ms { my $timestamp = int (gettimeofday() * 1000); return $timestamp; } # TODO windows part sub is_path_absolute { my $path = shift; return 1 if $path =~ /^\//; return 0; } # TODO windows part sub create_filesystem_path { my $items = shift; return join('/', @{$items}); } # TODO windows part (if needed) sub escape_brackets { my $string = shift; $string =~ s/\[/\\[/g; $string =~ s/\]/\\]/g; return $string; } # TODO windows part (if needed) sub delete_trailing_slash { my $string = shift; $string =~ s/\/$//; return $string; } sub encode_xml { my $string = shift; my $xs = XML::Simple->new(); $string = $xs->escape_value($string); $string =~ s/&/&/g; # double encoding of ampersand: http://sourceforge.net/p/minidlna/bugs/198/ #$string =~ s/'/'/g; # single qoutes are not encoded by XML::Simple, do we need it ? return $string; } 1; pDLNA/usr/lib/perl5/PDLNA/Devices.pm0000700000175000017500000002751213366114774016132 0ustar geumageumapackage PDLNA::Devices; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use File::Basename; use URI::Split qw(uri_split uri_join); use XML::Simple; use PDLNA::Config; use PDLNA::Database; sub add_device { my $dbh = shift; my $params = shift; # # BEGIN OF IP # my $device_ip_id = get_device_ip_id_by_device_ip($dbh, $$params{'ip'}); if (defined($device_ip_id)) { PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE device_ip SET last_seen = ? WHERE id = ?', 'parameters' => [ time(), $device_ip_id, ], }, ); } else { PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO device_ip (ip, last_seen) VALUES (?,?)', 'parameters' => [ $$params{'ip'}, time(), ], }, ); $device_ip_id = get_device_ip_id_by_device_ip($dbh, $$params{'ip'}); } # # END OF IP # # set the user agent string if defined if (defined($$params{'http_useragent'})) { PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE device_ip SET user_agent = ? WHERE id = ?', 'parameters' => [ $$params{'http_useragent'}, $device_ip_id, ], }, ); } # # BEGIN OF UDN # return 0 unless defined($$params{'udn'}); return 0 unless defined($$params{'ssdp_banner'}); return 0 unless defined($$params{'device_description_location'}); my $device_udn_id = _get_device_udn_id_by_device_ip_id($dbh, $device_ip_id, $$params{'udn'}); if (defined($device_udn_id)) { # we got nothing to do here } else { my %services = (); my ($device_udn_base_url, $device_udn_rela_url) = ''; my ($device_udn_devicetype, $device_udn_modelname, $device_udn_friendlyname) = ''; if (defined($$params{'device_description_location'})) { my ($scheme, $auth, $path, $query, $frag) = uri_split($$params{'device_description_location'}); $device_udn_base_url = uri_join($scheme, $auth); $device_udn_rela_url = uri_join($scheme, $auth, dirname($path)); $device_udn_rela_url = substr($device_udn_rela_url, 0, -1) if $device_udn_rela_url =~ /\/$/; # remove / at the end (if any) my $response = PDLNA::Utils::fetch_http($$params{'device_description_location'}); if ($response) { my $xs = XML::Simple->new(); my $xml = eval { $xs->XMLin($response) }; if ($@) { PDLNA::Log::log('ERROR: Unable to parse XML Device Description in PDLNA::Devices: '.$@, 0, 'discovery'); } else { $device_udn_devicetype = $xml->{'device'}->{'deviceType'} if defined($xml->{'device'}->{'deviceType'}); $device_udn_modelname = $xml->{'device'}->{'modelName'} if defined($xml->{'device'}->{'modelName'}); $device_udn_friendlyname = $xml->{'device'}->{'friendlyName'} if defined($xml->{'device'}->{'friendlyName'}); # add device_service if (ref($xml->{'device'}->{'serviceList'}->{'service'}) eq 'ARRAY') # we need to check if it is an array { foreach my $service (@{$xml->{'device'}->{'serviceList'}->{'service'}}) { my %service_configuration = ( 'serviceId' => $service->{'serviceId'}, 'serviceType' => $service->{'serviceType'}, ); foreach my $url ('controlURL', 'eventSubURL', 'SCPDURL') { if ($service->{$url} =~ /^\//) { $service_configuration{$url} = $device_udn_base_url.$service->{$url}; } else { $service_configuration{$url} = $device_udn_rela_url.'/'.$service->{$url}; } } $services{$service->{'serviceId'}} = \%service_configuration; } } else { my $service = $xml->{'device'}->{'serviceList'}->{'service'}; my %service_configuration = ( 'serviceId' => $service->{'serviceId'}, 'serviceType' => $service->{'serviceType'}, ); foreach my $url ('controlURL', 'eventSubURL', 'SCPDURL') { if ($service->{$url} =~ /^\//) { $service_configuration{$url} = $device_udn_base_url.$service->{$url}; } else { $service_configuration{$url} = $device_udn_rela_url.'/'.$service->{$url}; } } $services{$service->{'serviceId'}} = \%service_configuration; } } } } if (defined($device_udn_modelname) && defined($device_udn_friendlyname)) { PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO device_udn (device_ip_ref, udn, ssdp_banner, desc_url, rela_url, base_url, type, model_name, friendly_name) VALUES (?,?,?,?,?,?,?,?,?)', 'parameters' => [ $device_ip_id, $$params{'udn'}, $$params{'ssdp_banner'}, $$params{'device_description_location'}, $device_udn_base_url, $device_udn_rela_url, $device_udn_devicetype, $device_udn_modelname, $device_udn_friendlyname, ], }, ); $device_udn_id = _get_device_udn_id_by_device_ip_id($dbh, $device_ip_id, $$params{'udn'}); # create the device_service entries foreach my $service (keys %services) { if (defined($services{$service}->{'serviceId'}) && defined($services{$service}->{'controlURL'}) && defined($services{$service}->{'eventSubURL'}) && defined($services{$service}->{'SCPDURL'})) { PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO device_service (device_udn_ref, service_id, type, control_url, event_url, scpd_url) VALUES (?,?,?,?,?,?)', 'parameters' => [ $device_udn_id, $services{$service}->{'serviceId'}, $services{$service}->{'serviceType'}, $services{$service}->{'controlURL'}, $services{$service}->{'eventSubURL'}, $services{$service}->{'SCPDURL'}, ], }, ); } } } } # # END OF UDN # # # BEGIN OF NTS # return 0 unless defined($$params{'nt'}); return 0 unless defined($$params{'nt_time_of_expire'}); my $device_nts_id = _get_device_nts_id_by_device_udn_id($dbh, $device_udn_id, $$params{'nt'}); if (defined($device_nts_id)) { PDLNA::Database::update_db( $dbh, { 'query' => 'UPDATE device_nts SET expire = ? WHERE id = ? AND type = ?', 'parameters' => [ $$params{'nt_time_of_expire'}, $device_nts_id, $$params{'nt'}, ], }, ); } else { PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO device_nts (device_udn_ref, type, expire) VALUES (?,?,?)', 'parameters' => [ $device_udn_id, $$params{'nt'}, $$params{'nt_time_of_expire'}, ], }, ); $device_nts_id = _get_device_nts_id_by_device_udn_id($dbh, $device_udn_id, $$params{'nt'}); } # # END OF NTS # } sub delete_expired_devices { my $dbh = PDLNA::Database::connect(); my $time = time(); # delete expired device_nts entries my @device_nts = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, expire FROM device_nts', 'parameters' => [ ], }, \@device_nts, ); foreach my $nts (@device_nts) { if ($nts->{expire} < $time) { _delete_device_nts_by_id($dbh, $nts->{id}); } } # delete device_udn entries with no NTS entries my @device_udn = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id FROM device_udn', 'parameters' => [ ], }, \@device_udn, ); foreach my $udn (@device_udn) { if (_get_device_nts_amount_by_device_udn_id($dbh, $udn->{id}) == 0) { _delete_device_udn_by_id($dbh, $udn->{id}); } } PDLNA::Database::disconnect($dbh); } sub delete_device { my $dbh = shift; my $params = shift; return 0 if !defined($$params{'ip'}); return 0 if !defined($$params{'udn'}); return 0 if !defined($$params{'nt'}); my $device_ip_id = get_device_ip_id_by_device_ip($dbh, $$params{'ip'}); my $device_udn_id = _get_device_udn_id_by_device_ip_id($dbh, $device_ip_id, $$params{'udn'}) if defined($device_ip_id); my $device_nts_id = _get_device_nts_id_by_device_udn_id($dbh, $device_udn_id, $$params{'nt'}) if defined($device_udn_id); _delete_device_nts_by_id($dbh, $device_nts_id) if defined($device_nts_id); if (defined($device_udn_id)) { my $device_nts_amount = _get_device_nts_amount_by_device_udn_id($dbh, $device_udn_id); _delete_device_udn_by_id($dbh, $device_udn_id) if $device_nts_amount == 0; } } sub get_modelname_by_devicetype { my $dbh = shift; my $ip = shift; my $devicetype = shift; my @modelnames = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, model_name FROM device_udn WHERE device_ip_ref IN (SELECT id FROM device_ip WHERE ip = ?)', 'parameters' => [ $ip, ], }, \@modelnames, ); foreach my $modelname (@modelnames) { my @device_udns = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT device_udn_ref FROM device_nts WHERE type = ?', 'parameters' => [ $devicetype, ], }, \@device_udns, ); foreach my $device_udn (@device_udns) { if (defined($device_udn->{device_udn_ref}) && $device_udn->{device_udn_ref} == $modelname->{id}) { return $modelname->{model_name}; } } } return ''; } sub get_device_ip_id_by_device_ip { my $dbh = shift; my $ip = shift; my @devices = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id FROM device_ip WHERE ip = ?', 'parameters' => [ $ip, ], }, \@devices, ); return $devices[0]->{id}; } # # HELPER FUNCTIONS # sub _delete_device_nts_by_id { my $dbh = shift; my $device_nts_id = shift; PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM device_nts WHERE id = ?', 'parameters' => [ $device_nts_id, ], }, ); } sub _get_device_nts_id_by_device_udn_id { my $dbh = shift; my $device_udn_id = shift; my $device_nts_type = shift; my @device_nts = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id FROM device_nts WHERE device_udn_ref = ? AND type = ?', 'parameters' => [ $device_udn_id, $device_nts_type, ], }, \@device_nts, ); return $device_nts[0]->{id}; } sub _get_device_nts_amount_by_device_udn_id { my $dbh = shift; my $device_udn_id = shift; my @device_nts_amount = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT COUNT(id) AS amount FROM device_nts WHERE device_udn_ref = ?', 'parameters' => [ $device_udn_id, ], }, \@device_nts_amount, ); return $device_nts_amount[0]->{amount}; } sub _delete_device_udn_by_id { my $dbh = shift; my $device_udn_id = shift; PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM device_udn WHERE id = ?', 'parameters' => [ $device_udn_id, ], }, ); # delete the device_service entries PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM device_service WHERE device_udn_ref = ?', 'parameters' => [ $device_udn_id, ], }, ); } sub _get_device_udn_id_by_device_ip_id { my $dbh = shift; my $device_ip_id = shift; my $device_udn = shift; my @device_udn = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id FROM device_udn WHERE device_ip_ref = ? AND udn = ?', 'parameters' => [ $device_ip_id, $device_udn, ], }, \@device_udn, ); return $device_udn[0]->{id}; } sub _get_device_udn_amount_by_device_ip_id { my $dbh = shift; my $device_ip_id = shift; my @device_udn_amount = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT COUNT(id) AS amount FROM device_udn WHERE device_ip_ref = ?', 'parameters' => [ $device_ip_id, ], }, \@device_udn_amount, ); return $device_udn_amount[0]->{amount}; } sub _delete_device_ip_by_id { my $dbh = shift; my $device_ip_id = shift; PDLNA::Database::delete_db( $dbh, { 'query' => 'DELETE FROM device_ip WHERE id = ?', 'parameters' => [ $device_ip_id, ], }, ); } 1; pDLNA/usr/lib/perl5/PDLNA/SpecificViews.pm0000700000175000017500000000761613366114774017316 0ustar geumageumapackage PDLNA::SpecificViews; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use PDLNA::Database; use PDLNA::Utils; our %SPECIFICVIEWS = ( 'A' => { 'MediaType' => 'audio', 'GroupType' => { 'F' => 'folder', }, }, 'I' => { 'MediaType' => 'image', 'GroupType' => { 'F' => 'folder', }, }, 'V' => { 'MediaType' => 'video', 'GroupType' => { 'D' => 'folder', }, }, ); our %SPECIFICVIEW_QUERIES = ( 'folder' => { 'group_amount' => 'SELECT COUNT(ID) AS AMOUNT FROM DIRECTORIES WHERE PATH IN ( SELECT PATH FROM FILES WHERE TYPE = ? )', 'group_elements' => 'SELECT ID, NAME, PATH FROM DIRECTORIES WHERE PATH IN ( SELECT PATH FROM FILES WHERE TYPE = ? ) ORDER BY NAME', 'item_amount' => 'SELECT COUNT(ID) AS AMOUNT FROM FILES WHERE PATH IN ( SELECT PATH FROM DIRECTORIES WHERE ID = ? ) AND TYPE = ?', 'item_elements' => 'SELECT ID FROM FILES WHERE PATH IN ( SELECT PATH FROM DIRECTORIES WHERE ID = ? ) AND TYPE = ?', }, ); sub supported_request { my $media_type = shift; my $group_type = shift; if (defined($SPECIFICVIEWS{$media_type}) && defined($SPECIFICVIEWS{$media_type}->{'GroupType'}->{$group_type})) { return 1; } return 0; } sub get_groups { my $dbh = shift; my $media_type = shift; my $group_type = shift; my $starting_index = shift; my $requested_count = shift; my $group_elements = shift; my $sql_query = $SPECIFICVIEW_QUERIES{$SPECIFICVIEWS{$media_type}->{'GroupType'}->{$group_type}}->{'group_elements'}; if (defined($starting_index) && defined($requested_count)) { $sql_query .= ' LIMIT '.$starting_index.', '.$requested_count; } PDLNA::Database::select_db( $dbh, { 'query' => $sql_query, 'parameters' => [ $SPECIFICVIEWS{$media_type}->{'MediaType'}, ], }, $group_elements, ); } sub get_amount_of_groups { my $dbh = shift; my $media_type = shift; my $group_type = shift; my @group_amount = (); PDLNA::Database::select_db( $dbh, { 'query' => $SPECIFICVIEW_QUERIES{$SPECIFICVIEWS{$media_type}->{'GroupType'}->{$group_type}}->{'group_amount'}, 'parameters' => [ $SPECIFICVIEWS{$media_type}->{'MediaType'}, ], }, \@group_amount, ); return $group_amount[0]->{AMOUNT}; } sub get_items { my $dbh = shift; my $media_type = shift; my $group_type = shift; my $group_id = shift; my $starting_index = shift; my $requested_count = shift; my $item_elements = shift; my $sql_query = $SPECIFICVIEW_QUERIES{$SPECIFICVIEWS{$media_type}->{'GroupType'}->{$group_type}}->{'item_elements'}; if (defined($starting_index) && defined($requested_count)) { $sql_query .= ' LIMIT '.$starting_index.', '.$requested_count; } PDLNA::Database::select_db( $dbh, { 'query' => $sql_query, 'parameters' => [ $group_id, $SPECIFICVIEWS{$media_type}->{'MediaType'}, ], }, $item_elements, ); } sub get_amount_of_items { my $dbh = shift; my $media_type = shift; my $group_type = shift; my $group_id = shift; my @item_amount = (); PDLNA::Database::select_db( $dbh, { 'query' => $SPECIFICVIEW_QUERIES{$SPECIFICVIEWS{$media_type}->{'GroupType'}->{$group_type}}->{'item_amount'}, 'parameters' => [ $group_id, $SPECIFICVIEWS{$media_type}->{'MediaType'}, ], }, \@item_amount, ); return $item_amount[0]->{AMOUNT}; } 1; pDLNA/usr/lib/perl5/PDLNA/SSDP.pm0000700000175000017500000002452213366114774015317 0ustar geumageumapackage PDLNA::SSDP; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; #use threads; use IO::Socket::INET; use IO::Socket::Multicast; use Net::Netmask; use PDLNA::Config; use PDLNA::Database; use PDLNA::Devices; use PDLNA::Log; sub new { my $class = shift; my $self = (); $self->{NTS} = [ $CONFIG{'UUID'}, 'upnp:rootdevice', 'urn:schemas-upnp-org:device:MediaServer:1', 'urn:schemas-upnp-org:service:ContentDirectory:1', 'urn:schemas-upnp-org:service:ConnectionManager:1', ]; $self->{MULTICAST_SEND_SOCKET} = undef; $self->{MULTICAST_LISTEN_SOCKET} = undef; $self->{PORT} = 1900; $self->{PROTO} = 'udp'; $self->{MULTICAST_GROUP} = '239.255.255.250'; bless($self, $class); return $self; } sub add_send_socket { my $self = shift; PDLNA::Log::log('Creating SSDP sending socket.', 1, 'discovery'); $self->{MULTICAST_SEND_SOCKET} = IO::Socket::INET->new( LocalAddr => $CONFIG{'LOCAL_IPADDR'}, PeerAddr => $self->{MULTICAST_GROUP}, PeerPort => $self->{PORT}, Proto => $self->{PROTO}, Blocking => 0, #ReuseAddr => 1, ) || PDLNA::Log::fatal('Cannot bind to SSDP sending socket: '.$!); } sub add_receive_socket { my $self = shift; PDLNA::Log::log('Creating SSDP listening socket (bind '.$self->{PROTO}.' '.$self->{MULTICAST_GROUP}.':'.$self->{PORT}.').', 1, 'discovery'); # socket for listening to M-SEARCH messages $self->{MULTICAST_LISTEN_SOCKET} = IO::Socket::Multicast->new( Proto => $self->{PROTO}, LocalPort => $self->{PORT}, #ReuseAddr => 1, ) || PDLNA::Log::fatal('Cannot bind to Multicast socket: '.$!); $self->{MULTICAST_LISTEN_SOCKET}->mcast_if($CONFIG{'LISTEN_INTERFACE'}); $self->{MULTICAST_LISTEN_SOCKET}->mcast_loopback(0); $self->{MULTICAST_LISTEN_SOCKET}->mcast_add( $self->{MULTICAST_GROUP}, $CONFIG{'LISTEN_INTERFACE'} ) || PDLNA::Log::fatal('Cannot bind to SSDP listening socket: '.$!); } sub send_byebye { my $self = shift; my $amount = shift || 2; PDLNA::Log::log('Sending SSDP byebye NOTIFY messages.', 1, 'discovery'); for (1..$amount) { foreach my $nt (@{$self->{NTS}}) { $self->{MULTICAST_SEND_SOCKET}->send( $self->ssdp_message({ 'notify' => 1, 'nt' => $nt, 'nts' => 'byebye', 'usn' => generate_usn($nt), }) ); } sleeper(3); } } sub send_alive { my $self = shift; my $amount = shift || 2; PDLNA::Log::log('Sending SSDP alive NOTIFY messages.', 1, 'discovery'); for (1..$amount) { foreach my $nt (@{$self->{NTS}}) { $self->{MULTICAST_SEND_SOCKET}->send( $self->ssdp_message({ 'notify' => 1, 'nt' => $nt, 'nts' => 'alive', 'usn' => generate_usn($nt), }) ); } sleeper(3); } } sub send_announce { my $self = shift; my $destination_ip = shift; # client ip address my $destination_port = shift; # client original source port, which gets the destination port for the response of the discover my $stparam = shift; # type of service my $mx = shift; # sleep timer # well, some devices seem to send M-SEARCH messages with a really large MX # let us work around that the following way $mx = 10 if $mx > 10; my @STS = (); foreach my $nts (@{$self->{NTS}}) { push(@STS, $stparam) if $stparam eq $nts; } @STS = @{$self->{NTS}} if $stparam eq "ssdp:all"; foreach my $st (@STS) { PDLNA::Log::log('Sending SSDP M-SEARCH response messages for '.$st.'.', 1, 'discovery'); my $data = $self->ssdp_message({ 'response' => 1, 'nts' => 'alive', 'usn' => generate_usn($st), 'st' => $st, }); for (1..2) { sleeper($mx); $self->{MULTICAST_LISTEN_SOCKET}->mcast_if($CONFIG{'LISTEN_INTERFACE'}); $self->{MULTICAST_LISTEN_SOCKET}->mcast_loopback(0); $self->{MULTICAST_LISTEN_SOCKET}->mcast_send($data, $destination_ip.":".$destination_port); } } } sub start_sending_periodic_alive_messages_thread { my $self = shift; PDLNA::Log::log('Starting thread for sending periodic SSDP alive messages.', 1, 'discovery'); my $thread = threads->create( sub { $self->send_periodic_alive_messages(); } ); $thread->detach(); } sub send_periodic_alive_messages { my $self = shift; while(1) { $self->send_alive(2); PDLNA::Devices::delete_expired_devices(); sleeper($CONFIG{'CACHE_CONTROL'}); } } sub start_listening_thread { my $self = shift; PDLNA::Log::log('Starting SSDP messages receiver thread.', 1, 'discovery'); my $thread = threads->create( sub { $self->receive_messages(); } ); $thread->detach(); } sub parse_ssdp_message { my $input_data = shift; my $output_data = shift; my @lines = split('\n', $input_data); for (my $i = 0; $i < @lines; $i++) { chomp($lines[$i]); $lines[$i] =~ s/\r//g; splice(@lines, $i, 1) if length($lines[$i]) == 0; } PDLNA::Log::log('Parsed SSDP message data: '.join(', ', @lines), 3, 'discovery'); if ($lines[0] =~ /(NOTIFY|M-SEARCH)/i) { $$output_data{'TYPE'} = uc($1); splice(@lines, 0, 1); } else { return 0; } foreach my $line (@lines) { if ($line =~ /^([\w\-]+):\s*(.*)$/i) { $$output_data{uc($1)} = $2; } else { return 0; } } # some final sanitations if (defined($$output_data{'USN'})) { my ($a, undef) = split('::', $$output_data{'USN'}); $$output_data{'USN'} = $a; # $$output_data{'USN'} =~ s/^uuid://; } if (defined($$output_data{'CACHE-CONTROL'})) { $$output_data{'CACHE-CONTROL'} = $1 if $$output_data{'CACHE-CONTROL'} =~ /^max-age\s*=\s*(\d+)/i; my $time = time(); $$output_data{'CACHE-CONTROL'} += $time; } $$output_data{'MX'} = 3 if !defined($$output_data{'MX'}); # end of final sanitations return 1; } sub receive_messages { my $self = shift; while(1) { my $data = undef; my $peeraddr = $self->{MULTICAST_LISTEN_SOCKET}->recv($data,1024); return unless defined($peeraddr); # received multicast packets without content?? my ($peer_src_port, $peer_addr) = sockaddr_in($peeraddr) if defined($peeraddr); my $peer_ip_addr = inet_ntoa($peer_addr) if defined($peer_addr); # Check if the peer is one of our allowed clients my $client_allowed = 0; foreach my $block (@{$CONFIG{'ALLOWED_CLIENTS'}}) { $client_allowed++ if $block->match($peer_ip_addr); } if ($client_allowed) { PDLNA::Log::log('Received SSDP message from allowed client IP '.$peer_ip_addr.'.', 2, 'discovery'); } else { PDLNA::Log::log('Ignoring SSDP message from NOT allowed client IP '.$peer_ip_addr.'.', 2, 'discovery'); next; } my %message = (); unless(parse_ssdp_message($data, \%message)) { PDLNA::Log::log('ERROR: Unable to parse SSDP message from client IP '.$peer_ip_addr.'. Ignoring message.', 0, 'discovery'); next; } if ($message{'TYPE'} eq 'NOTIFY') { # we will not add the running pDLNA installation to our SSDP database if ($peer_ip_addr eq $CONFIG{'LOCAL_IPADDR'} && $message{'USN'} eq $CONFIG{'UUID'}) { PDLNA::Log::log('Ignore SSDP message from allowed client IP '.$peer_ip_addr.', because the message came from this running '.$CONFIG{'PROGRAM_NAME'}.' installation.', 2, 'discovery'); next; } my $dbh = PDLNA::Database::connect(); if ($message{'NTS'} eq 'ssdp:alive' && defined($message{'NT'})) { PDLNA::Log::log('Adding UPnP device '.$message{'USN'}.' ('.$peer_ip_addr.') for '.$message{'NT'}.' to database.', 2, 'discovery'); PDLNA::Devices::add_device( $dbh, { 'ip' => $peer_ip_addr, 'udn' => $message{'USN'}, 'ssdp_banner' => $message{'SERVER'}, 'device_description_location' => $message{'LOCATION'}, 'nt' => $message{'NT'}, 'nt_time_of_expire' => $message{'CACHE-CONTROL'}, }, ); } elsif ($message{'NTS'} eq 'ssdp:byebye' && defined($message{'NT'})) { PDLNA::Log::log('Deleting UPnP device '.$message{'USN'}.' ('.$peer_ip_addr.') for '.$message{'NT'}.' from database.', 2, 'discovery'); PDLNA::Devices::delete_device( $dbh, { 'ip' => $peer_ip_addr, 'udn' => $message{'USN'}, 'nt' => $message{'NT'}, }, ); } PDLNA::Database::disconnect($dbh) } elsif ($message{'TYPE'} eq 'M-SEARCH') { if (defined($message{'MAN'}) && $message{'MAN'} eq '"ssdp:discover"') { PDLNA::Log::log('Received a SSDP M-SEARCH message by '.$peer_ip_addr.':'.$peer_src_port.' for a '.$message{'ST'}.' with an mx of '.$message{'MX'}.'.', 1, 'discovery'); # TODO start function in a thread - currently this is a blocking implementation $self->send_announce($peer_ip_addr, $peer_src_port, $message{'ST'}, $message{'MX'}); } } } } sub ssdp_message { my $self = shift; my $params = shift; my $msg = ''; $msg = "NOTIFY * HTTP/1.1\r\n" if $$params{'notify'}; $msg = "HTTP/1.1 200 OK\r\n" if $$params{'response'}; if ($$params{'nts'} eq 'alive' || $$params{'response'}) { $msg .= "CACHE-CONTROL: max-age = ".$CONFIG{'CACHE_CONTROL'}."\r\n"; $msg .= "EXT:\r\n" if $$params{'response'}; $msg .= "LOCATION: http://".$CONFIG{'LOCAL_IPADDR'}.":".$CONFIG{'HTTP_PORT'}."/ServerDesc.xml\r\n"; } if ($$params{'notify'}) { $msg .= "HOST: ".$self->{MULTICAST_GROUP}.":".$self->{PORT}."\r\n"; $msg .= "NT: $$params{'nt'}\r\n"; $msg .= "NTS: ssdp:$$params{'nts'}\r\n"; } if ($$params{'nts'} eq 'alive' || $$params{'response'}) { $msg .= "SERVER: ".$CONFIG{'OS'}."/".$CONFIG{'OS_VERSION'}.", UPnP/1.0, ".$CONFIG{'PROGRAM_NAME'}."/".PDLNA::Config::print_version()."\r\n"; } $msg .= "ST: $$params{'st'}\r\n" if $$params{'response'}; $msg .= "USN: $$params{'usn'}\r\n"; if ($$params{'response'}) { $msg .= "DATE: ".PDLNA::Utils::http_date()."\r\n"; #$msg .= "CONTENT-LENGTH: 0\r\n"; } $msg .= "\r\n"; return $msg; } sub generate_usn { my $nt = shift; my $usn = $CONFIG{'UUID'}; $usn .= '::'.$nt if $nt ne $CONFIG{'UUID'}; return $usn; } sub sleeper { my $interval = shift; $interval = 3 unless defined($interval); sleep(int(rand($interval))); } 1; pDLNA/usr/lib/perl5/PDLNA/HTTPXML.pm0000700000175000017500000007645413366114774015721 0ustar geumageumapackage PDLNA::HTTPXML; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Date::Format; use PDLNA::Config; use PDLNA::Database; use PDLNA::FFmpeg; use PDLNA::SpecificViews; use PDLNA::Utils; sub get_browseresponse_header { my @xml = ( '', '', '', '', '<DIDL-Lite xmlns="urn:schemas-upnp-org:metadata-1-0/DIDL-Lite/"', ' xmlns:sec="http://www.sec.co.kr/dlna"', ' xmlns:dlna="urn:schemas-dlna-org:metadata-1-0/"', ' xmlns:dc="http://purl.org/dc/elements/1.1/"', ' xmlns:upnp="urn:schemas-upnp-org:metadata-1-0/upnp/"', '>', ); return join('', @xml); } sub get_browseresponse_footer { my $number_returned = shift; my $total_matches = shift; my @xml = ( '</DIDL-Lite>', '', ''.PDLNA::Utils::encode_xml($number_returned).'', ''.PDLNA::Utils::encode_xml($total_matches).'', '0', '', '', '', ); return join('', @xml); } sub get_browseresponse_group_specific { my $group_id = shift; my $media_type = shift; my $group_type = shift; my $group_name = shift; my $filter = shift; my $dbh = shift; my $group_elements_amount = PDLNA::SpecificViews::get_amount_of_items($dbh, $media_type, $group_type, $group_id); my $group_parent_id = $media_type.'_'.$group_type; my @xml = (); push(@xml, '<container '); push(@xml, 'id="'.$group_parent_id.'_'.PDLNA::Utils::add_leading_char($group_id, 4, '0').'" ') if grep(/^\@id$/, @{$filter}); push(@xml, 'parentID="'.$group_parent_id.'" ') if grep(/^\@parentID$/, @{$filter}); push(@xml, 'restricted="1" ') if grep(/^\@restricted$/, @{$filter}); push(@xml, 'childCount="'.$group_elements_amount.'">') if grep(/^\@childCount$/, @{$filter}); push(@xml, '<dc:title>'.$group_name.'</dc:title>') if grep(/^dc:title$/, @{$filter}); push(@xml, '<upnp:class>object.container</upnp:class>') if grep(/^upnp:class$/, @{$filter}); push(@xml, '</container>'); return join('', @xml); } sub get_browseresponse_item_specific { my $item_id = shift; my $media_type = shift; my $group_type = shift; my $group_id = shift; my $filter = shift; my $dbh = shift; my $client_ip = shift; my $user_agent = shift; my $item_parent_id = $media_type.'_'.$group_type.'_'.PDLNA::Utils::add_leading_char($group_id, 4, '0'); my @xml = (); push(@xml, '<item '); push(@xml, 'id="'.$item_parent_id.'_'.PDLNA::Utils::add_leading_char($item_id, 3, '0').'" ') if grep(/^\@id$/, @{$filter}); push(@xml, 'parentID="'.$item_parent_id.'" ') if grep(/^\@parentID$/, @{$filter}); get_browseresponse_item_detailed($item_id, $filter, $dbh, $client_ip, $user_agent, \@xml); return join('', @xml); } sub get_browseresponse_container { my $id = shift; my $title = shift; my $filter = shift; my $dbh = shift; my $parent_id = PDLNA::ContentLibrary::get_parentid_by_id($dbh, $id); my $amount = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'parent_id', $id); my @xml = (); push(@xml, '<container '); push(@xml, 'id="'.PDLNA::Utils::encode_xml($id).'" ') if grep(/^\@id$/, @{$filter}); push(@xml, 'parentID="'.PDLNA::Utils::encode_xml($parent_id).'" ') if grep(/^\@parentID$/, @{$filter}); # searchable="0" push(@xml, 'restricted="1" ') if grep(/^\@restricted$/, @{$filter}); push(@xml, 'childCount="'.PDLNA::Utils::encode_xml($amount).'">') if grep(/^\@childCount$/, @{$filter}); push(@xml, '<dc:title>'.PDLNA::Utils::encode_xml($title).'</dc:title>') if grep(/^dc:title$/, @{$filter}); push(@xml, '<upnp:class>object.container</upnp:class>') if grep(/^upnp:class$/, @{$filter}); # <upnp:objectUpdateID>5</upnp:objectUpdateID> # <sec:initUpdateID>5</sec:initUpdateID> # <sec:classCount class="object.container">0</sec:classCount> # <sec:classCount class="object.item.imageItem">0</sec:classCount> # <sec:classCount class="object.item.audioItem">0</sec:classCount> # <sec:classCount class="object.item.videoItem">0</sec:classCount> push(@xml, '</container>'); return join('', @xml); } sub get_browseresponse_item { my $id = shift; my $filter = shift; my $dbh = shift; my $client_ip = shift; my $user_agent = shift; my @xml = (); push(@xml, '<item '); push(@xml, 'id="'.PDLNA::Utils::encode_xml($id).'" ') if grep(/^\@id$/, @{$filter}); get_browseresponse_item_detailed($id, $filter, $dbh, $client_ip, $user_agent, \@xml); push(@xml, '</item>'); return join('', @xml); } sub get_browseresponse_item_detailed { my $id = shift; my $filter = shift; my $dbh = shift; my $client_ip = shift; my $user_agent = shift; my $xml = shift; my @item = PDLNA::ContentLibrary::get_item_by_id($dbh, $id, [ 'item_type', 'media_type', 'mime_type', 'title', 'size', 'file_extension', 'date', 'duration', 'width', 'height' ]); # # GENERAL ITEM DESCRIPTION # push(@{$xml}, 'parentID="'.PDLNA::Utils::encode_xml($item[0]->{parent_id}).'" ') if grep(/^\@parentID$/, @{$filter}); push(@{$xml}, 'restricted="1">') if grep(/^\@restricted$/, @{$filter}); push(@{$xml}, '<dc:title>'.PDLNA::Utils::encode_xml($item[0]->{title}).'</dc:title>') if grep(/^dc:title$/, @{$filter}); push(@{$xml}, '<upnp:class>object.item.'.PDLNA::Utils::encode_xml($item[0]->{media_type}).'Item</upnp:class>') if grep(/^upnp:class$/, @{$filter}); my $date = time2str("%Y-%m-%d", $item[0]->{date}); push(@{$xml}, '<dc:date>'.PDLNA::Utils::encode_xml($date).'</dc:date>') if grep(/^dc:date$/, @{$filter}); push(@{$xml}, '<sec:modifiationDate>'.PDLNA::Utils::encode_xml($date).'</sec:modifiationDate>') if grep(/^sec:modifiationDate$/, @{$filter}); if (grep(/^sec:dcmInfo$/, @{$filter})) { my @infos = (); if ($item[0]->{media_type} eq 'image') { push(@infos, 'WIDTH='.PDLNA::Utils::encode_xml($item[0]->{width})); push(@infos, 'HEIGHT='.PDLNA::Utils::encode_xml($item[0]->{height})); } push(@infos, 'CREATIONDATE='.PDLNA::Utils::encode_xml($item[0]->{date})); push(@{$xml}, '<sec:dcmInfo>'.join(',', @infos).'</sec:dcmInfo>'); } # # RESOURCE ITEM DESCRIPTION # my $url_scheme = 'http://'.PDLNA::Utils::encode_xml($CONFIG{'LOCAL_IPADDR'}).':'.PDLNA::Utils::encode_xml($CONFIG{'HTTP_PORT'}); push(@{$xml}, '<res '); if ($item[0]->{media_type} eq 'audio' || $item[0]->{media_type} eq 'video') { my $duration = PDLNA::Utils::convert_duration($item[0]->{duration}); push(@{$xml}, 'duration="'.PDLNA::Utils::encode_xml($duration).'" ') if grep(/^res\@duration$/, @{$filter}); } push(@{$xml}, 'size="'.PDLNA::Utils::encode_xml($item[0]->{size}).'" ') if grep(/^res\@size$/, @{$filter}); push(@{$xml}, 'protocolInfo="http-get:*:'.PDLNA::Utils::encode_xml($item[0]->{mime_type}).':'.PDLNA::Media::get_dlnacontentfeatures($item[0]).'" '); push(@{$xml}, '>'); push(@{$xml}, $url_scheme.'/media/'.PDLNA::Utils::encode_xml($id.'.'.$item[0]->{file_extension})); push(@{$xml}, '</res>'); # # THUMBNAILS # if (($item[0]->{media_type} eq 'image' && $CONFIG{'IMAGE_THUMBNAILS'}) || ($item[0]->{media_type} && $CONFIG{'VIDEO_THUMBNAILS'})) { push(@{$xml}, '<res protocolInfo='); push(@{$xml}, '"http-get:*:image/jpeg:'.PDLNA::Utils::encode_xml(PDLNA::Media::get_dlnacontentfeatures('JPEG_TN', 1)).'" '); push(@{$xml}, '>'); push(@{$xml}, $url_scheme.'/preview/'.PDLNA::Utils::encode_xml($id).'.jpg'); push(@{$xml}, '</res>'); } # # SUBTITLES # if ($item[0]->{media_type} eq 'video' && grep(/^sec:CaptionInfoEx$/, @{$filter})) { my @subtitles = PDLNA::ContentLibrary::get_subtitles_by_refid($dbh, $id); foreach my $subtitle (@subtitles) { push(@{$xml}, '<sec:CaptionInfoEx sec:type="'.PDLNA::Utils::encode_xml($subtitle->{media_type}).'" >'); push(@{$xml}, $url_scheme.'/media/'.PDLNA::Utils::encode_xml($subtitle->{id}.'.'.$subtitle->{file_extension})); push(@{$xml}, '</sec:CaptionInfoEx>'); } } } sub foo { my $item_id = 0; my $xml; my $dbh; my ($client_ip, $user_agent, $filter); my @item = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT NAME, FULLNAME, TYPE, DATE, SIZE, MIME_TYPE, FILE_EXTENSION, EXTERNAL FROM FILES WHERE ID = ?;', 'parameters' => [ $item_id, ], }, \@item, ); my @iteminfo = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT WIDTH, HEIGHT, BITRATE, DURATION, ARTIST, ALBUM, GENRE, YEAR, TRACKNUM, CONTAINER, AUDIO_CODEC, VIDEO_CODEC FROM FILEINFO WHERE FILEID_REF = ?;', 'parameters' => [ $item_id, ], }, \@iteminfo, ); # # check if we need to transcode the content # my %media_data = ( 'fullname' => $item[0]->{FULLNAME}, 'external' => $item[0]->{EXTERNAL}, 'media_type' => $item[0]->{TYPE}, 'container' => $iteminfo[0]->{CONTAINER}, 'audio_codec' => $iteminfo[0]->{AUDIO_CODEC}, 'video_codec' => $iteminfo[0]->{VIDEO_CODEC}, ); my $transcode = 0; if ($transcode = PDLNA::FFmpeg::shall_we_transcode( \%media_data, { 'ip' => $client_ip, 'user_agent' => $user_agent, }, )) { $item[0]->{MIME_TYPE} = $media_data{'mime_type'}; $iteminfo[0]->{CONTAINER} = $media_data{'container'}; $iteminfo[0]->{AUDIO_CODEC} = $media_data{'audio_codec'}; $iteminfo[0]->{VIDEO_CODEC} = $media_data{'video_codec'}; $iteminfo[0]->{BITRATE} = 0; $iteminfo[0]->{VBR} = 0; } # # end of checking for transcoding # if ($item[0]->{TYPE} eq 'audio') { push(@{$xml}, '<upnp:artist>'.PDLNA::Utils::encode_xml($iteminfo[0]->{ARTIST}).'</upnp:artist>') if grep(/^upnp:artist$/, @{$filter}); push(@{$xml}, '<dc:creator>'.PDLNA::Utils::encode_xml($iteminfo[0]->{ARTIST}).'</dc:creator>') if grep(/^dc:creator$/, @{$filter}); push(@{$xml}, '<upnp:album>'.PDLNA::Utils::encode_xml($iteminfo[0]->{ALBUM}).'</upnp:album>') if grep(/^upnp:album$/, @{$filter}); push(@{$xml}, '<upnp:genre>'.PDLNA::Utils::encode_xml($iteminfo[0]->{GENRE}).'</upnp:genre>') if grep(/^upnp:genre$/, @{$filter}); push(@{$xml}, '<upnp:originalTrackNumber>'.PDLNA::Utils::encode_xml($iteminfo[0]->{TRACKNUM}).'</upnp:originalTrackNumber>') if grep(/^upnp:originalTrackNumber$/, @{$filter}); # albumArtURI } elsif ($item[0]->{TYPE} eq 'image') { # <sec:manufacturer>NIKON CORPORATION</sec:manufacturer> # <sec:fvalue>4.5</sec:fvalue> # <sec:exposureTime>0.008</sec:exposureTime> # <sec:iso>2500</sec:iso> # <sec:model>NIKON D700</sec:model> # <sec:composition>0</sec:composition> # <sec:color>0</sec:color> } push(@{$xml}, '<upnp:playbackCount>0</upnp:playbackCount>') if grep(/^upnp:playbackCount$/, @{$filter}); push(@{$xml}, '<sec:preference>0</sec:preference>') if grep(/^sec:preference$/, @{$filter}); push(@{$xml}, '<dc:date>'.PDLNA::Utils::encode_xml(time2str("%Y-%m-%d", $item[0]->{DATE})).'</dc:date>') if grep(/^dc:date$/, @{$filter}); push(@{$xml}, '<sec:modifiationDate>'.PDLNA::Utils::encode_xml(time2str("%Y-%m-%d", $item[0]->{DATE})).'</sec:modifiationDate>') if grep(/^sec:modifiationDate$/, @{$filter}); if (grep(/^sec:dcmInfo$/, @{$filter})) { my @infos = (); # push(@infos, 'MOODSCORE=0') if $item->type() eq 'audio'; # push(@infos, 'MOODID=5') if $item->type() eq 'audio'; # push(@infos, 'WIDTH='.PDLNA::Utils::encode_xml($iteminfo[0]->{WIDTH})) if $item[0]->{TYPE} eq 'image'; push(@infos, 'HEIGHT='.PDLNA::Utils::encode_xml($iteminfo[0]->{HEIGHT})) if $item[0]->{TYPE} eq 'image'; # push(@infos, 'COMPOSCORE=0') if $item->type() eq 'image'; # push(@infos, 'COMPOID=0') if $item->type() eq 'image'; # push(@infos, 'COLORSCORE=0') if $item->type() eq 'image'; # push(@infos, 'COLORID=0') if $item->type() eq 'image'; # push(@infos, 'MONTHLY=12') if $item->type() eq 'image'; # push(@infos, 'ORT=1') if $item->type() eq 'image'; # push(@infos, 'CREATIONDATE='.PDLNA::Utils::encode_xml($item[0]->{DATE})); # push(@infos, 'YEAR='.time2str("%Y", $item->date())) if $item->type() eq 'audio'; # push(@infos, 'FOLDER=') if $item->type() =~ /^(image|video)$/; # # BOOKMARKS # if ($item[0]->{TYPE} eq 'video') { my $bookmark = 0; my $device_ip_id = PDLNA::Devices::get_device_ip_id_by_device_ip($dbh, $client_ip); if (defined($device_ip_id)) { $bookmark = PDLNA::Database::select_db_field_int( $dbh, { 'query' => 'SELECT pos_seconds FROM device_bm WHERE item_id_ref = ? AND device_ip_ref = ?', 'parameters' => [ $item_id, $device_ip_id, ], }, ); } push(@infos, 'BM='.PDLNA::Utils::encode_xml($bookmark)); } push(@{$xml}, '<sec:dcmInfo>'.join(',', @infos).'</sec:dcmInfo>'); } my $url_scheme = 'http://'.PDLNA::Utils::encode_xml($CONFIG{'LOCAL_IPADDR'}).':'.PDLNA::Utils::encode_xml($CONFIG{'HTTP_PORT'}); push(@{$xml}, '<res '); if ($item[0]->{TYPE} eq 'video') { # push(@xml, 'sec:acodec="'..'" '); # push(@xml, 'sec:vcodec="'..'" '); # sec:acodec="ac3" sec:vcodec="mpeg2video" } if ($item[0]->{TYPE} eq 'audio' || $item[0]->{TYPE} eq 'video') { push(@{$xml}, 'bitrate="'.PDLNA::Utils::encode_xml($iteminfo[0]->{BITRATE}).'" ') if grep(/^res\@bitrate$/, @{$filter}); push(@{$xml}, 'duration="'.PDLNA::Utils::encode_xml(PDLNA::Utils::convert_duration($iteminfo[0]->{DURATION})).'" ') if grep(/^res\@duration$/, @{$filter}); } if ($item[0]->{TYPE} eq 'image' || $item[0]->{TYPE} eq 'video') { push(@{$xml}, 'resolution="'.PDLNA::Utils::encode_xml($iteminfo[0]->{WIDTH}).'x'.PDLNA::Utils::encode_xml($iteminfo[0]->{HEIGHT}).'" ') if grep(/^res\@resolution$/, @{$filter}); } if ($transcode == 0 || $item[0]->{EXTERNAL} == 0) # just add the size attribute if file is local and not transcoded { push(@{$xml}, 'size="'.PDLNA::Utils::encode_xml($item[0]->{SIZE}).'" ') if grep(/^res\@size$/, @{$filter}); } push(@{$xml}, 'protocolInfo="http-get:*:'.PDLNA::Utils::encode_xml($item[0]->{MIME_TYPE}).':'.PDLNA::Utils::encode_xml(PDLNA::Media::get_dlnacontentfeatures($item[0], $transcode)).'" '); push(@{$xml}, '>'); push(@{$xml}, $url_scheme.'/media/'.PDLNA::Utils::encode_xml($item_id).'.'.PDLNA::Utils::encode_xml($item[0]->{FILE_EXTENSION})); push(@{$xml}, '</res>'); # File preview information if ( # $item->file() && # no thumbnails for commands or streams ($item[0]->{TYPE} eq 'image' && $CONFIG{'IMAGE_THUMBNAILS'}) || ($item[0]->{TYPE} eq 'video' && $CONFIG{'VIDEO_THUMBNAILS'}) ) { push(@{$xml}, '<res protocolInfo='); push(@{$xml}, '"http-get:*:image/jpeg:'.PDLNA::Utils::encode_xml(PDLNA::Media::get_dlnacontentfeatures(undef, 1, 'JPEG_TN')).'" '); push(@{$xml}, '>'); push(@{$xml}, $url_scheme.'/preview/'.PDLNA::Utils::encode_xml($item_id).'.jpg'); push(@{$xml}, '</res>'); } # subtitles if ($item[0]->{TYPE} eq 'video' && grep(/^sec:CaptionInfoEx$/, @{$filter})) { my @subtitles = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, type FROM subtitles WHERE fileid_ref = ?', 'parameters' => [ $item_id, ], }, \@subtitles, ); foreach my $subtitle (@subtitles) { push(@{$xml}, '<sec:CaptionInfoEx sec:type="'.PDLNA::Utils::encode_xml($subtitle->{type}).'" >'); push(@{$xml}, $url_scheme.'/subtitle/'.PDLNA::Utils::encode_xml($subtitle->{id}).'.'.PDLNA::Utils::encode_xml($subtitle->{type})); push(@{$xml}, '</sec:CaptionInfoEx>'); } } push(@{$xml}, '</item>'); } # # This is not the most elegant solution, # but at least it is more generic # # TODO: make me more beautiful # sub lookup_elementvalue_in_xml { my $xml = shift; my $name = shift; foreach my $key1 (%{$xml}) { if ($key1 =~ /:Body$/) { foreach my $key2 (%{$xml->{$key1}}) { if ($key2 =~ /:Browse$/) { if (ref($xml->{$key1}->{$key2}->{$name}) eq 'HASH') { return $xml->{$key1}->{$key2}->{$name}->{'content'}; } else { return $xml->{$key1}->{$key2}->{$name}; } } } } } return undef; } sub get_serverdescription { my $user_agent = shift || ''; my @xml = ( #'', '', '', '', '1', '5', '', '', ); # this seems to break some clients if ($user_agent eq 'SamsungWiselinkPro/1.0') { #push(@xml, 'DMS-1.50'); push(@xml, 'DMS-1.50'); push(@xml, 'M-DMS-1.50'); push(@xml, 'av-upload,image-upload,audio-upload'); } push(@xml, 'urn:schemas-upnp-org:device:MediaServer:1'); push(@xml, 'http://'.PDLNA::Utils::encode_xml($CONFIG{'LOCAL_IPADDR'}).':'.PDLNA::Utils::encode_xml($CONFIG{'HTTP_PORT'}).'/'); push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'FRIENDLY_NAME'}).''); push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'PROGRAM_AUTHOR'}).''); push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'AUTHOR_WEBSITE'}).''); push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'PROGRAM_DESC'}).''); push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'PROGRAM_NAME'}).''); push(@xml, ''.PDLNA::Utils::encode_xml(PDLNA::Config::print_version()).''); push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'PROGRAM_WEBSITE'}).''); push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'PROGRAM_SERIAL'}).''); # specific views my $dcm10 = ''; if ($CONFIG{'SPECIFIC_VIEWS'}) { $dcm10 = 'DCM10,'; } if ($user_agent eq 'SamsungWiselinkPro/1.0') { push(@xml, 'smi,'.$dcm10.'getMediaInfo.sec,getCaptionInfo.sec'); push(@xml, 'smi,'.$dcm10.'getMediaInfo.sec,getCaptionInfo.sec'); } push(@xml, ''.PDLNA::Utils::encode_xml($CONFIG{'UUID'}).''); my %TYPES = ( 'png' => 'png', 'jpeg' => 'jpeg', #'bmp' => 'x-ms-bmp', ); push(@xml, ''); foreach my $size ('120', '48', '32') { foreach my $type (keys %TYPES) { push(@xml, ''); push(@xml, 'image/'.$TYPES{$type}.''); push(@xml, ''.$size.''); push(@xml, ''.$size.''); push(@xml, '24'); push(@xml, '/icons/'.$size.'/icon.'.$type.''); push(@xml, ''); } } push(@xml, ''); push(@xml, ''); push(@xml, ''); push(@xml, 'urn:schemas-upnp-org:service:ConnectionManager:1'); push(@xml, 'urn:upnp-org:serviceId:ConnectionManager'); push(@xml, 'ConnectionManager1.xml'); push(@xml, '/upnp/control/ConnectionManager1'); push(@xml, '/upnp/event/ConnectionManager1'); push(@xml, ''); push(@xml, ''); push(@xml, 'urn:schemas-upnp-org:service:ContentDirectory:1'); push(@xml, 'urn:upnp-org:serviceId:ContentDirectory'); push(@xml, 'ContentDirectory1.xml'); push(@xml, '/upnp/control/ContentDirectory1'); push(@xml, '/upnp/event/ContentDirectory1'); push(@xml, ''); push(@xml, ''); push(@xml, ''); push(@xml, 'http://'.PDLNA::Utils::encode_xml($CONFIG{'LOCAL_IPADDR'}).':'.PDLNA::Utils::encode_xml($CONFIG{'HTTP_PORT'}).'/'); push(@xml, ''); return join('', @xml); } sub get_contentdirectory { my @xml = ( '', '', '', '1', '0', '', '', '', 'Browse', '', '', 'ObjectID', 'in', 'A_ARG_TYPE_ObjectID', '', '', 'BrowseFlag', 'in', 'A_ARG_TYPE_BrowseFlag', '', '', 'Filter', 'in', 'A_ARG_TYPE_Filter', '', '', 'StartingIndex', 'in', 'A_ARG_TYPE_Index', '', '', 'RequestedCount', 'in', 'A_ARG_TYPE_Count', '', '', 'SortCriteria', 'in', 'A_ARG_TYPE_SortCriteria', '', '', 'Result', 'out', 'A_ARG_TYPE_Result', '', '', 'NumberReturned', 'out', 'A_ARG_TYPE_Count', '', '', 'TotalMatches', 'out', 'A_ARG_TYPE_Count', '', '', 'UpdateID', 'out', 'A_ARG_TYPE_UpdateID', '', '', '', '', 'GetSearchCapabilities', '', '', 'SearchCaps', 'out', 'SearchCapabilities', '', '', '', '', 'GetSortCapabilities', '', '', 'SortCaps', 'out', 'SortCapabilities', '', '', '', '', 'GetSystemUpdateID', '', '', 'Id', 'out', 'SystemUpdateID', '', '', '', '', 'X_SetBookmark', '', '', 'CategoryType', 'in', 'A_ARG_TYPE_CategoryType', '', '', 'RID', 'in', 'A_ARG_TYPE_RID', '', '', 'ObjectID', 'in', 'A_ARG_TYPE_ObjectID', '', '', 'PosSecond', 'in', 'A_ARG_TYPE_PosSec', '', '', '', '', '', '', 'A_ARG_TYPE_BrowseFlag', 'string', '', 'BrowseMetadata', 'BrowseDirectChildren', '', '', '', 'SystemUpdateID', 'ui4', '', '', 'ContainerUpdateIDs', 'string', '', '', 'A_ARG_TYPE_Count', 'ui4', '', '', 'A_ARG_TYPE_SortCriteria', 'string', '', '', 'SortCapabilities', 'string', '', '', 'A_ARG_TYPE_Index', 'ui4', '', '', 'A_ARG_TYPE_ObjectID', 'string', '', '', 'A_ARG_TYPE_UpdateID', 'ui4', '', '', 'A_ARG_TYPE_Result', 'string', '', '', 'SearchCapabilities', 'string', '', '', 'A_ARG_TYPE_Filter', 'string', '', '', 'A_ARG_TYPE_CategoryType', 'ui4', '', '', '', 'A_ARG_TYPE_RID', 'ui4', '', '', '', 'A_ARG_TYPE_PosSec', 'ui4', '', '', '', '', ); return join('', @xml); } sub get_connectionmanager { my @xml = ( '', '', '', '1', '0', '', '', '', 'GetCurrentConnectionIDs', '', '', 'ConnectionIDs', 'out', 'CurrentConnectionIDs', '', '', '', '', 'GetCurrentConnectionInfo', '', '', 'ConnectionID', 'in', 'A_ARG_TYPE_ConnectionID', '', '', 'RcsID', 'out', 'A_ARG_TYPE_RcsID', '', '', 'AVTransportID', 'out', 'A_ARG_TYPE_AVTransportID', '', '', 'ProtocolInfo', 'out', 'A_ARG_TYPE_ProtocolInfo', '', '', 'PeerConnectionManager', 'out', 'A_ARG_TYPE_ConnectionManager', '', '', 'PeerConnectionID', 'out', 'A_ARG_TYPE_ConnectionID', '', '', 'Direction', 'out', 'A_ARG_TYPE_Direction', '', '', 'Status', 'out', 'A_ARG_TYPE_ConnectionStatus', '', '', '', '', 'GetProtocolInfo', '', '', 'Source', 'out', 'SourceProtocolInfo', '', '', 'Sink', 'out', 'SinkProtocolInfo', '', '', '', '', '', '', 'A_ARG_TYPE_ProtocolInfo', 'string', '', '', 'A_ARG_TYPE_ConnectionStatus', 'string', '', 'OK', 'ContentFormatMismatch', 'InsufficientBandwidth', 'UnreliableChannel', 'Unknown', '', '', '', 'A_ARG_TYPE_AVTransportID', 'i4', '', '', 'A_ARG_TYPE_RcsID', 'i4', '', '', 'A_ARG_TYPE_ConnectionID', 'i4', '', '', 'A_ARG_TYPE_ConnectionManager', 'string', '', '', 'SourceProtocolInfo', 'string', '', '', 'SinkProtocolInfo', 'string', '', '', 'A_ARG_TYPE_Direction', 'string', '', 'Input', 'Output', '', '', '', 'CurrentConnectionIDs', 'string', '', '', '', ); return join('', @xml); } 1; pDLNA/usr/lib/perl5/PDLNA/DeviceService.pm0000700000175000017500000000757013366114774017272 0ustar geumageumapackage PDLNA::DeviceService; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use threads; use threads::shared; use XML::Simple; use PDLNA::DeviceServiceAction; use PDLNA::Utils; # constructor sub new { my $class = shift; my $params = shift; my %self : shared = ( ID => $$params{'service_id'}, TYPE => $$params{'service_type'}, CONTROL_URL => $$params{'controlURL'}, EVENTSUB_URL => $$params{'eventSubURL'}, SCPD_URL => $$params{'SCPDURL'}, ); my %actions : shared = (); my $response = PDLNA::Utils::fetch_http($self{SCPD_URL}); if ($response) { my $xs = XML::Simple->new(); my $xml = eval { $xs->XMLin($response) }; if ($@) { PDLNA::Log::log('ERROR: Unable to parse XML Service Description in PDLNA::DeviceService: '.$@, 0, 'discovery'); } else { if (ref($xml->{'actionList'}->{'action'}) eq 'HASH') # we need to check if it is a hash { foreach my $action (keys %{$xml->{'actionList'}->{'action'}}) { my %action_definition = (); $action_definition{'action'} = $action; $action_definition{'parameters'} = {}; $action_definition{'variables'} = {}; if (ref($xml->{'actionList'}->{'action'}->{$action}->{'argumentList'}->{'argument'}) eq 'HASH') # we need to check if it is a hash { foreach my $argument (keys %{$xml->{'actionList'}->{'action'}->{$action}->{'argumentList'}->{'argument'}}) { if (ref($xml->{'actionList'}->{'action'}->{$action}->{'argumentList'}->{'argument'}->{$argument}) eq 'HASH') { foreach my $variable (keys %{$xml->{'actionList'}->{'action'}->{$action}->{'argumentList'}->{'argument'}->{$argument}}) { my %variable_definition = (); foreach my $param ('direction', 'relatedStateVariable', 'retval') { $variable_definition{$param} = $xml->{'actionList'}->{'action'}->{$action}->{'argumentList'}->{'argument'}->{$argument}->{$param}; } $action_definition{'parameters'}->{$argument} = \%variable_definition; $action_definition{'variables'}->{$argument} = $xml->{'serviceStateTable'}->{'stateVariable'}->{$variable_definition{'relatedStateVariable'}}; } } else { # TODO different structure when only one parameter is available } } } $actions{$action} = PDLNA::DeviceServiceAction->new(\%action_definition); } } } } $self{ACTIONS} = \%actions; bless(\%self, $class); return \%self; } # prints the object information sub print_object { my $self = shift; my $string = ''; $string .= "\t\t\t\tObject PDLNA::DeviceService\n"; $string .= "\t\t\t\t\tID: ".$self->{ID}."\n" if defined($self->{ID}); $string .= "\t\t\t\t\tType: ".$self->{TYPE}."\n" if defined($self->{ID}); $string .= "\t\t\t\t\tControlURL: ".$self->{CONTROL_URL}."\n" if defined($self->{ID}); $string .= "\t\t\t\t\tEventSubURL: ".$self->{EVENTSUB_URL}."\n" if defined($self->{ID}); $string .= "\t\t\t\t\tSCPDURL: ".$self->{SCPD_URL}."\n" if defined($self->{ID}); foreach my $action (keys %{$self->{ACTIONS}}) { $string .= $self->{ACTIONS}{$action}->print_object();; } $string .= "\t\t\t\tObject PDLNA::DeviceService END\n"; return $string; } 1; pDLNA/usr/lib/perl5/PDLNA/SOAPMessages.pm0000700000175000017500000000411313366114774016772 0ustar geumageumapackage PDLNA::SOAPMessages; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Date::Format; use PDLNA::Config; use PDLNA::SOAPClient; sub send_sms { my $service_type = shift; my $service_url = shift; my $message = shift; my $fullmessage = undef; $fullmessage .= 'SMS'; $fullmessage .= 'Maximum'; my $now = time(); $fullmessage .= ''.time2str('%y-%m-%d', $now).''; $fullmessage .= '1111You'; $fullmessage .= '0000'.$CONFIG{'PROGRAM_NAME'}.''; $fullmessage .= ''.$message.''; my $client = _soapclient($service_type, $service_url); $client->method('AddMessage'); my @arguments = (); push (@arguments, [ 'MessageType', 'text/xml', ]); push (@arguments, [ 'MessageID', 1, ]); push (@arguments, [ 'Message', $fullmessage, ]); foreach my $argument (@arguments) { $client->add_argument( { 'type' => 'string', 'name' => $argument->[0], 'value' => $argument->[1], } ); } $client->send(); } # # HELPER FUNCTIONS # sub _soapclient { my $service_type = shift; my $service_url = shift; my $client = PDLNA::SOAPClient->new( { 'proxy' => $service_url, 'uri' => $service_type, } ); return $client; } 1; pDLNA/usr/lib/perl5/PDLNA/Config.pm0000700000175000017500000005673613366531022015754 0ustar geumageumapackage PDLNA::Config; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use base 'Exporter'; our @ISA = qw(Exporter); our @EXPORT = qw(%CONFIG); use Config qw(); use Config::ApacheFormat; use DBI; use Digest::MD5; use Digest::SHA; use File::Basename; use File::MimeInfo; use IO::Interface::Simple; use Net::IP; use Net::Netmask; use Sys::Hostname qw(hostname); use PDLNA::Media; our %CONFIG = ( # values which can be modified by configuration file 'FRIENDLY_NAME' => 'pDLNA $VERSION on $HOSTNAME', 'LOCAL_IPADDR' => undef, 'LISTEN_INTERFACE' => undef, 'HTTP_PORT' => 8001, 'CACHE_CONTROL' => 1800, 'PIDFILE' => '/var/run/pdlna.pid', 'ALLOWED_CLIENTS' => [], 'DB_TYPE' => 'SQLITE3', 'DB_NAME' => '/tmp/pdlna.db', 'DB_USER' => 'pdlna', 'DB_PASS' => '', 'LOG_FILE_MAX_SIZE' => 10485760, # 10 MB 'LOG_FILE' => 'STDERR', 'LOG_FILE_ROTATION_AMOUNT' => 0, 'LOG_CATEGORY' => [], 'DATE_FORMAT' => '%Y-%m-%d %H:%M:%S', 'BUFFER_SIZE' => 32768, # 32 kB 'DEBUG' => 0, 'SPECIFIC_VIEWS' => 0, 'CHECK_UPDATES' => 1, 'CHECK_UPDATES_NOTIFICATION' => 1, 'ENABLE_GENERAL_STATISTICS' => 1, 'ENABLE_DATABASE_STATISTICS' => 0, 'RESCAN_MEDIA' => 86400, 'UUID' => 'Version4', 'TMP_DIR' => '/tmp', 'IMAGE_THUMBNAILS' => 0, 'VIDEO_THUMBNAILS' => 0, 'LOW_RESOURCE_MODE' => 0, 'FFMPEG_BIN' => '/usr/bin/ffmpeg', 'DIRECTORIES' => [], 'EXTERNALS' => [], 'TRANSCODING_PROFILES' => [], # values which can be modified manually :P 'PROGRAM_NAME' => 'pDLNA', 'PROGRAM_VERSION' => '0.70.2', 'PROGRAM_DATE' => '2018-11-01', 'PROGRAM_BETA' => 0, 'PROGRAM_DBVERSION' => '1.8', 'PROGRAM_WEBSITE' => 'https://www.pdlna.org', 'PROGRAM_AUTHOR' => 'Stefan Heumader-Rainer', 'PROGRAM_DESC' => 'Perl DLNA MediaServer', 'AUTHOR_WEBSITE' => 'https://www.urandom.at', 'PROGRAM_SERIAL' => 1337, # arrays holding supported codec 'AUDIO_CODECS_ENCODE' => [], 'AUDIO_CODECS_DECODE' => [], 'VIDEO_CODECS_ENCODE' => [], 'VIDEO_CODECS_DECODE' => [], 'FORMATS_ENCODE' => [], 'FORMATS_DECODE' => [], 'OS' => $Config::Config{osname}, 'OS_VERSION' => $Config::Config{osvers}, 'HOSTNAME' => hostname(), ); sub print_version { my $string = $CONFIG{'PROGRAM_VERSION'}; $string .= 'b' if $CONFIG{'PROGRAM_BETA'}; return $string; } sub eval_binary_value { my $value = lc(shift); if ($value eq 'on' || $value eq 'true' || $value eq 'yes' || $value eq 'enable' || $value eq 'enabled' || $value eq '1') { return 1; } return 0; } sub parse_config { my $file = shift; my $errormsg = shift; if (!-f $file) { push(@{$errormsg}, 'Configfile '.$file.' NOT found.'); return 0; } my $cfg = Config::ApacheFormat->new( valid_blocks => [qw(Directory External Transcode)], ); unless ($cfg->read($file)) { push(@{$errormsg}, 'Configfile '.$file.' is NOT readable.'); return 0; } # # FRIENDLY NAME PARSING # $CONFIG{'FRIENDLY_NAME'} = $cfg->get('FriendlyName') if defined($cfg->get('FriendlyName')); my $version_string = print_version(); $CONFIG{'FRIENDLY_NAME'} =~ s/\$VERSION/v$version_string/; $CONFIG{'FRIENDLY_NAME'} =~ s/\$HOSTNAME/$CONFIG{'HOSTNAME'}/; $CONFIG{'FRIENDLY_NAME'} =~ s/\$OS/$CONFIG{'OS'}/; if ($CONFIG{'FRIENDLY_NAME'} !~ /^[\w\-\s\.]{1,32}$/) { push(@{$errormsg}, 'Invalid FriendlyName: Please use letters, numbers, dots, dashes, underscores and or spaces and the FriendlyName requires a name that is 32 characters or less in length.'); } # # INTERFACE CONFIG PARSING # my @interfaces = IO::Interface::Simple->interfaces(); if ($cfg->get('ListenInterface')) { $CONFIG{'LISTEN_INTERFACE'} = $cfg->get('ListenInterface'); } # Get the first non lo interface else { foreach my $interface (@interfaces) { next if $interface =~ /^lo/i; next unless $interface->address(); $CONFIG{'LISTEN_INTERFACE'} = $interface; last; } } if (grep(/^$CONFIG{'LISTEN_INTERFACE'}$/, @interfaces)) { my $interface = IO::Interface::Simple->new($CONFIG{'LISTEN_INTERFACE'}); if ($cfg->get('ListenIPAddress')) { $CONFIG{'LOCAL_IPADDR'} = $cfg->get('ListenIPAddress'); if ($CONFIG{'LOCAL_IPADDR'} ne $interface->address()) { push(@{$errormsg}, 'Invalid ListenInterface: The configured ListenIPAddress is NOT located on the configured ListenInterface '.$CONFIG{'LISTEN_INTERFACE'}.'.'); } } else { $CONFIG{'LOCAL_IPADDR'} = $interface->address(); } unless (Net::IP->new($CONFIG{'LOCAL_IPADDR'})) { push(@{$errormsg}, 'Invalid ListenIPAddress: '.Net::IP::Error().'.'); } unless ($interface->is_multicast()) { push(@{$errormsg}, 'Invalid ListenInterface: Interface is NOT capable of Multicast'); } } else { push (@{$errormsg}, 'Invalid ListenInterface: The configured interface does NOT exist on your machine.'); } # # HTTP PORT PARSING # $CONFIG{'HTTP_PORT'} = int($cfg->get('HTTPPort')) if defined($cfg->get('HTTPPort')); if ($CONFIG{'HTTP_PORT'} < 0 && $CONFIG{'HTTP_PORT'} > 65535) { push(@{$errormsg}, 'Invalid HTTPPort: Please specify a valid TCP port which is > 0 and < 65536.'); } # # CHACHE CONTROL PARSING # $CONFIG{'CACHE_CONTROL'} = int($cfg->get('CacheControl')) if defined($cfg->get('CacheControl')); unless ($CONFIG{'CACHE_CONTROL'} > 60 && $CONFIG{'CACHE_CONTROL'} < 18000) { push(@{$errormsg}, 'Invalid CacheControl: Please specify the CacheControl in seconds (from 61 to 17999).'); } # # PID FILE PARSING # $CONFIG{'PIDFILE'} = $cfg->get('PIDFile') if defined($cfg->get('PIDFile')); if (defined($CONFIG{'PIDFILE'}) && $CONFIG{'PIDFILE'} =~ /^\/[\w\.\_\-\/]+\w$/) { if (-e $CONFIG{'PIDFILE'}) { push(@{$errormsg}, 'Warning PIDFile: The file named '.$CONFIG{'PIDFILE'}.' is already existing. Please change the filename or delete the file.'); } } else { push(@{$errormsg}, 'Invalid PIDFile: Please specify a valid filename (full path) for the PID file.'); } # # TMP DIRECTORY # $CONFIG{'TMP_DIR'} = $cfg->get('TempDir') if defined($cfg->get('TempDir')); unless (-d $CONFIG{'TMP_DIR'}) { push(@{$errormsg}, 'Invalid TempDir: Directory '.$CONFIG{'TMP_DIR'}.' for temporary files is NOT existing.'); } # # ALLOWED CLIENTS PARSING # if (defined($cfg->get('AllowedClients'))) { # Store a list of Net::Netmask blocks that are valid for connections foreach my $ip_subnet (split(/\s*,\s*/, $cfg->get('AllowedClients'))) { # We still need to use Net::IP as it validates that the ip/subnet is valid if (Net::IP->new($ip_subnet)) { push(@{$CONFIG{'ALLOWED_CLIENTS'}}, Net::Netmask->new($ip_subnet)); } else { push(@{$errormsg}, 'Invalid AllowedClient: '.Net::IP::Error().'.'); } } } else # AllowedClients is not defined, so take the local subnet { my $interface = IO::Interface::Simple->new($CONFIG{'LISTEN_INTERFACE'}); if (defined($interface)) { push(@{$CONFIG{'ALLOWED_CLIENTS'}}, Net::Netmask->new($CONFIG{'LOCAL_IPADDR'}.'/'.$interface->netmask())); } else { push(@{$errormsg}, 'Unable to autodetect AllowedClient configuration parameter. Please specify it in the configuration file.'); } } # # DATABASE PARSING # $CONFIG{'DB_TYPE'} = $cfg->get('DatabaseType') if defined($cfg->get('DatabaseType')); unless ($CONFIG{'DB_TYPE'} =~ /^(SQLITE3|MYSQL|PGSQL)$/) { push(@{$errormsg}, 'Invalid DatabaseType: Available options [SQLITE3|MYSQL|PGSQL]'); } if ($CONFIG{'DB_TYPE'} eq 'SQLITE3') { $CONFIG{'DB_NAME'} = $cfg->get('DatabaseName') if defined($cfg->get('DatabaseName')); if (-f $CONFIG{'DB_NAME'}) { unless (mimetype($CONFIG{'DB_NAME'}) eq 'application/octet-stream') # TODO better check if it is a valid database { push(@{$errormsg}, 'Invalid DatabaseName: Database '.$CONFIG{'DB_NAME'}.' is already existing but NOT a valid database.'); } } else { unless (-d dirname($CONFIG{'DB_NAME'})) { push(@{$errormsg}, 'Invalid DatabaseName: Directory '.dirname($CONFIG{'DB_NAME'}).' for database is NOT existing.'); } } } elsif ($CONFIG{'DB_TYPE'} =~ /^(MYSQL|PGSQL)$/) { if (defined($cfg->get('DatabaseName'))) { $CONFIG{'DB_NAME'} = $cfg->get('DatabaseName'); } else { $CONFIG{'DB_NAME'} = 'pdlna'; } $CONFIG{'DB_USER'} = $cfg->get('DatabaseUsername') if defined($cfg->get('DatabaseUsername')); $CONFIG{'DB_PASS'} = $cfg->get('DatabasePassword') if defined($cfg->get('DatabasePassword')); my $dsn = ''; $dsn = 'dbi:mysql:dbname='.$CONFIG{'DB_NAME'}.';host=localhost' if $CONFIG{'DB_TYPE'} eq 'MYSQL'; $dsn = 'dbi:Pg:dbname='.$CONFIG{'DB_NAME'}.';host=localhost' if $CONFIG{'DB_TYPE'} eq 'PGSQL'; my %settings = ( PrintError => 0, RaiseError => 0, ); my $dbh = DBI->connect($dsn, $CONFIG{'DB_USER'}, $CONFIG{'DB_PASS'}, \%settings); if (defined($dbh)) { $dbh->disconnect(); } else { push(@{$errormsg}, 'Invalid Database Configuration: Unable to connect to Database: '.$DBI::errstr); } } # # LOG FILE PARSING # $CONFIG{'LOG_FILE'} = $cfg->get('LogFile') if defined($cfg->get('LogFile')); unless ($CONFIG{'LOG_FILE'} eq 'STDERR' || $CONFIG{'LOG_FILE'} eq 'SYSLOG' || $CONFIG{'LOG_FILE'} =~ /^\/[\w\.\_\-\/]+\w$/) { push(@{$errormsg}, 'Invalid LogFile: Available options [STDERR|SYSLOG|]'); } # # LOG DATE FORMAT # $CONFIG{'DATE_FORMAT'} = $cfg->get('DateFormat') if defined($cfg->get('DateFormat')); unless ($CONFIG{'DATE_FORMAT'} =~ /^[\%mdHIMpsSoYZ\s\-\:\_\,]+$/) { push(@{$errormsg}, 'Invalid DateFormat: Valid characters are mdHIMpsSoYZ-:_,.% and spaces.'); } # # LOG FILE SIZE MAX # if ($CONFIG{'LOG_FILE'} =~ /^\/[\w\.\_\-\/]+\w$/) # if a path to a file was specified { if (defined($cfg->get('LogFileMaxSize'))) { $CONFIG{'LOG_FILE_MAX_SIZE'} = int($cfg->get('LogFileMaxSize')); unless ($CONFIG{'LOG_FILE_MAX_SIZE'} > 0 && $CONFIG{'LOG_FILE_MAX_SIZE'} < 100) { push(@{$errormsg}, 'Invalid LogFileMaxSize: Please specify LogFileMaxSize in megabytes (from 1 to 99).'); } $CONFIG{'LOG_FILE_MAX_SIZE'} = $CONFIG{'LOG_FILE_MAX_SIZE'} * 1024 * 1024; # calc megabytes value from config file to bytes } if (defined($cfg->get('LogFileRotation'))) { $CONFIG{'LOG_FILE_ROTATION_AMOUNT'} = int($cfg->get('LogFileRotation')); } } # # LOG CATEGORY # if (defined($cfg->get('LogCategory'))) { @{$CONFIG{'LOG_CATEGORY'}} = split(',', $cfg->get('LogCategory')); foreach my $category (@{$CONFIG{'LOG_CATEGORY'}}) { unless ($category =~ /^(discovery|httpdir|httpstream|library|httpgeneric|database|transcoding|soap)$/) { push(@{$errormsg}, 'Invalid LogCategory: Available options [discovery|httpdir|httpstream|library|httpgeneric|database|transcoding|soap]'); } } push(@{$CONFIG{'LOG_CATEGORY'}}, 'default'); push(@{$CONFIG{'LOG_CATEGORY'}}, 'update'); } # # LOG LEVEL PARSING # $CONFIG{'DEBUG'} = int($cfg->get('LogLevel')) if defined($cfg->get('LogLevel')); if ($CONFIG{'DEBUG'} < 0) { push(@{$errormsg}, 'Invalid LogLevel: Please specify the LogLevel with a positive integer.'); } # # BUFFER_SIZE # $CONFIG{'BUFFER_SIZE'} = int($cfg->get('BufferSize')) if defined($cfg->get('BufferSize')); # # SPECIFIC_VIEWS # $CONFIG{'SPECIFIC_VIEWS'} = eval_binary_value($cfg->get('SpecificViews')) if defined($cfg->get('SpecificViews')); # # CHECK FOR UPDATES # $CONFIG{'CHECK_UPDATES'} = eval_binary_value($cfg->get('Check4Updates')) if defined($cfg->get('Check4Updates')); # # CHECK_UPDATES_NOTIFICATION # $CONFIG{'CHECK_UPDATES_NOTIFICATION'} = eval_binary_value($cfg->get('Check4UpdatesNotification')) if defined($cfg->get('Check4UpdatesNotification')); # # ENABLE_GENERAL_STATISTICS # $CONFIG{'ENABLE_GENERAL_STATISTICS'} = eval_binary_value($cfg->get('EnableGeneralStatistics')) if defined($cfg->get('EnableGeneralStatistics')); # # ENABLE_DATABASE_STATISTICS # $CONFIG{'ENABLE_DATABASE_STATISTICS'} = eval_binary_value($cfg->get('EnableDBStatistics')) if defined($cfg->get('EnableDBStatistics')); # # RESCAN_MEDIA # if ($cfg->get('RescanMediaInterval')) { my %values = ( 'never' => 0, 'hourly' => 3600, 'halfdaily' => '43200', 'daily' => 86400, ); if (defined($values{$cfg->get('RescanMediaInterval')})) { $CONFIG{'RESCAN_MEDIA'} = $values{$cfg->get('RescanMediaInterval')}; } else { push(@{$errormsg}, 'Invalid RescanMediaInterval: Available options ['.join('|', keys %values).']'); } } # # EnableImageThumbnails # $CONFIG{'IMAGE_THUMBNAILS'} = eval_binary_value($cfg->get('EnableImageThumbnails')) if defined($cfg->get('EnableImageThumbnails')); # # EnableVideoThumbnails # $CONFIG{'VIDEO_THUMBNAILS'} = eval_binary_value($cfg->get('EnableVideoThumbnails')) if defined($cfg->get('EnableVideoThumbnails')); # # LowResourceMode # $CONFIG{'LOW_RESOURCE_MODE'} = eval_binary_value($cfg->get('LowResourceMode')) if defined($cfg->get('LowResourceMode')); # # FFmpegBinaryPath # $CONFIG{'FFMPEG_BIN'} = $cfg->get('FFmpegBinaryPath') if defined($cfg->get('FFmpegBinaryPath')); my $ffmpeg_error_message = undef; if (-x $CONFIG{'FFMPEG_BIN'}) { unless (PDLNA::FFmpeg::get_ffmpeg_codecs($CONFIG{'FFMPEG_BIN'}, \$CONFIG{'FFMPEG_VERSION'}, $CONFIG{'AUDIO_CODECS_DECODE'}, $CONFIG{'AUDIO_CODECS_ENCODE'}, $CONFIG{'VIDEO_CODECS_DECODE'}, $CONFIG{'VIDEO_CODECS_ENCODE'})) { $ffmpeg_error_message = 'Invalid FFmpeg Binary: Unable to detect FFmpeg installation.'; } unless (PDLNA::FFmpeg::get_ffmpeg_formats($CONFIG{'FFMPEG_BIN'}, $CONFIG{'FORMATS_DECODE'}, $CONFIG{'FORMATS_ENCODE'})) { $ffmpeg_error_message = 'Invalid FFmpeg Binary: Unable to detect FFmpeg installation.'; } } else { $ffmpeg_error_message = 'Invalid path for FFmpeg Binary: Please specify the correct path or install FFmpeg.'; } # a disabled LOW_RESOURCE_MODE requires FFmpeg if (defined($ffmpeg_error_message) && $CONFIG{'LOW_RESOURCE_MODE'} == 0) { push(@{$errormsg}, 'A disabled LowResourceMode requires a valid FFmpeg installation.'); push(@{$errormsg}, $ffmpeg_error_message); } # VIDEO_THUMBNAILS requires FFmpeg if (defined($ffmpeg_error_message) && $CONFIG{'VIDEO_THUMBNAILS'} == 1) { push(@{$errormsg}, 'EnableVideoThumbnails requires a valid FFmpeg installation.'); push(@{$errormsg}, $ffmpeg_error_message); } # # UUID # # some of the marked code lines are taken from UUID::Tiny perl module, # which is not working # IMPORTANT NOTE: NOT compliant to RFC 4122 my $mac = undef; $CONFIG{'UUID'} = $cfg->get('UUID') if defined($cfg->get('UUID')); if ($CONFIG{'UUID'} eq 'Version3') { my $md5 = Digest::MD5->new; $md5->add($CONFIG{'HOSTNAME'}); $CONFIG{'UUID'} = substr($md5->digest(), 0, 16); $CONFIG{'UUID'} = join '-', map { unpack 'H*', $_ } map { substr $CONFIG{'UUID'}, 0, $_, '' } ( 4, 2, 2, 2, 6 ); # taken from UUID::Tiny perl module } elsif ($CONFIG{'UUID'} eq 'Version4' || $CONFIG{'UUID'} eq 'Version4MAC') { if ($CONFIG{'UUID'} eq 'Version4MAC') # determine the MAC address of our listening interfae { my $interface = IO::Interface::Simple->new($CONFIG{'LISTEN_INTERFACE'}); $mac = lc($interface->hwaddr()); } my @chars = qw(a b c d e f 0 1 2 3 4 5 6 7 8 9); $CONFIG{'UUID'} = ''; while (length($CONFIG{'UUID'}) < 36) { $CONFIG{'UUID'} .= $chars[int(rand(@chars))]; $CONFIG{'UUID'} .= '-' if length($CONFIG{'UUID'}) =~ /^(8|13|18|23)$/; } if (defined($mac)) { $mac =~ s/://g; $CONFIG{'UUID'} = substr($CONFIG{'UUID'}, 0, 24).$mac; } } elsif ($CONFIG{'UUID'} eq 'Version5') { my $sha = Digest::SHA->new(); $sha->add($CONFIG{'HOSTNAME'}); $CONFIG{'UUID'} = substr($sha->digest(), 0, 16); $CONFIG{'UUID'} = join '-', map { unpack 'H*', $_ } map { substr $CONFIG{'UUID'}, 0, $_, '' } ( 4, 2, 2, 2, 6 ); # taken from UUID::Tiny perl module } elsif ($CONFIG{'UUID'} =~ /^[0-9a-f]{8}\-[0-9a-f]{4}\-[0-9a-f]{4}\-[0-9a-f]{4}\-[0-9a-f]{12}$/i) { } else { push(@{$errormsg}, 'Invalid type for UUID: Available options [Version3|Version4|Version4MAC|Version5|]'); } $CONFIG{'UUID'} = 'uuid:'.$CONFIG{'UUID'}; # # MEDIA DIRECTORY PARSING # foreach my $directory_block ($cfg->get('Directory')) { my $block = $cfg->block(Directory => $directory_block->[1]); if (!-d $directory_block->[1]) { push(@{$errormsg}, 'Invalid Directory \''.$directory_block->[1].'\': Not a directory.'); } unless (defined($block->get('MediaType')) && $block->get('MediaType') =~ /^(audio|video|image|all)$/) { push(@{$errormsg}, 'Invalid Directory \''.$directory_block->[1].'\': Invalid MediaType.'); } my $recursion = 'yes'; if (defined($block->get('Recursion'))) { if ($block->get('Recursion') !~ /^(no|yes)$/) { push(@{$errormsg}, 'Invalid Directory: \''.$directory_block->[1].'\': Invalid Recursion value.'); } else { $recursion = $block->get('Recursion'); } } my @exclude_dirs = (); if (defined($block->get('ExcludeDirs'))) { @exclude_dirs = split(',', $block->get('ExcludeDirs')); } my @exclude_items = (); if (defined($block->get('ExcludeItems'))) { @exclude_items = split(',', $block->get('ExcludeItems')); } my $allow_playlists = eval_binary_value($block->get('AllowPlaylists')) if defined($block->get('AllowPlaylists')); push(@{$CONFIG{'DIRECTORIES'}}, { 'path' => PDLNA::Utils::delete_trailing_slash($directory_block->[1]), #'path' => $directory_block->[1], 'type' => $block->get('MediaType'), 'recursion' => $recursion, 'exclude_dirs' => \@exclude_dirs, 'exclude_items' => \@exclude_items, 'allow_playlists' => $allow_playlists, } ); } # # EXTERNAL SOURCES PARSING # if ($CONFIG{'LOW_RESOURCE_MODE'} == 0) # ignore External configured media when LowResourceMode is enabled { foreach my $external_block ($cfg->get('External')) { my $block = $cfg->block(External => $external_block->[1]); my %external = ( 'name' => $external_block->[1], 'type' => '', ); if (defined($block->get('StreamingURL'))) { $external{'streamurl'} = $block->get('StreamingURL'); unless (PDLNA::Media::is_supported_stream($external{'streamurl'})) { push(@{$errormsg}, 'Invalid External \''.$external_block->[1].'\': Not a valid streaming URL.'); } } elsif (defined($block->get('Executable'))) { if (-x $block->get('Executable')) { $external{'command'} = $block->get('Executable'); } else { push(@{$errormsg}, 'Invalid External \''.$external_block->[1].'\': Script is NOT executable.'); } if (defined($block->get('MediaType')) && $block->get('MediaType') =~ /^(audio|video)$/) { $external{'type'} = $block->get('MediaType'); } else { push(@{$errormsg}, 'Invalid External \''.$external_block->[1].'\': Invalid MediaType.'); } } else { push(@{$errormsg}, 'Invalid External \''.$external_block->[1].'\': Please define Executable or StreamingURL.'); } push(@{$CONFIG{'EXTERNALS'}}, \%external); } } # # TRANSCODING PROFILES # if ($CONFIG{'LOW_RESOURCE_MODE'} == 0) # ignore Transcoding when LowResourceMode is enabled { foreach my $transcode_block ($cfg->get('Transcode')) { if (defined($ffmpeg_error_message)) { push(@{$errormsg}, 'Transcoding requires a valid FFmpeg installation.'); push(@{$errormsg}, $ffmpeg_error_message); last; } my $block = $cfg->block(Transcode => $transcode_block->[1]); my %transcode = ( 'Name' => $transcode_block->[1], ); my $transcode_error_msg = 'Invalid Transcoding Profile \''.$transcode_block->[1].'\': '; if (defined($block->get('MediaType')) && $block->get('MediaType') =~ /^(audio)$/) { $transcode{'MediaType'} = $block->get('MediaType'); } else { push(@{$errormsg}, $transcode_error_msg.'Invalid MediaType.'); } my @types = ('AudioCodec'); foreach my $type (@types) { foreach my $direction ('In', 'Out') { # since $block->get returns 1 if keyword is defined unless (defined($block->get($type.$direction)) && $block->get($type.$direction) ne '1') { push(@{$errormsg}, $transcode_error_msg.$type.$direction.' is NOT defined.'); next; } if ($type eq 'AudioCodec') { # # CHECK IF FFMPEG SUPPORTS THE CHOSEN CODECS # my $ffmpeg_codec = undef; $ffmpeg_codec = PDLNA::FFmpeg::is_supported_audio_decode_codec(lc($block->get($type.$direction))) if $direction eq 'In'; $ffmpeg_codec = PDLNA::FFmpeg::is_supported_audio_encode_codec(lc($block->get($type.$direction))) if $direction eq 'Out'; if (defined($ffmpeg_codec)) { my $tmp_string = 'AUDIO_CODECS_DECODE'; $tmp_string = 'AUDIO_CODECS_ENCODE' if $direction eq 'Out'; if (grep/^$ffmpeg_codec$/, @{$CONFIG{$tmp_string}}) { $transcode{$type.$direction} = lc($block->get($type.$direction)); } else { my $tmp_msg = $transcode_error_msg.$type.$direction.' '.$block->get($type.$direction).' '; $tmp_msg .= 'for transcoding is NOT supported by your FFmpeg installation'; push(@{$errormsg}, $tmp_msg); } } else { my $tmp_msg = $transcode_error_msg.$block->get($type.$direction); $tmp_msg .= ' is NOT a supported '.$type.' for '.$type.$direction.' yet.'; push(@{$errormsg}, $tmp_msg); } # # CHECK IF FFMPEG SUPPORTS THE FORMATS # my $format = undef; $format = PDLNA::FFmpeg::get_decode_format_by_audio_codec(lc($block->get($type.$direction))) if $direction eq 'In'; $format = PDLNA::FFmpeg::get_encode_format_by_audio_codec(lc($block->get($type.$direction))) if $direction eq 'Out'; if (defined($format)) { my $tmp_string = 'FORMATS_DECODE'; $tmp_string = 'FORMATS_ENCODE' if $direction eq 'Out'; unless (grep(/^$format$/, @{$CONFIG{$tmp_string}})) { my $tmp_msg = $transcode_error_msg; $tmp_msg .= 'Decode' if $direction eq 'In'; $tmp_msg .= 'Encode' if $direction eq 'Out'; $tmp_msg .= 'Format '.$format.' for transcoding of '; $tmp_msg .= $block->get($type.$direction).' is NOT supported by your FFmpeg installation'; push(@{$errormsg}, $tmp_msg); } } else { my $tmp_msg = $transcode_error_msg; $tmp_msg .= 'Decode' if $direction eq 'In'; $tmp_msg .= 'Encode' if $direction eq 'Out'; $tmp_msg .= 'Format of '.$type.$direction.' is NOT supported yet.'; push(@{$errormsg}, $tmp_msg); } } } } my @clients = (); if (defined($block->get('ClientIPs')) && $block->get('ClientIPs') ne '1') { foreach my $ip_subnet (split(/\s*,\s*/, $block->get('ClientIPs'))) { # We still need to use Net::IP as it validates that the ip/subnet is valid if (Net::IP->new($ip_subnet)) { push(@clients, Net::Netmask->new($ip_subnet)); } else { push(@{$errormsg}, 'Invalid Transcoding Profile \''.$transcode_block->[1].'\': '.Net::IP::Error().'.'); } } } else { push(@{$errormsg}, 'Invalid Transcoding Profile \''.$transcode_block->[1].'\': Please configure ClientIPs.'); } $transcode{'ClientIPs'} = \@clients; push(@{$CONFIG{'TRANSCODING_PROFILES'}}, \%transcode); } } return 1 if (scalar(@{$errormsg}) == 0); return 0; } 1; pDLNA/usr/lib/perl5/PDLNA/FFmpeg.pm0000700000175000017500000003044013366114774015706 0ustar geumageumapackage PDLNA::FFmpeg; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use PDLNA::Config; use PDLNA::Media; use PDLNA::Log; my $FFMPEG_REGEX_STRING = '^ffmpeg\s+version\s+(.+),{0,1}\scopyright'; # this represents the beatuiful codec names and their internal (in the db) possible values (from FFmpeg) my %AUDIO_CODECS = ( 'aac' => [ 'mpeg4aac', 'aac', ], 'ac3' => [ 'ac3', ], 'flac' => [ 'flac', ], 'mp3' => [ 'mp3', ], 'vorbis' => [ 'vorbis', ], 'wav' => [ 'pcm_s16le', ], 'wmav1' => [ 'wmav1', ], 'wmav2' => [ 'wmav2', ], ); # this represents the beatuiful codec names and their internal (in the db) possible container names (from FFmpeg) my %AUDIO_CONTAINERS = ( 'aac' => 'mov', 'ac3' => 'ac3', 'flac' => 'flac', 'mp3' => 'mp3', 'vorbis' => 'ogg', 'wav' => 'wav', 'wmav1' => 'asf', 'wmav2' => 'asf', ); # this represents the beatuiful codec names and their FFmpeg decoder formats my %FFMPEG_DECODE_FORMATS = ( 'aac' => 'aac', 'ac3' => 'ac3', 'flac' => 'flac', 'mp3' => 'mp3', 'vorbis' => 'ogg', 'wav' => 'wav', 'wmav1' => 'asf', 'wmav2' => 'asf', ); # this represents the beatuiful codec names and their FFmpeg encoder formats my %FFMPEG_ENCODE_FORMATS = ( 'aac' => 'm4v', 'ac3' => 'ac3', 'flac' => 'flac', 'mp3' => 'mp3', 'vorbis' => 'ogg', 'wav' => 'wav', 'wmav1' => 'asf', 'wmav2' => 'asf', ); # this represents the beautiful codec names and their FFmpeg decode codecs my %FFMPEG_AUDIO_DECODE_CODECS = ( 'aac' => 'aac', 'ac3' => 'ac3', 'flac' => 'flac', 'mp3' => 'mp3', 'vorbis' => 'vorbis', 'wav' => 'pcm_s16le', 'wmav1' => 'wmav1', 'wmav2' => 'wmav2', ); # this represents the beautiful codec names and their FFmpeg encode codecs my %FFMPEG_AUDIO_ENCODE_CODECS = ( 'aac' => 'libfaac', 'ac3' => 'ac3', 'flac' => 'flac', 'mp3' => 'libmp3lame', 'vorbis' => 'libvorbis', 'wav' => 'pcm_s16le', 'wmav1' => 'wmav1', 'wmav2' => 'wmav2', ); # additional parameters for FFmpeg my %FFMPEG_AUDIO_ENCODE_PARAMS = ( 'aac' => [], 'ac3' => [], 'flac' => [], 'mp3' => [], 'vorbis' => [], 'wav' => [], 'wmav1' => [ '-ab 32k', ], 'wmav2' => [ '-ab 32k', ], ); # # # sub is_supported_audio_decode_codec { my $codec = shift; return $FFMPEG_AUDIO_DECODE_CODECS{$codec} if defined($FFMPEG_AUDIO_DECODE_CODECS{$codec}); return undef; } sub is_supported_audio_encode_codec { my $codec = shift; return $FFMPEG_AUDIO_ENCODE_CODECS{$codec} if defined($FFMPEG_AUDIO_ENCODE_CODECS{$codec}); return undef; } sub is_supported_decode_format { my $format = shift; return $FFMPEG_DECODE_FORMATS{$format} if defined($FFMPEG_DECODE_FORMATS{$format}); return undef; } sub is_supported_encode_format { my $format = shift; return $FFMPEG_ENCODE_FORMATS{$format} if defined($FFMPEG_ENCODE_FORMATS{$format}); return undef; } # # # sub get_beautiful_audio_decode_codec { my $codec = shift; foreach my $beautiful (keys %FFMPEG_AUDIO_DECODE_CODECS) { return $beautiful if $FFMPEG_AUDIO_DECODE_CODECS{$beautiful} eq $codec; } return undef; } sub get_beautiful_audio_encode_codec { my $codec = shift; foreach my $beautiful (keys %FFMPEG_AUDIO_ENCODE_CODECS) { return $beautiful if $FFMPEG_AUDIO_ENCODE_CODECS{$beautiful} eq $codec; } return undef; } sub get_beautiful_decode_format { my $format = shift; foreach my $beautiful (keys %FFMPEG_DECODE_FORMATS) { return $beautiful if $FFMPEG_DECODE_FORMATS{$beautiful} eq $format; } return undef; } sub get_beautiful_encode_format { my $format = shift; foreach my $beautiful (keys %FFMPEG_ENCODE_FORMATS) { return $beautiful if $FFMPEG_ENCODE_FORMATS{$beautiful} eq $format; } return undef; } # # # sub get_decode_format_by_audio_codec { my $codec = shift; return $FFMPEG_DECODE_FORMATS{$codec} if defined($FFMPEG_DECODE_FORMATS{$codec}); return undef; } sub get_encode_format_by_audio_codec { my $codec = shift; return $FFMPEG_ENCODE_FORMATS{$codec} if defined($FFMPEG_ENCODE_FORMATS{$codec}); return undef; } # # # sub shall_we_transcode { my $media_data = shift; my $client_data = shift; if ($CONFIG{'LOW_RESOURCE_MODE'} == 1 || $$media_data{'external'} != 0 || !defined($$media_data{'container'})) { return 0; } PDLNA::Log::log('Looking for a matching Transcoding Profile for Container: '.$$media_data{'container'}.', AudioCodec: '.$$media_data{'audio_codec'}.'.', 2, 'transcoding'); foreach my $profile (@{$CONFIG{'TRANSCODING_PROFILES'}}) { next if $$media_data{'media_type'} ne $profile->{'MediaType'}; my $matched_profile = 0; if ($$media_data{'media_type'} eq 'audio') { if (grep(/^$$media_data{'audio_codec'}$/, @{$AUDIO_CODECS{$profile->{'AudioCodecIn'}}})) { $matched_profile = 1; } } elsif ($$media_data{'media_type'} eq 'video') { next; } else { next; } next if $matched_profile == 0; my $matched_ip = 0; foreach my $ip (@{$$profile{'ClientIPs'}}) { $matched_ip++ if $ip->match($$client_data{'ip'}); } next if $matched_ip == 0; if ($$media_data{'media_type'} eq 'audio') { PDLNA::Log::log('Found a matching Transcoding Profile with Name: '.$profile->{'Name'}.'.', 2, 'transcoding'); $$media_data{'audio_codec'} = $AUDIO_CODECS{$profile->{'AudioCodecOut'}}->[0]; $$media_data{'container'} = $AUDIO_CONTAINERS{$profile->{'AudioCodecOut'}}; $$media_data{'file_extension'} = PDLNA::Media::details($$media_data{'container'}, undef, $$media_data{'audio_codec'}, 'FileExtension'); $$media_data{'mime_type'} = PDLNA::Media::details($$media_data{'container'}, undef, $$media_data{'audio_codec'}, 'MimeType'); PDLNA::Log::log("$$media_data{'container'}, $$media_data{'audio_codec'}, $$media_data{'file_extension'}, $$media_data{'mime_type'}", 3, 'transcoding'); $$media_data{'command'} = get_transcode_command($media_data, $profile->{'AudioCodecOut'}); return 1; } elsif ($$media_data{'media_type'} eq 'video') { } } return 0; } sub get_ffmpeg_stream_command { my $media_data = shift; my $command = $CONFIG{'FFMPEG_BIN'}.' -i "'.$$media_data{'fullname'}.'"'; $command .= ' -vcodec copy' if $$media_data{'media_type'} eq 'video'; $command .= ' -acodec copy'; $command .= ' -f '.$$media_data{'container'}; $command .= ' pipe:'; $command .= ' 2>/dev/null'; return $command; } sub get_transcode_command { my $media_data = shift; my $audio_codec = shift; my $command = $CONFIG{'FFMPEG_BIN'}.' -i "'.$$media_data{'fullname'}.'"'; $command .= ' -acodec '.$FFMPEG_AUDIO_ENCODE_CODECS{$audio_codec}.' '; if (scalar @{$FFMPEG_AUDIO_ENCODE_PARAMS{$audio_codec}} > 0) { $command .= join(' ', @{$FFMPEG_AUDIO_ENCODE_PARAMS{$audio_codec}}); } $command .= ' -f '.$FFMPEG_ENCODE_FORMATS{$audio_codec}; $command .= ' pipe: 2>/dev/null'; PDLNA::Log::log('Command for Transcoding Profile: '.$command.'.', 3, 'transcoding'); return $command; } sub get_ffmpeg_command { my $media_data = shift; my $command = $CONFIG{'FFMPEG_BIN'}.' -i "'.$$media_data{'fullname'}.'"'; $command .= ' -acodec copy'; $command .= ' -f '.$AUDIO_CONTAINERS{$$media_data{'audio_codec'}}; $command .= ' pipe: 2>/dev/null'; PDLNA::Log::log('Command for streaming: '.$command.'.', 3, 'transcoding'); return $command; } # # parse FFmpeg capabilities # sub get_ffmpeg_formats { my $ffmpeg_bin = shift; my $decode = shift; my $encode = shift; open(CMD, $CONFIG{'FFMPEG_BIN'}.' -formats 2>&1 |'); my @output = ; close(CMD); unless ($output[0] =~ /$FFMPEG_REGEX_STRING/i) { return 0; } foreach my $line (@output) { if ($line =~ /\s+([DE\s]{2})\s([a-z0-9\_]+)\s+/) { my $support = $1; my $codec = $2; next if !defined($support); next if !defined($codec); if (substr($support, 0, 1) eq 'D') { push(@{$decode}, $codec); } if (substr($support, 1, 1) eq 'E') { push(@{$encode}, $codec); } } } return 1; } sub get_ffmpeg_codecs { my $ffmpeg_bin = shift; my $ffmpeg_ver = shift; my $audio_decode = shift; my $audio_encode = shift; my $video_decode = shift; my $video_encode = shift; my $exitcode = system($CONFIG{'FFMPEG_BIN'}.' -codecs > /dev/null 2>&1'); # FIX ME for WINDOWS if (defined($exitcode) && $exitcode == 0) { open(CMD, $CONFIG{'FFMPEG_BIN'}.' -codecs 2>&1 |'); } else { open(CMD, $CONFIG{'FFMPEG_BIN'}.' -formats 2>&1 |'); } my @output = ; close(CMD); if ($output[0] =~ /$FFMPEG_REGEX_STRING/i) { $$ffmpeg_ver = $1; } else { return 0; } foreach my $line (@output) { if ($line =~ /\s+([A-Z\s]{6})\s([a-z0-9\_]+)\s+/) { my $support = $1; my $codec = $2; next if !defined($support); next if !defined($codec); if (substr($support, 2, 1) eq 'A') # audio codecs { # $codec = PDLNA::Media::audio_codec_by_beautiful_name($codec); # next unless defined($codec); if (substr($support, 0, 1) eq 'D') { push(@{$audio_decode}, $codec); } if (substr($support, 1, 1) eq 'E') { push(@{$audio_encode}, $codec); } } elsif (substr($support, 2, 1) eq 'V') # video codecs { # TODO transcoding profiles for videos } } } return 1; } # # use FFmpeg to determine media (audio ir video) details (codecs, ...) # sub get_media_info { my $file = shift; my $info = shift; $$info{VIDEO_CODEC} = ''; $$info{AUDIO_CODEC} = ''; $$info{CONTAINER} = ''; $$info{DURATION} = 0; $$info{HZ} = 0; $$info{BITRATE} = 0; $$info{WIDTH} = 0; $$info{HEIGHT} = 0; open(FFMPEG, $CONFIG{'FFMPEG_BIN'}.' -i "'.$file.'" 2>&1 |') || PDLNA::Log::fatal('Unable to open FFmpeg :'.$!); while () { if ($_ =~ /Duration:\s+(\d\d):(\d\d):(\d\d).(\d+)\,/) { $$info{DURATION} = 3600*$1+60*$2+$3; # ignore miliseconds } elsif ($_ =~ /Stream\s+.+:\s+(Video|Audio):\s+(.*)/) { my $type = $1; my @information = split(',', $2); $information[0] =~ s/(\s+\(.*\))$//; # delete information in brackets if ($type eq 'Video') { $$info{VIDEO_CODEC} = $information[0]; foreach my $element (@information) { if ($element =~ /(\d+)x(\d+)/) { $$info{WIDTH} = $1; $$info{HEIGHT} = $2; } } } elsif ($type eq 'Audio') { $$info{AUDIO_CODEC} = $information[0]; foreach my $element (@information) { if ($element =~ /(\d+)\s+Hz/) { $$info{HZ} = $1; } elsif ($element =~ /(\d+)\s+kb\/s/) { $$info{BITRATE} = $1*1000; } } } } elsif ($_ =~ /Input\s+.+,\s+([\w\d,]+),\s+from/) { $$info{CONTAINER} = (split(',', $1))[0]; # only take the first container (even if it is a comma seperated list) } } close(CMD); if (defined($$info{CONTAINER}) && (defined($$info{VIDEO_CODEC}) || defined($$info{AUDIO_CODEC}))) { $$info{MIME_TYPE} = PDLNA::Media::details($$info{CONTAINER}, $$info{VIDEO_CODEC}, $$info{AUDIO_CODEC}, 'MimeType'); $$info{TYPE} = PDLNA::Media::details($$info{CONTAINER}, $$info{VIDEO_CODEC}, $$info{AUDIO_CODEC}, 'MediaType'); $$info{FILE_EXTENSION} = PDLNA::Media::details($$info{CONTAINER}, $$info{VIDEO_CODEC}, $$info{AUDIO_CODEC}, 'FileExtension'); if (defined($$info{MIME_TYPE}) && defined($$info{TYPE}) && defined($$info{FILE_EXTENSION})) { PDLNA::Log::log('PDLNA::Media::details() returned for '.$file.": $$info{MIME_TYPE}, $$info{TYPE}, $$info{FILE_EXTENSION}", 3, 'library'); } else { $$info{CONTAINER} = '' unless $$info{CONTAINER}; $$info{VIDEO_CODEC} = '' unless $$info{VIDEO_CODEC}; $$info{AUDIO_CODEC} = '' unless $$info{AUDIO_CODEC}; PDLNA::Log::log('ERROR: PDLNA::Media::details() was unable to determine details for '.$file.': '.join(', ', ($$info{CONTAINER}, $$info{VIDEO_CODEC}, $$info{AUDIO_CODEC})), 0, 'library'); } } else { PDLNA::Log::log('ERROR: FFmpeg was unable to determine codec and/or container information for '.$file, 0, 'library'); } return 1; } 1; pDLNA/usr/lib/perl5/PDLNA/HTTPServer.pm0000700000175000017500000017406613366242611016515 0ustar geumageumapackage PDLNA::HTTPServer; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Fcntl; use Data::Dumper; use Date::Format; use GD; use IO::Select; use Net::Netmask; use Socket; use threads; use threads::shared; use XML::Simple; require bytes; no bytes; use PDLNA::Config; use PDLNA::ContentLibrary; use PDLNA::Database; use PDLNA::Devices; use PDLNA::FFmpeg; use PDLNA::HTTPXML; use PDLNA::Log; use PDLNA::SpecificViews; use PDLNA::WebUI; sub start_webserver { PDLNA::Log::log('Starting HTTP Server listening on '.$CONFIG{'LOCAL_IPADDR'}.':'.$CONFIG{'HTTP_PORT'}.'.', 0, 'default'); # got inspired by: http://www.adp-gmbh.ch/perl/webserver/ local *S; socket(S, PF_INET, SOCK_STREAM, getprotobyname('tcp')) || die "Can't open HTTPServer socket: $!\n"; setsockopt(S, SOL_SOCKET, SO_REUSEADDR, 1); my $server_ip = inet_aton($CONFIG{'LOCAL_IPADDR'}); bind(S, sockaddr_in($CONFIG{'HTTP_PORT'}, $server_ip)); listen(S, 5) || die "Can't listen to HTTPServer socket: $!\n"; my $ss = IO::Select->new(); $ss->add(*S); while(1) { my @connections_pending = $ss->can_read(60); foreach my $connection (@connections_pending) { my $FH; my $remote = accept($FH, $connection); my ($peer_src_port, $peer_addr) = sockaddr_in($remote); my $peer_ip_addr = inet_ntoa($peer_addr); my $thread = threads->create(\&handle_connection, $FH, $peer_ip_addr, $peer_src_port); $thread->detach(); } } } sub handle_connection { my $FH = shift; my $peer_ip_addr = shift; my $peer_src_port = shift; my $response = undef; PDLNA::Log::log('Incoming HTTP connection from '.$peer_ip_addr.':'.$peer_src_port.'.', 3, 'httpgeneric'); # Check if the peer is one of our allowed clients my $client_allowed = 0; foreach my $block (@{$CONFIG{'ALLOWED_CLIENTS'}}) { $client_allowed++ if $block->match($peer_ip_addr); } unless ($client_allowed) { PDLNA::Log::log('Received HTTP request from NOT allowed client IP '.$peer_ip_addr.'.', 2, 'httpgeneric'); $response = http_header({ 'statuscode' => 403, 'content_type' => 'text/plain', }); print $FH $response; close($FH); return 0; } # # PARSING HTTP REQUEST # binmode($FH); my %CGI = (); my %ENV = (); my $post_xml = undef; my $request_line = <$FH>; my $first_line = ''; while (defined($request_line) && $request_line ne "\r\n") { next unless $request_line; $request_line =~ s/\r\n//g; chomp($request_line); if (!$first_line) { $first_line = $request_line; my @parts = split(' ', $first_line); close $FH if @parts != 3; $ENV{'METHOD'} = $parts[0]; $ENV{'OBJECT'} = $parts[1]; $ENV{'HTTP_VERSION'} = $parts[2]; } else { my ($name, $value) = split(':', $request_line, 2); $name = uc($name); $value =~ s/^\s//g; $CGI{$name} = $value; } $request_line = <$FH>; } if (!defined($ENV{'METHOD'}) || !defined($ENV{'OBJECT'})) { PDLNA::Log::log('ERROR: Unable to parse HTTP request from '.$peer_ip_addr.':'.$peer_src_port.'.', 0, 'httpstream'); $response = http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); print $FH $response; close($FH); return 0; } my $debug_string = ''; foreach my $key (keys %CGI) { $debug_string .= "\n\t".$key.' -> '.$CGI{$key}; } PDLNA::Log::log($ENV{'METHOD'}.' '.$ENV{'OBJECT'}.' from '.$peer_ip_addr.':'.$peer_src_port.':'.$debug_string, 3, 'httpgeneric'); # # Reading POSTDATA, PARSING XML # if ($ENV{'METHOD'} eq "POST") { if (defined($CGI{'CONTENT-LENGTH'}) && length($CGI{'CONTENT-LENGTH'}) > 0) { PDLNA::Log::log('Reading '.$CGI{'CONTENT-LENGTH'}.' bytes from request for POSTDATA.', 2, 'httpgeneric'); read($FH, $CGI{'POSTDATA'}, $CGI{'CONTENT-LENGTH'}); } else { PDLNA::Log::log('Looking for \r\n in request for POSTDATA.', 2, 'httpgeneric'); $CGI{'POSTDATA'} = <$FH>; } PDLNA::Log::log('POSTDATA: '.$CGI{'POSTDATA'}, 3, 'httpgeneric'); my $xmlsimple = XML::Simple->new(); eval { $post_xml = $xmlsimple->XMLin($CGI{'POSTDATA'}) }; if ($@) { PDLNA::Log::log('ERROR: Unable to convert POSTDATA with XML::Simple for '.$peer_ip_addr.':'.$peer_src_port.': '.$@, 0, 'httpdir'); } else { PDLNA::Log::log('Finished converting POSTDATA with XML::Simple for '.$peer_ip_addr.':'.$peer_src_port.'.', 3, 'httpdir'); } } # adding device and/or request to Devices tables my $dbh = PDLNA::Database::connect(); PDLNA::Devices::add_device( $dbh, { 'ip' => $peer_ip_addr, 'http_useragent' => $CGI{'USER-AGENT'}, }, ); my $model_name = PDLNA::Devices::get_modelname_by_devicetype($dbh, $peer_ip_addr, 'urn:schemas-upnp-org:device:MediaRenderer:1'); PDLNA::Log::log('ModelName for '.$peer_ip_addr.' is '.$model_name.'.', 2, 'httpgeneric'); PDLNA::Database::disconnect($dbh); # # HANDLING DIFFERENT KIND OF REQUESTS # if ($ENV{'OBJECT'} eq '/ServerDesc.xml') # delivering ServerDescription XML { my $xml = PDLNA::HTTPXML::get_serverdescription($CGI{'USER-AGENT'}); my @additional_header = ( 'Content-Type: text/xml; charset=utf8', 'Content-Length: '.length($xml), ); $response = http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); $response .= $xml; } elsif ($ENV{'OBJECT'} eq '/ContentDirectory1.xml') # delivering ContentDirectory XML { my $xml = PDLNA::HTTPXML::get_contentdirectory(); my @additional_header = ( 'Content-Type: text/xml; charset=utf8', 'Content-Length: '.length($xml), ); $response = http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); $response .= $xml; } elsif ($ENV{'OBJECT'} eq '/ConnectionManager1.xml') # delivering ConnectionManager XML { my $xml = PDLNA::HTTPXML::get_connectionmanager(); my @additional_header = ( 'Content-Type: text/xml; charset=utf8', 'Content-Length: '.length($xml), ); $response = http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); $response .= $xml; } elsif ($ENV{'OBJECT'} eq '/upnp/event/ContentDirectory1' || $ENV{'OBJECT'} eq '/upnp/event/ConnectionManager1') { my $response_content = ''; $response_content = '

200 OK

' if $ENV{'METHOD'} eq 'UNSUBSCRIBE'; my @additional_header = ( 'Content-Length: '.length($response_content), 'SID: '.$CONFIG{'UUID'}, 'Timeout: Second-'.$CONFIG{'CACHE_CONTROL'}, ); $response = http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); $response .= $response_content; } elsif ($ENV{'OBJECT'} eq '/upnp/control/ContentDirectory1') # handling Directory Listings { $response = ctrl_content_directory_1($post_xml, $CGI{'SOAPACTION'}, $peer_ip_addr, $CGI{'USER-AGENT'}); } # elsif ($ENV{'OBJECT'} eq '/upnp/control/ConnectionManager1') # { # } elsif ($ENV{'OBJECT'} =~ /^\/media\/(.*)$/) # handling media streaming { stream_item($1, $ENV{'METHOD'}, \%CGI, $FH, $model_name, $peer_ip_addr, $CGI{'USER-AGENT'}); } elsif ($ENV{'OBJECT'} =~ /^\/preview\/(.*)$/) # handling media thumbnails { $response = preview_media($1); } elsif ($ENV{'OBJECT'} =~ /^\/icons\/(.*)$/) # handling pDLNA logo { $response = logo($1); } elsif ($ENV{'OBJECT'} =~ /^\/webui\/js.js$/) # deliver javascript code { my $js = PDLNA::WebUI::javascript(); my @additional_header = ( 'Content-Type: application/javascript; charset=utf8', 'Content-Length: '.length($js), ); $response = http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); $response .= $js; } elsif ($ENV{'OBJECT'} =~ /^\/webui\/css.css$/) # deliver stylesheet { my $css = PDLNA::WebUI::css(); my @additional_header = ( 'Content-Type: text/css; charset=utf8', 'Content-Length: '.length($css), ); $response = http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); $response .= $css; } elsif ($ENV{'OBJECT'} =~ /^\/webui\/graphs\/(.+)\.png$/) # handling delivering graphs { print $FH PDLNA::WebUI::graph($1); close($FH); } elsif ($ENV{'OBJECT'} =~ /^\/webui\/(.*)$/) # handling WebUI { print $FH PDLNA::WebUI::show($1); close($FH); } else # NOT supported request { PDLNA::Log::log('Request '.$ENV{'METHOD'}.' '.$ENV{'OBJECT'}.' from '.$peer_ip_addr.' NOT supported yet.', 2, 'httpgeneric'); $response = http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); } if (defined($response)) { # binmode($FH, ":utf8"); print $FH $response; close($FH); } return 1; } sub http_header { my $params = shift; my %HTTP_CODES = ( 200 => 'OK', 206 => 'Partial Content', 400 => 'Bad request', 403 => 'Forbidden', 404 => 'Not found', 406 => 'Not acceptable', 501 => 'Not implemented', ); my @response = (); push(@response, "HTTP/1.1 ".$$params{'statuscode'}." ".$HTTP_CODES{$$params{'statuscode'}}); # TODO (maybe) differ between http protocol versions push(@response, "Server: ".$CONFIG{'OS'}."/".$CONFIG{'OS_VERSION'}.", UPnP/1.0, ".$CONFIG{'PROGRAM_NAME'}."/".PDLNA::Config::print_version()); push(@response, "Content-Type: ".$params->{'content_type'}) if $params->{'content_type'}; push(@response, "Content-Length: ".$params->{'content_length'}) if $params->{'content_length'}; push(@response, "Date: ".PDLNA::Utils::http_date()); # push(@response, "Last-Modified: ".PDLNA::Utils::http_date()); if (defined($$params{'additional_header'})) { foreach my $header (@{$$params{'additional_header'}}) { push(@response, $header); } } push(@response, 'Cache-Control: no-cache'); push(@response, 'Connection: close'); PDLNA::Log::log("HTTP Response Header:\n\t".join("\n\t",@response), 3, $$params{'log'}) if defined($$params{'log'}); return join("\r\n", @response)."\r\n\r\n"; } # # # BEGINNING OF DIRECTORY CONTROLS # # sub manage_browsefilters { my $filter = shift; my $browse_flag = shift; my @browsefilters = split(',', $filter) if length($filter) > 0; @browsefilters = () if $filter eq '*'; if ($browse_flag eq 'BrowseDirectChildren') { # these filter seem to be mandatory, so we need to put them always into the HTTP response foreach my $filter ('@id', '@parentID', '@childCount', '@restricted', 'dc:title', 'upnp:class') { push(@browsefilters, $filter) unless grep(/^$filter$/, @browsefilters); } if ($filter eq '*') { push(@browsefilters, 'res@bitrate'); push(@browsefilters, 'res@duration'); } } elsif ($browse_flag eq 'BrowseMetadata') { if (grep(/^\@parentID$/, @browsefilters)) { @browsefilters = ('@id', '@parentID', '@childCount', '@restricted', 'dc:title', 'upnp:class'); } else { # these filter seem to be mandatory, so we need to put them always into the HTTP response foreach my $filter ('@id', '@childCount', '@restricted', 'dc:title', 'upnp:class') { push(@browsefilters, $filter) unless grep(/^$filter$/, @browsefilters); } } } PDLNA::Log::log('Modified Filter: '.$filter.' to: '.join(', ', @browsefilters).')', 3, 'httpdir'); return @browsefilters; } sub build_BrowseMetadata_response { my $params = shift; PDLNA::Log::log('Starting to prepare BrowseMetadata XML response for ID: '.$$params{'item_id'}, 3, 'httpdir'); my $dbh = PDLNA::Database::connect(); # # build the http response # my $response_xml = ''; $response_xml .= PDLNA::HTTPXML::get_browseresponse_header(); $response_xml .= PDLNA::HTTPXML::get_browseresponse_item( $$params{'item_id'}, $$params{'browsefilters'}, $dbh, $$params{'peer_ip_addr'}, $$params{'user_agent'}, ); $response_xml .= PDLNA::HTTPXML::get_browseresponse_footer(1, 1); PDLNA::Log::log('Done preparing BrowseMetadata XML response for ID: '.$$params{'item_id'}, 3, 'httpdir'); # # return the http response # PDLNA::Database::disconnect($dbh); return $response_xml; } sub build_BrowseDirectChildren_response { my $params = shift; PDLNA::Log::log('Starting to prepare BrowseDirectChildren XML response for ID: '.$$params{'item_id'}, 3, 'httpdir'); my $dbh = PDLNA::Database::connect(); # # get the subdirectories for the item_id requested # my @dire_elements = (); PDLNA::ContentLibrary::get_items_by_parentid( $dbh, $$params{'item_id'}, $$params{'starting_index'}, $$params{'requested_count'}, 0, \@dire_elements, ); # # get the full amount of subdirectories for the item_id requested # my $amount_directories = PDLNA::ContentLibrary::get_amount_items_by_parentid_n_itemtype($dbh, $$params{'item_id'}, 0); $$params{'requested_count'} = $$params{'requested_count'} - scalar(@dire_elements); # amount of @dire_elements is already in answer if ($$params{'starting_index'} >= $amount_directories) { $$params{'starting_index'} = $$params{'starting_index'} - $amount_directories; } # # get the files for the directory requested # my @file_elements = (); PDLNA::ContentLibrary::get_items_by_parentid( $dbh, $$params{'item_id'}, $$params{'starting_index'}, $$params{'requested_count'}, 1, \@file_elements, ); # # get the full amount of files in the directory requested # my $amount_files = PDLNA::ContentLibrary::get_amount_items_by_parentid_n_itemtype($dbh, $$params{'item_id'}, 1); # # build the http response # my $response_xml = ''; $response_xml .= PDLNA::HTTPXML::get_browseresponse_header(); foreach my $directory (@dire_elements) { $response_xml .= PDLNA::HTTPXML::get_browseresponse_container( $directory->{id}, $directory->{title}, $$params{'browsefilters'}, $dbh, ); } foreach my $file (@file_elements) { $response_xml .= PDLNA::HTTPXML::get_browseresponse_item( $file->{id}, $$params{'browsefilters'}, $dbh, $$params{'peer_ip_addr'}, $$params{'user_agent'}, ); } my $elements_in_listing = scalar(@dire_elements) + scalar(@file_elements); my $elements_in_directory = $amount_directories + $amount_files; $response_xml .= PDLNA::HTTPXML::get_browseresponse_footer($elements_in_listing, $elements_in_directory); PDLNA::Log::log('Done preparing BrowseDirectChildren XML response for ID: '.$$params{'item_id'}, 3, 'httpdir'); # # return the http response # PDLNA::Database::disconnect($dbh); return $response_xml; } sub ctrl_content_directory_1 { my $xml = shift; my $action = shift; my $peer_ip_addr = shift; my $user_agent = shift; my $response_xml = undef; PDLNA::Log::log("Function PDLNA::HTTPServer::ctrl_content_directory_1 called", 3, 'httpdir'); if ($action eq '"urn:schemas-upnp-org:service:ContentDirectory:1#Browse"') { my $object_id = PDLNA::HTTPXML::lookup_elementvalue_in_xml($xml, 'ObjectID'); my $browse_flag = PDLNA::HTTPXML::lookup_elementvalue_in_xml($xml, 'BrowseFlag'); my $starting_index = PDLNA::HTTPXML::lookup_elementvalue_in_xml($xml, 'StartingIndex') || 0; my $requested_count = PDLNA::HTTPXML::lookup_elementvalue_in_xml($xml, 'RequestedCount') || 0; my $filter = PDLNA::HTTPXML::lookup_elementvalue_in_xml($xml, 'Filter') || ''; # # sanity check - we had to find an object_id and a browse_flag # unless (defined($object_id) && defined($browse_flag)) { PDLNA::Log::log('ERROR: Unable to find ObjectID and/or BrowseFlag in XML (POSTDATA).', 0, 'httpdir'); return http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); } PDLNA::Log::log('Starting to handle ContentDirectory:1#Browse request: (ObjectID: '.$object_id.'; BrowseFlag: '.$browse_flag.'; StartingIndex: '.$starting_index.'; RequestedCount: '.$requested_count.'; Filter: '.$filter.')', 3, 'httpdir'); my @browsefilters = manage_browsefilters($filter, $browse_flag); $requested_count = 10 if $requested_count == 0; # if client asks for 0 items, we should return the 'default' amount (in our case 10) # # building the response # if ($browse_flag eq 'BrowseDirectChildren') { if ($object_id =~ /^\d+$/) { PDLNA::Log::log('Received numeric Directory Listing request for: '.$object_id.'.', 2, 'httpdir'); $response_xml = build_BrowseDirectChildren_response( { item_id => $object_id, starting_index => $starting_index, requested_count => $requested_count, browsefilters => \@browsefilters, peer_ip_addr => $peer_ip_addr, user_agent => $user_agent, }, ); } } elsif ($browse_flag eq 'BrowseMetadata') { if (grep(/^\@parentID$/, @browsefilters) && $object_id =~ /^\d+$/) { # set object_id to parent_id my $dbh = PDLNA::Database::connect(); # TODO find a more elegant solution instead of opening a DB connection for this requesest my $parent_id = PDLNA::ContentLibrary::get_parentid_by_id($dbh, $object_id); PDLNA::Database::disconnect($dbh); $response_xml = build_BrowseDirectChildren_response( { item_id => $parent_id, starting_index => $starting_index, requested_count => $requested_count, browsefilters => \@browsefilters, peer_ip_addr => $peer_ip_addr, user_agent => $user_agent, }, ); } elsif ($object_id =~ /^\d+$/) { PDLNA::Log::log('A BrowseMetadata request with NO @parentID filter has been sent for: '.$object_id.'.', 3, 'httpdir'); $response_xml = build_BrowseMetadata_response( { item_id => $object_id, starting_index => $starting_index, requested_count => $requested_count, browsefilters => \@browsefilters, peer_ip_addr => $peer_ip_addr, user_agent => $user_agent, }, ); } } else { PDLNA::Log::log('ERROR: BrowseFlag '.$browse_flag.' for ContentDirectory:1#Browse requests is NOT supported yet.', 0, 'httpdir'); return http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); } PDLNA::Log::log('Finished handling ContentDirectory:1#Browse request for ID: '.$object_id.'.', 3, 'httpdir'); # # old code is coming again # # elsif ($object_id =~ /^(\w)\_(\w)\_{0,1}(\d*)\_{0,1}(\d*)/) # { # PDLNA::Log::log('Received SpecificView Directory Listing request for: '.$object_id.'.', 2, 'httpdir'); # # my $media_type = $1; # my $group_type = $2; # my $group_id = $3; # my $item_id = $4; # # unless (PDLNA::SpecificViews::supported_request($media_type, $group_type)) # { # PDLNA::Log::log('SpecificView: '.$media_type.'_'.$group_type.' is NOT supported yet.', 2, 'httpdir'); # return http_header({ # 'statuscode' => 501, # 'content_type' => 'text/plain', # }); # } # # if (length($group_id) == 0) # { # my @group_elements = (); # PDLNA::SpecificViews::get_groups($dbh, $media_type, $group_type, $starting_index, $requested_count, \@group_elements); # my $amount_groups = PDLNA::SpecificViews::get_amount_of_groups($dbh, $media_type, $group_type); # # $response_xml .= PDLNA::HTTPXML::get_browseresponse_header(); # foreach my $group (@group_elements) # { # $response_xml .= PDLNA::HTTPXML::get_browseresponse_group_specific( # $group->{ID}, # $media_type, # $group_type, # $group->{NAME}, # \@browsefilters, # $dbh, # ); # } # $response_xml .= PDLNA::HTTPXML::get_browseresponse_footer(scalar(@group_elements), $amount_groups); # } # elsif (length($group_id) > 0 && length($item_id) == 0) # { # $group_id = PDLNA::Utils::remove_leading_char($group_id, '0'); # # my @item_elements = (); # PDLNA::SpecificViews::get_items($dbh, $media_type, $group_type, $group_id, $starting_index, $requested_count, \@item_elements); # my $amount_items = PDLNA::SpecificViews::get_amount_of_items($dbh, $media_type, $group_type, $group_id); # # $response_xml .= PDLNA::HTTPXML::get_browseresponse_header(); # foreach my $item (@item_elements) # { # $response_xml .= PDLNA::HTTPXML::get_browseresponse_item_specific( # $item->{ID}, # $media_type, # $group_type, # $group_id, # \@browsefilters, # $dbh, # $peer_ip_addr, # $user_agent, # ); # } # $response_xml .= PDLNA::HTTPXML::get_browseresponse_footer(scalar(@item_elements), $amount_items); # } # else # { # PDLNA::Log::log('ERROR: SpecificView: Unable to understand request for ObjectID '.$object_id.'.', 0, 'httpdir'); # return http_header({ # 'statuscode' => 501, # 'content_type' => 'text/plain', # }); # } # } } elsif ($action eq '"urn:schemas-upnp-org:service:ContentDirectory:1#GetSearchCapabilities"') { $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; } elsif ($action eq '"urn:schemas-upnp-org:service:ContentDirectory:1#GetSortCapabilities"') { $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; } elsif ($action eq '"urn:schemas-upnp-org:service:ContentDirectory:1#GetSystemUpdateID"') { $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= '0'; $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; } # OLD CODE # elsif ($action eq '"urn:schemas-upnp-org:service:ContentDirectory:1#X_GetObjectIDfromIndex"') # { # my $media_type = ''; # my $sort_type = ''; # if ($xml->{'s:Body'}->{'u:X_GetObjectIDfromIndex'}->{'CategoryType'} == 14) # { # $media_type = 'I'; # $sort_type = 'F'; # } # elsif ($xml->{'s:Body'}->{'u:X_GetObjectIDfromIndex'}->{'CategoryType'} == 22) # { # $media_type = 'A'; # $sort_type = 'F'; # } # elsif ($xml->{'s:Body'}->{'u:X_GetObjectIDfromIndex'}->{'CategoryType'} == 32) # { # $media_type = 'V'; # $sort_type = 'F'; # } # PDLNA::Log::log('Getting object for '.$media_type.'_'.$sort_type.'.', 2, 'httpdir'); # # my $index = $xml->{'s:Body'}->{'u:X_GetObjectIDfromIndex'}->{'Index'}; # # my $content_type_obj = $content->get_content_type($media_type, $sort_type); # my $i = 0; # my @groups = @{$content_type_obj->content_groups()}; # while ($index >= $groups[$i]->content_items_amount()) # { # $index -= $groups[$i]->content_items_amount(); # $i++; # } # my $content_item_obj = $groups[$i]->content_items()->[$index]; # # $response = http_header({ # 'statuscode' => 200, # }); # # $response .= ''; # $response .= ''; # $response .= ''; # $response .= ''.$media_type.'_'.$sort_type.'_'.$groups[$i]->beautiful_id().'_'.$content_item_obj->beautiful_id().''; # $response .= ''; # $response .= ''; # $response .= ''; # } # TODO X_GetIndexfromRID (i think it might be the question, to which item the tv should jump ... but currently i don't understand the question () elsif ($action eq '"urn:schemas-upnp-org:service:ContentDirectory:1#X_GetIndexfromRID"') { $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; $response_xml .= '0'; # we are setting it to 0 - so take the first item in the list to be active $response_xml .= ''; $response_xml .= ''; $response_xml .= ''; } # elsif ($action eq '"urn:schemas-upnp-org:service:ContentDirectory:1#X_SetBookmark"') # { # PDLNA::Log::log('Handling X_SetBookmark request.', 2, 'httpdir'); # if (defined($xml->{'s:Body'}->{'u:Browse'}->{'ObjectID'}) && defined($xml->{'s:Body'}->{'u:Browse'}->{'PosSecond'})) # { # my $device_ip_id = PDLNA::Devices::get_device_ip_id_by_device_ip($dbh, $peer_ip_addr); # if (defined($device_ip_id)) # { # my @device_bm = (); # PDLNA::Database::select_db( # $dbh, # { # 'query' => 'SELECT pos_seconds FROM device_bm WHERE item_id_ref = ? AND device_ip_ref = ?', # 'parameters' => [ $xml->{'s:Body'}->{'u:Browse'}->{'ObjectID'}, $device_ip_id, ], # }, # \@device_bm, # ); # # if (defined($device_bm[0]->{pos_seconds})) # { # PDLNA::Database::update_db( # $dbh, # { # 'query' => 'UPDATE device_bm SET pos_seconds = ? WHERE item_id_ref = ? AND device_ip_ref = ?', # 'parameters' => [ $xml->{'s:Body'}->{'u:Browse'}->{'PosSecond'}, $xml->{'s:Body'}->{'u:Browse'}->{'ObjectID'}, $device_ip_id, ], # } # ); # } # else # { # PDLNA::Database::insert_db( # $dbh, # { # 'query' => 'INSERT INTO device_bm (item_id_ref, device_ip_ref, pos_seconds) VALUES (?,?,?)', # 'parameters' => [ $xml->{'s:Body'}->{'u:Browse'}->{'ObjectID'}, $device_ip_id, $xml->{'s:Body'}->{'u:Browse'}->{'PosSecond'}, ], # } # ); # } # # $response_xml .= ''; # $response_xml .= ''; # $response_xml .= ''; # $response_xml .= ''; # $response_xml .= ''; # $response_xml .= ''; # } # else # { # PDLNA::Log::log('Unable to find matching entry in device_ip table.', 2, 'httpdir'); # return http_header({ # 'statuscode' => 501, # 'content_type' => 'text/plain', # }); # } # } # else # { # PDLNA::Log::log('Missing ObjectID or PosSecond parameter.', 2, 'httpdir'); # return http_header({ # 'statuscode' => 501, # 'content_type' => 'text/plain', # }); # } # } else { PDLNA::Log::log('ERROR: Action '.$action.' is NOT supported yet.', 0, 'httpdir'); return http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); } # # RETURN THE ANSWER # my $response = undef; if (defined($response_xml)) { $response = http_header({ 'statuscode' => 200, 'log' => 'httpdir', 'content_length' => length($response_xml), 'content_type' => 'text/xml; charset=utf8', }); $response .= $response_xml; PDLNA::Log::log('Response: '.$response, 3, 'httpdir'); } else { PDLNA::Log::log('ERROR: No Response.', 0, 'httpdir'); $response = http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); } return $response; } # # # END OF DIRECTORY CONTROLS # # # # # BEGINNING OF DELIVERING ITEMS # # # # NEW: # sub stream_item { my $item_id = shift; my $method = shift; my $CGI = shift; my $FH = shift; my $model_name = shift; # # sanity check for ID # if ($item_id =~ /^(\d+)\.(\w+)$/) { $item_id = $1; # cut off the file_extension } else { PDLNA::Log::log('ERROR: ID '.$item_id.' for streaming items is NOT supported yet.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } # # getting information from database # my $dbh = PDLNA::Database::connect(); my @item = PDLNA::ContentLibrary::get_item_by_id($dbh, $item_id, [ 'item_type', 'media_type', 'mime_type', 'fullname', 'title', 'size', 'duration' ]); my @subtitles = PDLNA::ContentLibrary::get_subtitles_by_refid($dbh, $item_id); PDLNA::Database::disconnect($dbh); # # sanity check for media item # unless (defined($item[0]->{fullname})) { PDLNA::Log::log('ERROR: Item with ID '.$item_id.' NOT found (in media library).', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } unless (-f $item[0]->{fullname}) { PDLNA::Log::log('ERROR: Item with ID '.$item_id.' NOT found (on filesystem): '.$item[0]->{fullname}.'.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } # # parse HTTP Header # my @additional_header = (); push(@additional_header, 'Content-Type: '.PDLNA::Media::get_mimetype_by_modelname($item[0]->{mime_type}, $model_name)); push(@additional_header, 'Content-Length: '.$item[0]->{size}); push(@additional_header, 'Content-Disposition: attachment; filename="'.$item[0]->{title}.'"'); push(@additional_header, 'Accept-Ranges: bytes'); my $dlna_contentfeatures = PDLNA::Media::get_dlnacontentfeatures($item[0]); unless (handle_getcontentfeatures_header($CGI, \@additional_header, $dlna_contentfeatures)) { PDLNA::Log::log('ERROR: Invalid contentFeatures.dlna.org:'.$$CGI{'GETCONTENTFEATURES.DLNA.ORG'}.'.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } unless (handle_getcaptioninfo_header($CGI, \@additional_header, $item[0]->{media_type}, \@subtitles, $dlna_contentfeatures)) { PDLNA::Log::log('ERROR: Invalid getCaptionInfo.sec:'.$$CGI{'GETCAPTIONINFO.SEC'}.'.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } unless (handle_getmediainfosec_header($CGI, \@additional_header, $item[0]->{media_type}, $item[0]->{duration}, $dlna_contentfeatures)) { PDLNA::Log::log('ERROR: Invalid getMediaInfo.sec:'.$$CGI{'GETMEDIAINFO.SEC'}.'.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } # # # if ($method eq 'HEAD') # handling HEAD requests { PDLNA::Log::log('Delivering content information (HEAD Request) for: '.$item[0]->{title}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); } elsif ($method eq 'GET') # handling GET requests { unless (handle_transfermode_header($CGI, \@additional_header)) { PDLNA::Log::log('ERROR: Invalid Transfermode:'.$$CGI{'TRANSFERMODE.DLNA.ORG'}.'.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } # # # if ($$CGI{'TRANSFERMODE.DLNA.ORG'} eq 'Streaming') # for immediate rendering of audio or video content { my $statuscode = 200; my ($lowrange, $highrange) = 0; if ( defined($$CGI{'RANGE'}) && # if RANGE is defined as HTTP header $$CGI{'RANGE'} =~ /^bytes=(\d+)-(\d*)$/ # if RANGE looks like ) { PDLNA::Log::log('Delivering content for: '.$item[0]->{fullname}.' with RANGE Request.', 1, 'httpstream'); $statuscode = 206; $lowrange = int($1); $highrange = $2 ? int($2) : 0; $highrange = $item[0]->{size}-1 if $highrange == 0; $highrange = $item[0]->{size}-1 if $highrange >= $item[0]->{size}; my $bytes_to_ship = $highrange - $lowrange + 1; $additional_header[1] = 'Content-Length: '.$bytes_to_ship; # we need to change the Content-Length push(@additional_header, 'Content-Range: bytes '.$lowrange.'-'.$highrange.'/'.$item[0]->{size}); } sysopen(ITEM, $item[0]->{fullname}, O_RDONLY); sysseek(ITEM, $lowrange, 0) if $lowrange; print $FH http_header({ 'statuscode' => $statuscode, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); my $buf = undef; while (sysread(ITEM, $buf, $CONFIG{'BUFFER_SIZE'})) { PDLNA::Log::log('Adding '.bytes::length($buf).' bytes to Streaming connection.', 3, 'httpstream'); print $FH $buf or return 1; } close(ITEM); return 1; } elsif ($$CGI{'TRANSFERMODE.DLNA.ORG'} eq 'Interactive') # for immediate rendering of images or playlist files { # Delivering interactive content as a whole print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); sysopen(FILE, $item[0]->{fullname}, O_RDONLY); print $FH ; close(FILE); return; } elsif ($$CGI{'TRANSFERMODE.DLNA.ORG'} eq 'Background') # for subtitles { # Delivering background content as a whole print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); sysopen(FILE, $item[0]->{fullname}, O_RDONLY); print $FH ; close(FILE); } } else { PDLNA::Log::log('ERROR: HTTP Method '.$method.' for streaming items is NOT supported yet.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } } # # NEW: # sub handle_transfermode_header { my $CGI = shift; my $additional_header = shift; # for clients, which are not sending the Streaming value for the transferMode.dlna.org parameter # we set it, because they seem to ignore it if (defined($$CGI{'USER-AGENT'})) { if ( $$CGI{'USER-AGENT'} =~ /^foobar2000/ || # since foobar2000 is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^vlc/i || # since vlc is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^stagefright/ || # since UPnPlay is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^gvfs/ || # since Totem Movie Player is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^\(null\)/ ) { $$CGI{'TRANSFERMODE.DLNA.ORG'} = 'Streaming'; } } if (defined($$CGI{'TRANSFERMODE.DLNA.ORG'})) { if ($$CGI{'TRANSFERMODE.DLNA.ORG'} =~ /^Streaming|Interactive|Background$/) { push(@{$additional_header}, 'transferMode.dlna.org: '.$$CGI{'TRANSFERMODE.DLNA.ORG'}); return 1; } } return 0; } # # NEW: # sub handle_getmediainfosec_header { my $CGI = shift; my $additional_header = shift; my $media_type = shift; my $seconds = shift; my $dlna_contentfeatures = shift; if (defined($$CGI{'GETMEDIAINFO.SEC'})) { if ($$CGI{'GETMEDIAINFO.SEC'} == 1) { if ($media_type eq 'video' || $media_type eq 'audio') { push(@{$additional_header}, 'MediaInfo.sec: SEC_Duration='.$seconds.'000;'); # in milliseconds } unless (grep(/^contentFeatures.dlna.org:/, @{$additional_header})) { push(@{$additional_header}, 'contentFeatures.dlna.org: '.$dlna_contentfeatures); } } else { return 0; } } return 1; } # # NEW: # sub handle_getcaptioninfo_header { my $CGI = shift; my $additional_header = shift; my $media_type = shift; my $subtitles = shift; my $dlna_contentfeatures = shift; if (defined($$CGI{'GETCAPTIONINFO.SEC'})) { if ($$CGI{'GETCAPTIONINFO.SEC'} == 1) { if ($media_type eq 'video') { foreach my $subtitle (@{$subtitles}) { if ($subtitle->{media_type} eq 'srt' && -f $subtitle->{fullname}) { my $url = 'http://'.$CONFIG{'LOCAL_IPADDR'}.':'.$CONFIG{'HTTP_PORT'}.'/media/'.$subtitle->{id}.'.srt'; push(@{$additional_header}, 'CaptionInfo.sec: '.$url); } } } unless (grep(/^contentFeatures.dlna.org:/, @{$additional_header})) { push(@{$additional_header}, 'contentFeatures.dlna.org: '.$dlna_contentfeatures); } } else { return 0; } } return 1; } # # NEW: # Streaming of content is NOT working with SAMSUNG without this response header # sub handle_getcontentfeatures_header { my $CGI = shift; my $additional_header = shift; my $dlna_contentfeatures = shift; if (defined($$CGI{'GETCONTENTFEATURES.DLNA.ORG'})) { if ($$CGI{'GETCONTENTFEATURES.DLNA.ORG'} == 1) { push(@{$additional_header}, 'contentFeatures.dlna.org: '.$dlna_contentfeatures); } else { return 0; } } return 1; } sub preview_media { my $item_id = shift; # # sanity check for ID # if ($item_id =~ /^(\d+)\.(\w+)$/) { $item_id = $1; # cut off the file_extension } else { PDLNA::Log::log('ERROR: ID '.$item_id.' for preview items is NOT supported yet.', 0, 'httpstream'); return http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } # # getting information from database # my $dbh = PDLNA::Database::connect(); my @item = PDLNA::ContentLibrary::get_item_by_id($dbh, $item_id, [ 'media_type', 'fullname' ]); PDLNA::Database::disconnect($dbh); # # sanity check for media item # unless (defined($item[0]->{fullname})) { PDLNA::Log::log('ERROR: Item with ID '.$item_id.' NOT found (in media library).', 0, 'httpstream'); return http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } unless (-f $item[0]->{fullname}) { PDLNA::Log::log('ERROR: Item with ID '.$item_id.' NOT found (on filesystem): '.$item[0]->{fullname}.'.', 0, 'httpstream'); return http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } if ($item[0]->{media_type} eq 'audio') { PDLNA::Log::log('ERROR: Delivering preview for audio item is NOT supported yet.', 0, 'httpstream'); return http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } # # # PDLNA::Log::log('Delivering preview for: '.$item[0]->{fullname}.'.', 2, 'httpstream'); my $randid = ''; my $path = $item[0]->{fullname}; if ($item[0]->{media_type} eq 'video') # we need to create the thumbnail { $randid = $CONFIG{'PROGRAM_NAME'}.'-'.PDLNA::Utils::get_randid(); mkdir($CONFIG{'TMP_DIR'}.'/'.$randid); my $thumbnail_path = $CONFIG{'TMP_DIR'}.'/'.$randid.'/thumbnail.jpg'; system($CONFIG{'FFMPEG_BIN'}.' -y -ss 20 -i "'.$path.'" -vcodec mjpeg -vframes 1 -an -f rawvideo "'.$thumbnail_path.'" > /dev/null 2>&1'); $path = $thumbnail_path; unless (-f $path) { PDLNA::Log::log('ERROR: Unable to create image for item preview.', 0, 'httpstream'); return http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } } # image scaling stuff GD::Image->trueColor(1); my $image = GD::Image->new($path); $image = newFromJpeg GD::Image($path) unless ($image); # if GD::Image->new doesn't work, try newFromJpeg unless ($image) # and if both ways did not work { PDLNA::Log::log('ERROR: Unable to create GD::Image object for item preview.', 0, 'httpstream'); return http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } my $height = $image->height / ($image->width/160); my $preview = GD::Image->new(160, $height); $preview->copyResampled($image, 0, 0, 0, 0, 160, $height, $image->width, $image->height); # remove tmp files from thumbnail generation if ($item[0]->{media_type} eq 'video') { unlink($path); rmdir("$CONFIG{'TMP_DIR'}/$randid"); # TODO Windows specific } # the response itself my $response = http_header({ 'statuscode' => 200, 'content_type' => 'image/jpeg', 'log' => 'httpstream', }); $response .= $preview->jpeg(); $response .= "\r\n"; return $response; } sub logo { my ($size, $type) = split('/', shift); $type = lc($1) if ($type =~ /\.(\w{3,4})$/); my $response = ''; if ($type =~ /^(jpeg|png)$/) { PDLNA::Log::log('Delivering Logo in format '.$type.' and with '.$size.'x'.$size.' pixels.', 2, 'httpgeneric'); GD::Image->trueColor(1); my $image = GD::Image->new('../lib/perl5/PDLNA/pDLNA.png'); my $preview = GD::Image->new($size, $size); # all black areas of the image should be transparent my $black = $preview->colorAllocate(0,0,0); $preview->transparent($black); $preview->copyResampled($image, 0, 0, 0, 0, $size, $size, $image->width, $image->height); my @additional_header = (); $additional_header[0] = 'Content-Type: image/jpeg' if ($type eq 'jpeg'); $additional_header[0] = 'Content-Type: image/png' if ($type eq 'png'); $response = http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); $response .= $preview->jpeg() if ($type eq 'jpeg'); $response .= $preview->png() if ($type eq 'png'); $response .= "\r\n"; } else { PDLNA::Log::log('Unknown Logo format '.$type.'.', 2, 'httpgeneric'); $response = http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', }); } return $response; } 1; __END__ sub stream_media_beta { my $content_id = shift; my $method = shift; my $CGI = shift; my $FH = shift; my $model_name = shift; my $client_ip = shift; my $user_agent = shift; # # ContentID verification # my $id = 0; if ($content_id =~ /^(\d+)\.(\w+)$/) { $id = $1; } else { PDLNA::Log::log('ERROR: ContentID '.$content_id.' for Streaming Items is NOT supported yet.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); close(FILE); return; } PDLNA::Log::log('Found ContentID in streaming request: '.$id, 3, 'httpstream'); # # getting information from database # my $dbh = PDLNA::Database::connect(); my @item = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT NAME,FULLNAME,PATH,FILE_EXTENSION,SIZE,MIME_TYPE,TYPE,EXTERNAL FROM FILES WHERE ID = ?', 'parameters' => [ $id, ], }, \@item, ); my @iteminfo = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT CONTAINER, AUDIO_CODEC, VIDEO_CODEC, DURATION FROM FILEINFO WHERE FILEID_REF = ?;', 'parameters' => [ $id, ], }, \@iteminfo, ); my @subtitles = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, type, fullname FROM subtitles WHERE fileid_ref = ?', 'parameters' => [ $id, ], }, \@subtitles, ); PDLNA::Database::disconnect($dbh); # # TODO sanity checks for file # my $transcode = 0; # # TODO HTTP response header # my @additional_header = (); push(@additional_header, 'Content-Type: '.PDLNA::Media::get_mimetype_by_modelname($item[0]->{MIME_TYPE}, $model_name)); push(@additional_header, 'Content-Length: '.$item[0]->{SIZE}) if !$item[0]->{EXTERNAL}; # TODO push(@additional_header, 'Content-Disposition: attachment; filename="'.$item[0]->{NAME}.'"') if !$item[0]->{EXTERNAL}; push(@additional_header, 'Accept-Ranges: bytes'); # TODO # # contentFeatures.dlna.org # Streaming of content is NOT working with SAMSUNG without this response header # if (defined($$CGI{'GETCONTENTFEATURES.DLNA.ORG'})) { if ($$CGI{'GETCONTENTFEATURES.DLNA.ORG'} == 1) { push(@additional_header, 'contentFeatures.dlna.org: '.PDLNA::Media::get_dlnacontentfeatures($item[0], $transcode)); } else { PDLNA::Log::log('Invalid contentFeatures.dlna.org:'.$$CGI{'GETCONTENTFEATURES.DLNA.ORG'}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', }); close(FILE); return; } } # # SUBTITLES # if (defined($$CGI{'GETCAPTIONINFO.SEC'})) { if ($$CGI{'GETCAPTIONINFO.SEC'} == 1) { if ($item[0]->{TYPE} eq 'video') { foreach my $subtitle (@subtitles) { if ($subtitle->{type} eq 'srt' && -f $subtitle->{fullname}) { push(@additional_header, 'CaptionInfo.sec: http://'.$CONFIG{'LOCAL_IPADDR'}.':'.$CONFIG{'HTTP_PORT'}.'/subtitle/'.$subtitle->{id}.'.srt'); } } } unless (grep(/^contentFeatures.dlna.org:/, @additional_header)) { push(@additional_header, 'contentFeatures.dlna.org: '.PDLNA::Media::get_dlnacontentfeatures($item[0], $transcode)); } } else { PDLNA::Log::log('Invalid getCaptionInfo.sec:'.$$CGI{'GETCAPTIONINFO.SEC'}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', }); close(FILE); return; } } # # DURATION # if (defined($$CGI{'GETMEDIAINFO.SEC'})) { if ($$CGI{'GETMEDIAINFO.SEC'} == 1) { if ($item[0]->{TYPE} eq 'video' || $item[0]->{TYPE} eq 'audio') { push(@additional_header, 'MediaInfo.sec: SEC_Duration='.$iteminfo[0]->{DURATION}.'000;'); # in milliseconds unless (grep(/^contentFeatures.dlna.org:/, @additional_header)) { push(@additional_header, 'contentFeatures.dlna.org: '.PDLNA::Media::get_dlnacontentfeatures($item[0], $transcode)); } } } else { PDLNA::Log::log('Invalid getMediaInfo.sec:'.$$CGI{'GETMEDIAINFO.SEC'}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', }); close(FILE); return; } } # # HANDLING THE THE REQUESTS # if ($method eq 'HEAD') # handling HEAD requests { PDLNA::Log::log('Delivering content information (HEAD Request) for: '.$item[0]->{NAME}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); close(FILE); return; } elsif ($method eq 'GET') # handling GET requests { # for clients, which are not sending the Streaming value for the transferMode.dlna.org parameter # we set it, because they seem to ignore it my @useragents = ( 'foobar2000', # since foobar2000 is NOT sending any TRANSFERMODE.DLNA.ORG param 'vlc*', # since vlc is NOT sending any TRANSFERMODE.DLNA.ORG param 'stagefright', # since UPnPlay is NOT sending any TRANSFERMODE.DLNA.ORG param 'gvfs', # since Totem Movie Player is NOT sending any TRANSFERMODE.DLNA.ORG param '(null)', ); if (defined($$CGI{'USER-AGENT'})) { foreach my $ua (@useragents) { $$CGI{'TRANSFERMODE.DLNA.ORG'} = 'Streaming' if $$CGI{'USER-AGENT'} =~ /^$ua/i; } } # # transferMode handling # if (defined($$CGI{'TRANSFERMODE.DLNA.ORG'})) { if ($$CGI{'TRANSFERMODE.DLNA.ORG'} eq 'Streaming') # for immediate rendering of audio or video content { push(@additional_header, 'transferMode.dlna.org: Streaming'); if (defined($$CGI{'TIMESEEKRANGE.DLNA.ORG'}) && $$CGI{'TIMESEEKRANGE.DLNA.ORG'} =~ /^npt=(\d+)-(\d*)/) { PDLNA::Log::log('Delivering content for: '.$item[0]->{FULLNAME}.' with TIMESEEKRANGE request.', 1, 'httpstream'); my $startseek = $1 ? $1 : 0; my $endseek = $2 ? $2 : $iteminfo[0]->{DURATION}; push(@additional_header, 'TimeSeekRange.dlna.org: npt='.PDLNA::Utils::convert_duration($startseek).'-'.PDLNA::Utils::convert_duration($endseek).'/'.PDLNA::Utils::convert_duration($iteminfo[0]->{DURATION})); push(@additional_header, 'X-Seek-Range: npt='.PDLNA::Utils::convert_duration($startseek).'-'.PDLNA::Utils::convert_duration($endseek).'/'.PDLNA::Utils::convert_duration($iteminfo[0]->{DURATION})); my $command = $CONFIG{'FFMPEG_BIN'}.' -y -ss '.$1.' -i "'.$item[0]->{FULLNAME}.'" -vcodec copy -acodec copy -f avi pipe:'; my $statuscode = 200; #@additional_header = map { /^(Content-Length|Accept-Ranges):/i ? () : $_ } @additional_header; # delete some header @additional_header = map { /^(Accept-Ranges):/i ? () : $_ } @additional_header; # delete some header open(ITEM, '-|', $command); binmode(ITEM); print $FH http_header({ 'statuscode' => $statuscode, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); my $buf = undef; while (sysread(ITEM, $buf, $CONFIG{'BUFFER_SIZE'})) { PDLNA::Log::log('Adding '.bytes::length($buf).' bytes to Streaming connection.', 3, 'httpstream'); print $FH $buf or return 1; } close(ITEM); } else { # if ($CONFIG{'LOW_RESOURCE_MODE'}) # { my $statuscode = 200; my ($lowrange, $highrange) = 0; if (defined($$CGI{'RANGE'}) && $$CGI{'RANGE'} =~ /^bytes=(\d+)-(\d*)$/) { PDLNA::Log::log('Delivering content for: '.$item[0]->{FULLNAME}.' with RANGE request.', 1, 'httpstream'); my $statuscode = 206; $lowrange = int($1); $highrange = $2 ? int($2) : 0; $highrange = $item[0]->{SIZE}-1 if $highrange == 0; $highrange = $item[0]->{SIZE}-1 if ($highrange >= $item[0]->{SIZE}); my $bytes_to_ship = $highrange - $lowrange + 1; $additional_header[1] = 'Content-Length: '.$bytes_to_ship; # we need to change the Content-Length push(@additional_header, 'Content-Range: bytes '.$lowrange.'-'.$highrange.'/'.$item[0]->{SIZE}); } sysopen(ITEM, $item[0]->{FULLNAME}, O_RDONLY); sysseek(ITEM, $lowrange, 0) if $lowrange; print $FH http_header({ 'statuscode' => $statuscode, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); my $buf = undef; while (sysread(ITEM, $buf, $CONFIG{'BUFFER_SIZE'})) { PDLNA::Log::log('Adding '.bytes::length($buf).' bytes to Streaming connection.', 3, 'httpstream'); print $FH $buf or return 1; } close(ITEM); } # else # { # my $statuscode = 200; # my $command = $CONFIG{'FFMPEG_BIN'}.' -i '.$item[0]->{FULLNAME}.' -acodec copy -f mp3 pipe:'; # #@additional_header = map { /^(Content-Length|Accept-Ranges):/i ? () : $_ } @additional_header; # delete some header # @additional_header = map { /^(Accept-Ranges):/i ? () : $_ } @additional_header; # delete some header # # open(ITEM, '-|', $command); # binmode(ITEM); # # print $FH http_header({ # 'statuscode' => $statuscode, # 'additional_header' => \@additional_header, # 'log' => 'httpstream', # }); # my $buf = undef; # while (sysread(ITEM, $buf, $CONFIG{'BUFFER_SIZE'})) # { # PDLNA::Log::log('Adding '.bytes::length($buf).' bytes to Streaming connection.', 3, 'httpstream'); # print $FH $buf or return 1; # } # close(ITEM); # } # close($FH); return; } elsif ($$CGI{'TRANSFERMODE.DLNA.ORG'} eq 'Interactive') # for immediate rendering of images or playlist files { PDLNA::Log::log('Delivering (Interactive) content for: '.$item[0]->{FULLNAME}.'.', 1, 'httpstream'); push(@additional_header, 'transferMode.dlna.org: Interactive'); # Delivering interactive content as a whole print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); sysopen(FILE, $item[0]->{FULLNAME}, O_RDONLY); print $FH ; close(FILE); return; } else # unknown TRANSFERMODE.DLNA.ORG is set { PDLNA::Log::log('ERROR: Transfermode '.$$CGI{'TRANSFERMODE.DLNA.ORG'}.' for Streaming Items is NOT supported yet.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); close(FILE); return; } } else # no TRANSFERMODE.DLNA.ORG is set { PDLNA::Log::log('Delivering content information (no Transfermode) for: '.$item[0]->{FULLNAME}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); close(FILE); return; } } else # unknown HTTP METHOD is set { PDLNA::Log::log('ERROR: HTTP Method '.$method.' for Streaming Items is NOT supported yet.', 0, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); close(FILE); return; } } sub stream_media_old # with old db scheme { my $content_id = shift; my $method = shift; my $CGI = shift; my $FH = shift; my $model_name = shift; my $client_ip = shift; my $user_agent = shift; my $dbh = PDLNA::Database::connect(); PDLNA::Log::log('ContentID: '.$content_id, 3, 'httpstream'); if ($content_id =~ /^(\d+)\.(\w+)$/) { my $id = $1; PDLNA::Log::log('ID: '.$id, 3, 'httpstream'); # # getting information from database # my @item = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT NAME,FULLNAME,PATH,FILE_EXTENSION,SIZE,MIME_TYPE,TYPE,EXTERNAL FROM FILES WHERE ID = ?', 'parameters' => [ $id, ], }, \@item, ); my @iteminfo = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT CONTAINER, AUDIO_CODEC, VIDEO_CODEC FROM FILEINFO WHERE FILEID_REF = ?;', 'parameters' => [ $id, ], }, \@iteminfo, ); # # check if we need to transcode # my %media_data = ( 'fullname' => $item[0]->{FULLNAME}, 'external' => $item[0]->{EXTERNAL}, 'media_type' => $item[0]->{TYPE}, 'container' => $iteminfo[0]->{CONTAINER}, 'audio_codec' => $iteminfo[0]->{AUDIO_CODEC}, 'video_codec' => $iteminfo[0]->{VIDEO_CODEC}, ); my $transcode = 0; if ($transcode = PDLNA::FFmpeg::shall_we_transcode( \%media_data, { 'ip' => $client_ip, 'user_agent' => $user_agent, }, )) { $item[0]->{MIME_TYPE} = $media_data{'mime_type'}; } # # sanity checks # unless (defined($item[0]->{FULLNAME})) { PDLNA::Log::log('Content with ID '.$id.' NOT found (in media library).', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } if (!$item[0]->{EXTERNAL} && !-f $item[0]->{FULLNAME}) { PDLNA::Log::log('Content with ID '.$id.' NOT found (on filesystem): '.$item[0]->{FULLNAME}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } if ($item[0]->{EXTERNAL} && !PDLNA::Media::is_supported_stream($item[0]->{FULLNAME}) && !-x $item[0]->{FULLNAME}) { PDLNA::Log::log('Content with ID '.$id.' is a SCRIPT but NOT executable: '.$item[0]->{FULLNAME}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 404, 'content_type' => 'text/plain', 'log' => 'httpstream', }); return; } # # for streaming relevant code starts here # my @additional_header = (); push(@additional_header, 'Content-Type: '.PDLNA::Media::get_mimetype_by_modelname($item[0]->{MIME_TYPE}, $model_name)); push(@additional_header, 'Content-Length: '.$item[0]->{SIZE}) if !$item[0]->{EXTERNAL}; push(@additional_header, 'Content-Disposition: attachment; filename="'.$item[0]->{NAME}.'"') if !$item[0]->{EXTERNAL}; push(@additional_header, 'Accept-Ranges: bytes'); # TODO # Streaming of content is NOT working with SAMSUNG without this response header if (defined($$CGI{'GETCONTENTFEATURES.DLNA.ORG'})) { if ($$CGI{'GETCONTENTFEATURES.DLNA.ORG'} == 1) { push(@additional_header, 'contentFeatures.dlna.org: '.PDLNA::Media::get_dlnacontentfeatures($item[0], $transcode)); } else { PDLNA::Log::log('Invalid contentFeatures.dlna.org:'.$$CGI{'GETCONTENTFEATURES.DLNA.ORG'}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', }); } } # subtitles if (defined($$CGI{'GETCAPTIONINFO.SEC'})) { if ($$CGI{'GETCAPTIONINFO.SEC'} == 1) { if ($item[0]->{TYPE} eq 'video') { my @subtitles = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT id, type, fullname FROM subtitles WHERE fileid_ref = ?', 'parameters' => [ $id, ], }, \@subtitles, ); foreach my $subtitle (@subtitles) { if ($subtitle->{type} eq 'srt' && -f $subtitle->{fullname}) { push(@additional_header, 'CaptionInfo.sec: http://'.$CONFIG{'LOCAL_IPADDR'}.':'.$CONFIG{'HTTP_PORT'}.'/subtitle/'.$subtitle->{id}.'.srt'); } } } unless (grep(/^contentFeatures.dlna.org:/, @additional_header)) { push(@additional_header, 'contentFeatures.dlna.org: '.PDLNA::Media::get_dlnacontentfeatures($item[0], $transcode)); } } else { PDLNA::Log::log('Invalid getCaptionInfo.sec:'.$$CGI{'GETCAPTIONINFO.SEC'}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', }); } } # duration if (defined($$CGI{'GETMEDIAINFO.SEC'})) { if ($$CGI{'GETMEDIAINFO.SEC'} == 1) { if ($item[0]->{TYPE} eq 'video' || $item[0]->{TYPE} eq 'audio') { my @item_metainfo = (); PDLNA::Database::select_db( $dbh, { 'query' => 'SELECT DURATION FROM FILEINFO WHERE FILEID_REF = ?', 'parameters' => [ $id, ], }, \@item_metainfo, ); push(@additional_header, 'MediaInfo.sec: SEC_Duration='.$item_metainfo[0]->{DURATION}.'000;'); # in milliseconds unless (grep(/^contentFeatures.dlna.org:/, @additional_header)) { push(@additional_header, 'contentFeatures.dlna.org: '.PDLNA::Media::get_dlnacontentfeatures($item[0], $transcode)); } } } else { PDLNA::Log::log('Invalid getMediaInfo.sec:'.$$CGI{'GETMEDIAINFO.SEC'}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 400, 'content_type' => 'text/plain', }); } } if ($method eq 'HEAD') # handling HEAD requests { PDLNA::Log::log('Delivering content information (HEAD Request) for: '.$item[0]->{NAME}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); } elsif ($method eq 'GET') # handling GET requests { # for clients, which are not sending the Streaming value for the transferMode.dlna.org parameter # we set it, because they seem to ignore it if (defined($$CGI{'USER-AGENT'})) { if ( $$CGI{'USER-AGENT'} =~ /^foobar2000/ || # since foobar2000 is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^vlc/i || # since vlc is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^stagefright/ || # since UPnPlay is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^gvfs/ || # since Totem Movie Player is NOT sending any TRANSFERMODE.DLNA.ORG param $$CGI{'USER-AGENT'} =~ /^\(null\)/ ) { $$CGI{'TRANSFERMODE.DLNA.ORG'} = 'Streaming'; } } # transferMode handling if (defined($$CGI{'TRANSFERMODE.DLNA.ORG'})) { if ($$CGI{'TRANSFERMODE.DLNA.ORG'} eq 'Streaming') # for immediate rendering of audio or video content { push(@additional_header, 'transferMode.dlna.org: Streaming'); my $statuscode = 200; my ($lowrange, $highrange) = 0; if ( defined($$CGI{'RANGE'}) && # if RANGE is defined as HTTP header $$CGI{'RANGE'} =~ /^bytes=(\d+)-(\d*)$/ && # if RANGE looks like !$item[0]->{EXTERNAL} && # if FILE is not external !$transcode # if TRANSCODING is not required ) { PDLNA::Log::log('Delivering content for: '.$item[0]->{FULLNAME}.' with RANGE Request.', 1, 'httpstream'); my $statuscode = 206; $lowrange = int($1); $highrange = $2 ? int($2) : 0; $highrange = $item[0]->{SIZE}-1 if $highrange == 0; $highrange = $item[0]->{SIZE}-1 if ($highrange >= $item[0]->{SIZE}); my $bytes_to_ship = $highrange - $lowrange + 1; $additional_header[1] = 'Content-Length: '.$bytes_to_ship; # we need to change the Content-Length push(@additional_header, 'Content-Range: bytes '.$lowrange.'-'.$highrange.'/'.$item[0]->{SIZE}); } # # sending the response # if (!$item[0]->{EXTERNAL} && !$transcode) # file on disk or TRANSFERMODE is NOT required { sysopen(ITEM, $item[0]->{FULLNAME}, O_RDONLY); sysseek(ITEM, $lowrange, 0) if $lowrange; } else # streams, scripts, or transcoding { my $command = ''; if (PDLNA::Media::is_supported_stream($item[0]->{FULLNAME})) # if it is a supported stream { $command = PDLNA::FFmpeg::get_ffmpeg_stream_command(\%media_data); } elsif ($transcode) # if TRANSCODING is required { $command = $media_data{'command'}; } else # if it is a script { $command = $item[0]->{FULLNAME}; } open(ITEM, '-|', $command); binmode(ITEM); @additional_header = map { /^(Content-Length|Accept-Ranges):/i ? () : $_ } @additional_header; # delete some header } print $FH http_header({ 'statuscode' => $statuscode, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); my $buf = undef; while (sysread(ITEM, $buf, $CONFIG{'BUFFER_SIZE'})) { PDLNA::Log::log('Adding '.bytes::length($buf).' bytes to Streaming connection.', 3, 'httpstream'); print $FH $buf or return 1; } close(ITEM); return 1; } elsif ($$CGI{'TRANSFERMODE.DLNA.ORG'} eq 'Interactive') # for immediate rendering of images or playlist files { PDLNA::Log::log('Delivering (Interactive) content for: '.$item[0]->{FULLNAME}.'.', 1, 'httpstream'); push(@additional_header, 'transferMode.dlna.org: Interactive'); # Delivering interactive content as a whole print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, }); sysopen(FILE, $item[0]->{FULLNAME}, O_RDONLY); print $FH ; close(FILE); } else # unknown TRANSFERMODE.DLNA.ORG is set { PDLNA::Log::log('Transfermode '.$$CGI{'TRANSFERMODE.DLNA.ORG'}.' for Streaming Items is NOT supported yet.', 2, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', }); } } else # no TRANSFERMODE.DLNA.ORG is set { PDLNA::Log::log('Delivering content information (no Transfermode) for: '.$item[0]->{FULLNAME}.'.', 1, 'httpstream'); print $FH http_header({ 'statuscode' => 200, 'additional_header' => \@additional_header, 'log' => 'httpstream', }); } } else # not implemented HTTP method { PDLNA::Log::log('HTTP Method '.$method.' for Streaming Items is NOT supported yet.', 2, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } } else { PDLNA::Log::log('ContentID '.$content_id.' for Streaming Items is NOT supported yet.', 2, 'httpstream'); print $FH http_header({ 'statuscode' => 501, 'content_type' => 'text/plain', 'log' => 'httpstream', }); } } pDLNA/usr/lib/perl5/PDLNA/Media.pm0000700000175000017500000004075313366114774015571 0ustar geumageumapackage PDLNA::Media; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Audio::FLAC::Header; use Audio::Wav; use Audio::WMA; use Fcntl; use Image::Info qw(image_info dim image_type); use MP3::Info; use MP4::Info; use Ogg::Vorbis::Header::PurePerl; use XML::Simple; # # SUPPORTED MIME_TYPES # my %MIME_TYPES = ( 'image/jpeg' => 'jpeg', 'image/gif' => 'gif', 'audio/mpeg' => 'mp3', 'audio/mp4' => 'mp4', 'audio/x-ms-wma' => 'wma', 'audio/x-flac' => 'flac', 'audio/x-wav' => 'wav', 'video/x-theora+ogg' => 'ogg', 'audio/ac3' => 'ac3', 'audio/x-aiff' => 'lpcm', 'video/x-msvideo' => 'avi', 'video/x-matroska' => 'mkv', 'video/mp4' => 'mp4', 'video/mpeg' => 'mpg', 'video/x-flv' => 'flv', ); sub is_supported_mimetype { my $mimetype = shift; return 1 if defined($MIME_TYPES{$mimetype}); return 0; } sub return_type_by_mimetype { my $mimetype = shift; my ($media_type) = split('/', $mimetype, 0); $media_type = 'audio' if $mimetype eq 'video/x-theora+ogg'; return $media_type; } sub get_mimetype_by_modelname { my $mimetype = shift; my $modelname = shift || ''; if ($modelname eq 'Samsung DTV DMR') { return 'video/x-mkv' if $mimetype eq 'video/x-matroska'; return 'video/x-avi' if $mimetype eq 'video/x-msvideo'; return 'smi/caption' if $mimetype eq 'application/x-subrip'; } return $mimetype; } # # SUPPORTED PLAYLIST MIME_TYPES # my %PLAYLISTS = ( 'audio/x-scpls' => 'pls', 'application/vnd.apple.mpegurl' => 'm3u', 'audio/x-mpegurl' => 'm3u', 'audio/x-ms-asx' => 'asx', 'video/x-ms-asf' => 'asf', 'application/xspf+xml' => 'xspf', # '' => 'm3u8' ); sub is_supported_playlist { my $mimetype = shift; return 1 if defined($PLAYLISTS{$mimetype}); return 0; } sub parse_playlist { my $file = shift; my $mime_type = shift; # # TODO # shall we open all playlist files with UTF-8 encoding ?? # or for instance only specific types of playlist files: m3u8 ?? # open(PLAYLIST, '<:encoding(UTF-8)', $file); # my @items = (); if ($mime_type eq 'audio/x-scpls') { # reading the playlist file sysopen(PLAYLIST, $file, O_RDONLY); my @content = ; close(PLAYLIST); foreach my $line (@content) { $line =~ s/\r\n//g; $line =~ s/\n//g; push(@items, $1) if ($line =~ /^File\d+\=(.+)$/); } } elsif ($mime_type eq 'application/vnd.apple.mpegurl' || $mime_type eq 'audio/x-mpegurl') { # reading the playlist file sysopen(PLAYLIST, $file, O_RDONLY); my @content = ; close(PLAYLIST); foreach my $line (@content) { $line =~ s/\r\n//g; $line =~ s/\n//g; push(@items, $line) if ($line !~ /^#/); } } elsif ($mime_type eq 'audio/x-ms-asx' || $mime_type eq 'video/x-ms-asf') { # TODO more beautiful way to do this # reading the playlist file sysopen(PLAYLIST, $file, O_RDONLY); my @content = ; close(PLAYLIST); foreach my $line (@content) { $line =~ s/\r\n//g; $line =~ s/\n//g; $line =~ s/^\s+//g; } foreach my $entry (split(/(<.+?>)/, join('', @content))) { push(@items, $1) if $entry =~ /^$/; } } elsif ($mime_type eq 'application/xspf+xml') { my $xs = XML::Simple->new(); my $xml = $xs->XMLin($file); foreach my $element (@{$xml->{trackList}->{track}}) { if ($element->{location} =~ /^file:\/\/(.+)$/) { push(@items, $1); } elsif ($element->{location} =~ /^http:\/\//) { push(@items, $element->{location}); } } } return @items; } # # SUPPORTED SUBTITLE MIME_TYPES # my %SUBTITLES = ( 'application/x-subrip' => 'srt', ); sub is_supported_subtitle { my $mimetype = shift; return 1 if defined($SUBTITLES{$mimetype}); return 0; } # # SUPPORTED STREAMING URLS # sub is_supported_stream { my $url = shift || ''; return 1 if $url =~ /^(http|mms):\/\//; return 0; } # # this is the data structure to determine the exact MimeType, FileExtension and MediaType per container and codec information from FFmpeg # this is used when LOW_RESOURCE_MODE is disabled # my %CONTAINER = ( 'avi' => { 'AudioCodecs' => [ 'mp3', 'mp2', ], 'VideoCodecs' => [ 'mpeg4', 'msmpeg4', 'msmpeg4v2' ], 'mpeg4' => { 'MimeType' => 'video/x-msvideo', # video/avi, video/msvideo 'FileExtension' => 'avi', 'MediaType' => 'video', }, 'msmpeg4' => { 'MimeType' => 'video/x-msvideo', # video/avi, video/msvideo 'FileExtension' => 'avi', 'MediaType' => 'video', }, 'msmpeg4v2' => { 'MimeType' => 'video/x-msvideo', # video/avi, video/msvideo 'FileExtension' => 'avi', 'MediaType' => 'video', }, }, 'mp3' => { 'AudioCodecs' => [ 'mp3', ], 'VideoCodecs' => [], 'mp3' => { 'MimeType' => 'audio/mpeg', 'FileExtension' => 'mp3', 'MediaType' => 'audio', }, }, 'mov' => { 'AudioCodecs' => [ 'mpeg4aac', 'aac', ], 'VideoCodecs' => [ 'h264', 'mpeg4', ], 'mpeg4aac' => { 'MimeType' => 'audio/mp4', 'FileExtension' => 'mp4', # m4a 'MediaType' => 'audio', }, 'aac' => { 'MimeType' => 'audio/mp4', 'FileExtension' => 'mp4', # m4a 'MediaType' => 'audio', }, 'h264' => { 'MimeType' => 'video/mp4', 'FileExtension' => 'mp4', 'MediaType' => 'video', }, 'mpeg4' => { 'MimeType' => 'video/mp4', 'FileExtension' => 'mp4', 'MediaType' => 'video', }, }, 'ac3' => { 'AudioCodecs' => [ 'ac3', ], 'VideoCodecs' => [], 'ac3' => { 'MimeType' => 'audio/ac3', 'FileExtension' => 'ac3', 'MediaType' => 'audio', }, }, 'flac' => { 'AudioCodecs' => [ 'flac', ], 'VideoCodecs' => [], 'flac' => { 'MimeType' => 'audio/flac', 'FileExtension' => 'flac', 'MediaType' => 'audio', }, }, 'ogg' => { 'AudioCodecs' => [ 'vorbis', ], 'VideoCodecs' => [], 'vorbis' => { 'MimeType' => 'video/x-theora+ogg', 'FileExtension' => 'ogg', 'MediaType' => 'audio', }, }, 'wav' => { 'AudioCodecs' => [ 'pcm_s16le', ], 'VideoCodecs' => [], 'pcm_s16le' => { 'MimeType' => 'audio/wav', 'FileExtension' => 'wav', 'MediaType' => 'audio', }, }, 'asf' => { 'AudioCodecs' => [ 'wmav1', 'wmav2', ], 'VideoCodecs' => [], 'wmav1' => { 'MimeType' => 'audio/x-ms-wma', 'FileExtension' => 'wma', 'MediaType' => 'audio', }, 'wmav2' => { 'MimeType' => 'audio/x-ms-wma', 'FileExtension' => 'wma', 'MediaType' => 'audio', }, }, 'matroska' => { 'AudioCodecs' => [ 'ac3', 'dca', 'aac', ], 'VideoCodecs' => [ 'h264', 'mpeg4', ], 'h264' => { 'MimeType' => 'video/x-matroska', 'FileExtension' => 'mkv', 'MediaType' => 'video', }, 'mpeg4' => { 'MimeType' => 'video/x-matroska', 'FileExtension' => 'mkv', 'MediaType' => 'video', }, }, 'mpeg' => { 'AudioCodecs' => [ 'mp2', 'ac3', ], 'VideoCodecs' => [ 'mpeg1video', 'mpeg2video', ], 'mpeg1video' => { 'MimeType' => 'video/mpeg', 'FileExtension' => 'mpg', 'MediaType' => 'video', }, 'mpeg2video' => { 'MimeType' => 'video/mpeg', 'FileExtension' => 'mpg', 'MediaType' => 'video', }, }, 'flv' => { 'AudioCodecs' => [ 'mp3', ], 'VideoCodecs' => [ 'vp6f', ], 'vp6f' => { 'MimeType' => 'video/x-flv', 'FileExtension' => 'flv', 'MediaType' => 'video', }, }, ); sub details { my $container = shift; my $video_codec = shift; my $audio_codec = shift; my $param = shift; if ($container && $video_codec) { if (defined($CONTAINER{$container}->{$video_codec})) { return $CONTAINER{$container}->{$video_codec}->{$param}; } else { PDLNA::Log::log('Unknown MediaInformation: Container: '.$container.', AudioCodec: '.$audio_codec.', VideoCodec: '.$video_codec.'.', 1, 'library'); } } elsif ($container && $audio_codec) { if (defined($CONTAINER{$container}->{$audio_codec})) { return $CONTAINER{$container}->{$audio_codec}->{$param}; } else { PDLNA::Log::log('Unknown MediaInformation: Container: '.$container.', AudioCodec: '.$audio_codec.'.', 1, 'library'); } } else { PDLNA::Log::log('ERROR: FFmpeg was unable to determine MediaInformation.', 0, 'library'); } return undef; } # # OTHER FUNCTIONS # # TODO find a more elegant way to handle this sub get_dlnacontentfeatures { my $item = shift; my $transcode = shift || 0; my $contentfeatures = ''; # DLNA.ORG_PN - media profile if (ref($item) eq 'HASH') { $contentfeatures .= 'DLNA.ORG_PN=WMABASE;' if $item->{mime_type} eq 'audio/x-ms-wma'; $contentfeatures .= 'DLNA.ORG_PN=MP3;' if $item->{mime_type} eq 'audio/mpeg'; $contentfeatures .= 'DLNA.ORG_PN=JPEG_LRG;' if $item->{mime_type} eq 'image/jpeg'; } else { $contentfeatures .= 'DLNA.ORG_PN=JPEG_TN;' if $item eq 'JPEG_TN'; $contentfeatures .= 'DLNA.ORG_PN=JPEG_SM;' if $item eq 'JPEG_SM'; } # DLNA.ORG_OP=ab # a - server supports TimeSeekRange # b - server supports RANGE if (ref($item) eq 'HASH') { if ($item->{media_type} eq 'image' || $item->{item_type} == 2) { $contentfeatures .= 'DLNA.ORG_OP=00;'; # no seeking for images or subtitles } else { $contentfeatures .= 'DLNA.ORG_OP=01;'; # activate seeking by RANGE command } } else { $contentfeatures .= 'DLNA.ORG_OP=00;'; # no seeking } # DLNA.ORG_PS - supported play speeds # TODO # DLNA.ORG_CI - for transcoded media items it is set to 1 $contentfeatures .= 'DLNA.ORG_CI='.$transcode.';'; # DLNA.ORG_FLAGS - binary flags with device parameters if (ref($item) eq 'HASH') { if ($item->{media_type} eq 'image') { $contentfeatures .= 'DLNA.ORG_FLAGS=00D00000000000000000000000000000'; } elsif ($item->{item_type} == 2) { # do not add something to our contentfeatures } else { $contentfeatures .= 'DLNA.ORG_FLAGS=01500000000000000000000000000000'; } } else { $contentfeatures .= 'DLNA.ORG_FLAGS=00D00000000000000000000000000000'; } return $contentfeatures; } sub get_dlnacontentfeatures_old { my $item = shift; my $transcode = shift; my $type = shift; my $contentfeatures = ''; # DLNA.ORG_PN - media profile if (defined($item)) { # $contentfeatures .= 'DLNA.ORG_PN=LPCM;' if $self->{MIME_TYPE} eq 'audio/L16'; # $contentfeatures .= 'DLNA.ORG_PN=LPCM;' if $self->{MIME_TYPE} eq 'audio/x-aiff'; # $contentfeatures .= 'DLNA.ORG_PN=LPCM;' if $self->{MIME_TYPE} eq 'audio/x-wav'; $contentfeatures .= 'DLNA.ORG_PN=WMABASE;' if $item->{MIME_TYPE} eq 'audio/x-ms-wma'; $contentfeatures .= 'DLNA.ORG_PN=MP3;' if $item->{MIME_TYPE} eq 'audio/mpeg'; $contentfeatures .= 'DLNA.ORG_PN=JPEG_LRG;' if $item->{MIME_TYPE} eq 'image/jpeg'; } else { $contentfeatures .= 'DLNA.ORG_PN=JPEG_TN;' if $type eq 'JPEG_TN'; $contentfeatures .= 'DLNA.ORG_PN=JPEG_SM;' if $type eq 'JPEG_SM'; } # DLNA.ORG_OP=ab # a - server supports TimeSeekRange # b - server supports RANGE if (defined($item)) { if ($item->{TYPE} eq 'image') { $contentfeatures .= 'DLNA.ORG_OP=00;'; # deactivate seeking for images } # else # { # $contentfeatures .= 'DLNA.ORG_OP=11;'; # } elsif ($transcode) { $contentfeatures .= 'DLNA.ORG_OP=00;'; # deactivate seeking for transcoded media items } elsif ($item->{EXTERNAL}) { $contentfeatures .= 'DLNA.ORG_OP=00;'; # deactivate seeking for external media items } else { $contentfeatures .= 'DLNA.ORG_OP=01;'; # activate seeking by RANGE command } } else { $contentfeatures .= 'DLNA.ORG_OP=00;'; # deactivate seeking for thumbnails } # DLNA.ORG_PS - supported play speeds # TODO # DLNA.ORG_CI - for transcoded media items it is set to 1 $contentfeatures .= 'DLNA.ORG_CI='.$transcode.';'; # DLNA.ORG_FLAGS - binary flags with device parameters if (defined($item)) { if ($item->{TYPE} eq 'image') { $contentfeatures .= 'DLNA.ORG_FLAGS=00D00000000000000000000000000000'; } # elsif ($self->{MIME_TYPE} eq 'audio/x-aiff' || $self->{MIME_TYPE} eq 'audio/x-wav') # { # $contentfeatures .= 'DLNA.ORG_FLAGS=61F00000000000000000000000000000'; # } else { $contentfeatures .= 'DLNA.ORG_FLAGS=01500000000000000000000000000000'; } } else { $contentfeatures .= 'DLNA.ORG_FLAGS=00D00000000000000000000000000000'; } return $contentfeatures; } sub get_image_fileinfo { my $path = shift; my $info = image_info($path); return dim($info); } sub get_audio_fileinfo { my $file = shift; my $audio_codec = shift; my $info = shift; if ($audio_codec eq 'mp3') { my $tag = get_mp3tag($file); if (keys %{$tag}) { $$info{ARTIST} = $tag->{'ARTIST'} if length($tag->{'ARTIST'}) > 0; $$info{ALBUM} = $tag->{'ALBUM'} if length($tag->{'ALBUM'}) > 0; $$info{TRACKNUM} = $tag->{'TRACKNUM'} if length($tag->{'TRACKNUM'}) > 0; $$info{TITLE} = $tag->{'TITLE'} if length($tag->{'TITLE'}) > 0; $$info{GENRE} = $tag->{'GENRE'} if length($tag->{'GENRE'}) > 0; $$info{YEAR} = $tag->{'YEAR'} if length($tag->{'YEAR'}) > 0; } } elsif ($audio_codec eq 'mpeg4aac') { my $tag = get_mp4tag($file); if (keys %{$tag}) { $$info{ARTIST} = $tag->{'ARTIST'} if length($tag->{'ARTIST'}) > 0; $$info{ALBUM} = $tag->{'ALBUM'} if length($tag->{'ALBUM'}) > 0; $$info{TRACKNUM} = $tag->{'TRACKNUM'} if length($tag->{'TRACKNUM'}) > 0; $$info{TITLE} = $tag->{'TITLE'} if length($tag->{'TITLE'}) > 0; $$info{GENRE} = $tag->{'GENRE'} if length($tag->{'GENRE'}) > 0; $$info{YEAR} = $tag->{'YEAR'} if length($tag->{'YEAR'}) > 0; } } elsif ($audio_codec eq 'wmav2') # TODO wmav1 { my $wma = Audio::WMA->new($file); my $tag = $wma->tags(); if (keys %{$tag}) { $$info{ARTIST} = $tag->{'AUTHOR'} if length($tag->{'AUTHOR'}) > 0; $$info{ALBUM} = $tag->{'ALBUMTITLE'} if length($tag->{'ALBUMTITLE'}) > 0; $$info{TRACKNUM} = $tag->{'TRACKNUMBER'} if length($tag->{'TRACKNUMBER'}) > 0; $$info{TITLE} = $tag->{'TITLE'} if length($tag->{'TITLE'}) > 0; $$info{GENRE} = $tag->{'GENRE'} if length($tag->{'GENRE'}) > 0; $$info{YEAR} = $tag->{'YEAR'} if length($tag->{'YEAR'}) > 0; } } elsif ($audio_codec eq 'flac') { my $flac = Audio::FLAC::Header->new($file); my $tag = $flac->tags(); if (keys %{$tag}) { $$info{ARTIST} = $tag->{'ARTIST'} if defined($tag->{'ARTIST'}); $$info{ALBUM} = $tag->{'ALBUM'} if defined($tag->{'ALBUM'}); $$info{TRACKNUM} = $tag->{'TRACKNUMBER'} if defined($tag->{'TRACKNUMBER'}); $$info{TITLE} = $tag->{'TITLE'} if defined($tag->{'TITLE'}); $$info{GENRE} = $tag->{'GENRE'} if defined($tag->{'GENRE'}); $$info{YEAR} = $tag->{'DATE'} if defined($tag->{'DATE'}); } } elsif ($audio_codec eq 'vorbis') { my $ogg = Ogg::Vorbis::Header::PurePerl->new($file); ($$info{ARTIST}) = $ogg->comment('artist') if $ogg->comment('artist'); ($$info{ALBUM}) = $ogg->comment('album') if $ogg->comment('album'); ($$info{TRACKNUM}) = $ogg->comment('tracknumber') if $ogg->comment('tracknumber'); ($$info{TITLE}) = $ogg->comment('title') if $ogg->comment('title'); ($$info{GENRE}) = $ogg->comment('genre') if $ogg->comment('genre'); ($$info{YEAR}) = $ogg->comment('year') if $ogg->comment('year'); } # TODO ac3 # TODO wav return 1; } # # OLD FUNCTIONS # #sub audio_codec_by_beautiful_name #{ # my $beautiful_name = shift; # foreach my $audio_codec (keys %AUDIO_CODECS) # { # return $audio_codec if $AUDIO_CODECS{$audio_codec} eq $beautiful_name; # } # return undef; #} # #sub audio_codec_by_name #{ # my $name = shift; # return $AUDIO_CODECS{$name} if defined($AUDIO_CODECS{$name}); # return undef; #} # #sub video_codec_by_beautiful_name #{ # my $beautiful_name = shift; # foreach my $video_codec (keys %VIDEO_CODECS) # { # return $video_codec if $VIDEO_CODECS{$video_codec} eq $beautiful_name; # } # return undef; #} # #sub container_by_beautiful_name #{ # my $beautiful_name = shift; # return $beautiful_name if defined($CONTAINER{$beautiful_name}); # return undef; #} # #sub container_supports_audio_codec #{ # my $container = shift; # my $codec = shift; # return 1 if grep(/^$codec$/, @{$CONTAINER{$container}->{AudioCodecs}}); # return 0; #} # #sub container_supports_audio #{ # my $container = shift; # # return 0 unless defined($container); # return scalar(@{$CONTAINER{$container}->{AudioCodecs}}); #} # #sub container_supports_video #{ # my $container = shift; # # return 0 unless defined($container); # return scalar(@{$CONTAINER{$container}->{VideoCodecs}}); #} 1; pDLNA/usr/lib/perl5/PDLNA/pDLNA.png0000700000175000017500000015537513366114774015627 0ustar geumageumaPNG  IHDR\rf pHYs   OiCCPPhotoshop ICC profilexڝSgTS=BKKoR RB&*! J!QEEȠQ, !{kּ> H3Q5 B.@ $pd!s#~<<+"x M0B\t8K@zB@F&S`cbP-`'{[! eDh;VEX0fK9-0IWfH  0Q){`##xFW<+*x<$9E[-qWW.(I+6aa@.y24x6_-"bbϫp@t~,/;m%h^ uf@Wp~<5j>{-]cK'Xto(hw?G%fIq^D$.Tʳ?D*A, `6B$BB dr`)B(Ͱ*`/@4Qhp.U=pa( Aa!ڈbX#!H$ ɈQ"K5H1RT UH=r9\F;2G1Q= C7F dt1r=6Ыhڏ>C03l0.B8, c˱" VcϱwE 6wB aAHXLXNH $4 7 Q'"K&b21XH,#/{C7$C2'ITFnR#,4H#dk9, +ȅ3![ b@qS(RjJ4e2AURݨT5ZBRQ4u9̓IKhhitݕNWGw Ljg(gwLӋT071oUX**| J&*/Tު UUT^S}FU3S ԖUPSSg;goT?~YYLOCQ_ cx,!k u5&|v*=9C3J3WRf?qtN (~))4L1e\kXHQG6EYAJ'\'GgSSݧ M=:.kDwn^Loy}/TmG X $ <5qo</QC]@Caaᄑ.ȽJtq]zۯ6iܟ4)Y3sCQ? 0k߬~OCOg#/c/Wװwa>>r><72Y_7ȷOo_C#dz%gA[z|!?:eAAA!h쐭!ΑiP~aa~ 'W?pX15wCsDDDޛg1O9-J5*>.j<74?.fYXXIlK9.*6nl {/]py.,:@LN8A*%w% yg"/6шC\*NH*Mz쑼5y$3,幄'L Lݛ:v m2=:1qB!Mggfvˬen/kY- BTZ(*geWf͉9+̳ې7ᒶKW-X潬j9(xoʿܔĹdff-[n ڴ VE/(ۻCɾUUMfeI?m]Nmq#׹=TR+Gw- 6 U#pDy  :v{vg/jBFS[b[O>zG499?rCd&ˮ/~јѡ򗓿m|x31^VwwO| (hSЧc3- cHRMz%u0`:o_F(IDATxweYU/]sozr&Mr|`BO=<)=$f`30=9uNn8c٧jt3w gw}KxA|kǺssN{k|<#x&Ϗ(IGK\ݔSkuL}ſ_HBxk ?w_O]KRx$<*=zU|\}l)W B|H݊Ww_= .ReH `cHbffnVO^XYYoeLN\﹯Ϗ( *:ٗx$}}t!_?Ͼ/|=^6"*17S,X[em0ۻ ?8|4D$lpюsA/x'}WoTi͸YѴ4mn543S7Y%~/rA{~~JY `iӻ ih'F'am *@khmj(*s;-薓t32YRP Rb"[#&")m+[/)u&)4=ɠi÷$OwO(%JQ 6'5t6hMmNQ7FӰ=ՀOfmxw 0A2>|)B2G' E(E5 ")hM>o~ʶfii׼[^w?vX$~.AJu3$G~'ʀvV^v3ЧW (qݝXt2E2Fcژ ׭ zuh\o/jiQ`Q(Kd"6 JU(*ȴ D"(2اTf:Uzt=WܿoE$&I MO C%GF>OKsVݽ{fff*fӷ/biBpr7F]4dڢi&{r@. n`ҦwI ؚ}:k$R>YBdfP&AP+S*@JASg]8t˳LE%2pӅhIM%7wOBmgjӫlw1j-&5c2m0nZLk6IenMq?] >9dO?>}| 70}29 $4PA)@)EI( Sm-*s,^m˟G d}*AUڃDHظRoV=Gyff)D(<4]{'vDɴŤO5V &ui me7*)%' O9 ިw&/II6W+Zw4 Il*;-((K l" UTJTU\qdg?I`d b# `/w]WY{Vpx1]˘~45ehb Q%訶'?9ҐMD%N, WɼAYf*C TT8Mo:G]I"%D~%b$__}5O{_)OݾԂt--'-FSv`д:f6IulÞI,t;m. ?M+E yCޑU[Af:& mK$$<0'(شAi,V2 P%6u/:c-o_dA#lz&_1~/z.JQ[aR[M&˓ZcZxN𾷶_[j BʗĶ${2D&IH)m18(Q `I2IEI7S=}~ }h|}Y2c"ڗKAk͞wdrno+ \wb(=x&2$֎$ty>!H-Z 3E[  fzO;v"vc21Dl d** 25s3xOO~" LD{/{x$+.}fviZ،V&[5XX2&趚V\`)W"Pk?)ٓ; )ˮ #*D'/:-3"GHHu/naAR%%J *@ \`9~ճ[^~&\2H+e[H8SP~ֻ~sEnCK5F- G V,4ZN qð_v9w<-~=GL$K-"M(>I)Tf 5ApӲnRUTPTJC&(fpᙛǪeo?J@aS </T{OP= 5-,.XLM5Fc.q\'/}: ֶ Aߧ'́ ZXY$&ǕkYךC1U0)T*AjVf@ ^t#?}M*H+T <ϮkM @]2V&[5_i<6DiЍWs SDE46g0:=eD}uG˲^T==;S=iBTkA&9%=jY4_Tn$bl<ϯf򉗾 c@R.âO?ESߑJі;No6IQKf^;]y'qRJQSpX= OF%~zqfCg?AV>XRT$K$M@S RC\y֕?~ů$QƆѤH@&ӒPݻț_B+YGG F3۟j[Al7A9O Q5Ⱦ6?yԿޚĖnd(N|BwY|/f#Zo rZoR-O"OԟK:XOxYrd'y_$f}N,[3mh(QX(~Hi+mT4-A9*pގ-+_*i"R l.p @+'Sֻ-ߵËfwpƾ#5lVtVvD"6RShAtwY` !A5]1() ٥`2c5&׷3XBǃ i@ 0Snш|"#I⒉htx]g 1x{Ͻ_Sl[m0`צԕ ~e?+5yߞ#>?GG-}1FsxƑ% 56hc2z|$gdNLKH'G|2L,轎{*Ԣӂ %x`J0TǓ87̣` P ttcO`J$A-A @ P΢n=f?ʧ{R nzǿリz&wQYi22 =NK>Kd4=zٶG2hbR'` D-wG4\uDA$'CUVssy2Ѥ]X':%>Z$ {4G\tE (E jPp8wȕ?ik V%48?809T#9d? >m4;|nKr8%=UЇ=kII/N;DkWs-QUCzg!8Q <D5}əE$_t?!PlFH/ t3, X:zd7~-6o=%DP=z,|>cGk_b+o+4ATsrEQhRo y%[3e/Q{L;ӌTk=qSxI&>q̊`RZ\'XL = 'm__Nm9w{>ROɑXW%@%(kG`nl+v.)я?' vz'ֻ^yH/>8ʤł^26k,s<yѸ爾ЕdX qQG|ÕiE NDzpI1R͑F`nYɰe4j*/WhƎ5#9Pp!8]A_XL.`?X]~3xņ3hbNfԷG595wR7%mT4g~Ͳ"H6AE|@՜MW_?LxWp/= .Zw˓j\02M9,'DF nLхAK7&֭]ah`bmcn}6C;B$C@ QJ9Q~I4yV`ѧ3r dOmഭ3SpegKLmm?q_;!ʲ;.EUUï(p˝{ƍƝTa3*=M mȝ4 `#?}3F^]: c=k;6hR)K=;)&tRZS7Vu=4 k{_YEQpUBT3L5 ͌ {y`fmd9}_K-Mȑ#9?w:qP%X X>I@)[0ɉkb2r5ȝk,r2`uUG}6=oo?w|7z=ba p^P2;ު6}n -,8l;E %ST0QO=Ga? bGA=^B=@5zݶhƔ'TK2aX7֜9OyxC4NzJ Ղ{G6~sc,B3GhfBSM k1ّsX[@D9%SexQE7 y)TN{ZE h'GP76<$f֕.OOrчR;n{.788au7=_'lGx@v)PRxctxdzh cA^\,0O^|a0N=c _-};q%w^bC3YF3$ж5t;nj6ALh6*؜_ _1݇Hy'|,aG[^s$ šYĪBɬІ'F{Ł[LF\C9l&vyZ+ľ8%%W@hzf:BShIu Fk@Fj_O_(=mE4hm[p6|s} 0Sh+h&+ht3ALLhkl0 dv qC b1~JPv[Sp3F;]D;>)5?JXgi1ѧ|m޴?Pca8\Rm8\`t =739@\ Y'nAsOGhSS֖mclQi mqʦEOmZoD5s75u6֏~.ܱT1t3FL[aN$bKݓ\ҥ>8(I.B#C$tz|KyO _} MI Fúz7L{LZy%0;FPn>B2PVZkƵGLͩ6SmӘa_})~.8sK's%WP'yk.E;YA=v@7SVUKaHJrE?G0}vvK,IQ"M^)td5U mH nSDay.Z6,?\Qc #;2]_v1@ly[c[X&nB7U;__q5fYITUAx ?b[lk4nf#Cpjm;=PG`izmgerBp"C\g=^@;:R`x\6752-/p(K{0IGՈ)0'ܵtxdy9?qEωv@U8ыs@Z}Ùg=DcqŔGWڞ }ZzDSJ@4$%7x`>ԗ_m5|s=/-SP}>h t=IVZLbyXTR0rxQ9)6"#Mng3kp3#4{_'LF );zczt%ZnqhhzOEY.Dž,p$$2LQaLHy@c<cv W8*o6ȩLR' KX/[l]j,5G8j12QZ\&t4"U\ K#$)e%~.J22z595hxw}mg#@wKG_$ux)/XhZN8vWaqt!IM`b!{ŝwE'4% z)~[[?>q"w9_x3P贙ۉ9oB:QOw,£2 )X&d0U~NC%&AB׎@ߘTs,xh*]U7;xqtKciͦ$K:/@ 73Ud B1g}{6@ָSC/{vo}~Z?}3.gm3lڴM35q8CbY& a$VXA! x#z}U^Rؼ<` ,Eی7={K3Ujqa'V#l۶w2X58`ilz9qq)cy Ε TKӐE9.5m~f_yK073e}}7_dO/2Y7`NZ`N-Kbw v8R2j|I-y3./:gـ4S@Q_\oJi#+-dhļza#$p,9Zgw=4!&b~՚VhP1#/ǎӶzɜ o">wgA{* %o/C9g~cij Z e$Pa.y]q:"Ed8(щoMmdvBs mThzO|g>O5>s'\\gEq0[]i\cidJj`ѽXx:nHGZ:E#AX]v#wt(?~ً'\vagDO4vݏk?~K>R%@dxTa{LnAڼ;N݊]8YOE'\^+݁t @Y%!HAdmT!psrh,Aǀa% .UZ5jn׼~oo?MT  G)'XceJqIcgנH:5ځH0))CH}Zq 6e*aސ?6xgzId>~x?PV~΁HL)k59jj7]3]ya  Hΰ &s=2|׷(;;^ϵ +wT(YBQI_V!TT,%eVQAޗ>_n>QxGKf @%L/ژHt2~cP5n#bS1bg,i?}{6'D0U@OUU]ǘ֌q+-V&-ꚅjw$~ANjI#dr[_| 96`~~D>~On3?AQT& E9**.U'(8ף+#ٶSp9@PEӸoa|7=uǃ)7oYBV])APTkCW"BH "y'y"F"\o. 0@3RS=E[,CMB >ӎֵj_G-F+ ZL4# Ph)!pG=ez$m鿔ByLQ$m@OJPJewXO}E1*b47{(9 8bvFN붅.kE *j|;QEO:a$f5phЂjyuc0BYu"*1q |yz S2?ɴa{zj֟'PxO}'?;Ov jU@NY9_oIcziF],%c!$Gp9QfG.ѳf-HJi$|iA;Qoiin (QV36(!T5@Q L"( @֐Üd{!PحhKWn/RS45d"qe>%¨*Ff/@M<( 0'FRI.@qWﲺto(!f#J)tdp˖$' FT [8 hb& #i-vs#|UHjeCߝciJ @xRӬW߿S;^Z| ;i?E5E9`8rfMPn`8j8r8j0j0r0j0fQCT &I*$L)q3 Q ((sx>?j^sl@#6mm88"5}vdttJI [a>I@ ;E,;Pԧ=cW0h@N\rOb{JNRqvC`c qGp,\s2pki,(! jʙy fQ $Y Te8|  EUyU~D1cI5c,?tc/G6&ZV5sX'':9ux`uWEĀhp=B;Yt3_ E3YuQH_{30j--VZLS8hFG> :Bk1~#ӌX G<ۿh|_ û&[/i>3oN<ʡ j|o52zY E Ax(QxRUXUP@JBQPm?. bTo}PNIW\w*;5?09?uIx Sm%s -[ C,[x?cI (OP -.5XhY+u:gbДT J@FA8;lWsMsFqx7L>74n5D1AiKwRj`gUpuPsA҃h\XC)c0J V%Yp} uW+}qEjE jkIl6@QYN>IL{ݖ$Hn @BAe? 6AWLD%0U@mc P's_\yҢn\%;] 4E~c]}N#nҟ,5!kmr^ }|[ߕpp63fQg 8B(T U/Y0 ϼZ3tY.J/ (*| ?(Ϡήh_vYFmp7^w g\]$52w 6H]Kqgk؉}8 P'sEqMP7屑^:,+y tSYPZPIt$uӕ`syL!O;Vr8V{^5@UyΣ-AaAY P(7SSk=%oJ&+?-HIQ">X(f0yqaqZG%loOiSgq[wbQvv\`?FMX7cE AW+ 8O=V>ѕpkJwL]VHuH?4(w5Ғ BGnS ʁ86_*K%HۤUx %ަd;BtɅZnY>?{'N= 6|OU6&+WVfmG- 8}ua (euVB *wL`n 8]B3>k~?R\ ~`p٭1mKFꈡo Y%sBM{nqei!@V PdM8(N\a8y?CxAw}8*ΏHSAQV(ҏ=IoߊDK5هMf-7 };PJC;xݶon]zoKF HCVnFa{T$N|DDLt;#@T/:`QI#hA)~IUTUI> X_ wIOn#>s2tN omIf9qKh i)!e LP0%`t&cM(,] xK-0\;u$vsā n '';jX&n-ۀz ] * } M1m+Q{LM/AJ^>cf^@ymD_v+0JT>%s"hSXN[Rd'/Nk8y?66AiX'91E= `shϐ%Z#J*C-|fgT'6auJ,U΂s&K 68t O|ͻ-q`P+W7W& 6saĩ8tRq9S^7N]Nr=pڇOzq{ )+YZAqBj,FgD~;2W't^N)n2kJISڰ)+x-[liȶ-swn>}Zi6{'ٗGQ+ fVfm+ މJMgDcY#D# hIAѬIXV2 qWɟ @>N5m6K?Fq0ˍ%Jbs_bCBqiNH~ oWj;o'Y '"ZDAv)9%5ς#@ҔmQ.uÁn~І${l*Pׁ"7sa_䛯ZƑ687zZ M!uޅ@5چ1jLk[:Q\Χkԩ[}{DbvUF޸SB#{l[apTqq,Fn@vwVdcY\`l*amVqDI6AKϴiȞg^ ' sD(6,B=ppAZ`:75fdS3٧fLii$r r-ii)AGX!GA AI%79CeV=S(gD`dgܡ2"٤c>y=:Ib:*,AH##j4s6gm3p9dJc&#h~aA2&^eELI:9% TҞb)^\a6:l aOoE1Aj t zu d\ɫps螞>>} d8&"F2I\%u,1 .p|2[~j6s g銌HiH0(m-n#`-\m Phƴ6,@-`,|  s?g.^ MR(uf#=rszyBj:,8ܝa`NTvV$.vяH-dIQiyBucz4S-5tN9|%.w*SQ`ZNPU`gL?'aЎvwŴ씛<'K^fL Pz~_wb2&3H$sv)>A&V+HS&I5]>uY@݀?'>q@$"/<ҝ_%ttĽ3byIz؈e+^ #y-OTbh:ZFU;3Nc\U"{+9-[}SQZcܴ+$u6!'S<ǝe݁ tZ{Wirt_n9&3'#5WZ XWiM<KHTyWQkV'<ݹ&*1%bHQZN2 ϔS.ۍHs3؞w H L*ֹ`Η7:Ǿ~G2W5"ʽ!NtW Hk rIR5U̫w'rUluuD;ˌ( kՁ̩9-dx%[c@&Gw& x9Ï8:e{d+ŲR,\n^`3r.zAO('6@Q׌V#FeA)1)@Zpa)LLJFAZ|Mģ)cFD%+ tRdUGINԗ PQZKF!erBSj$sL^ иl|o)ͻLJ̮ qM盅XG ֡s0DΗ~嗰E1'*9}%2iZ3Z͘6V[JTcXXǨ;dH(@%~";HBB &$ 1> j =tNd!8t%h-D'e{ =Y'Hz[Bf1I29eYDziH\S6 Gހܭb @#+&Z`fXg @_sH֘49je/'Õ:RenppE,#a,.o1^O5o92ia_EL=@]EY%23hp\yя5׊~Zj.@l؁Vϱ>X>s؅PQ)xmFX?ڞDDLP9u2 mY* ;زu޳Vk4-nZԵ·şe@%ͺ1 ROD,iS I^)dGm ܃c\p΂r$YHN#L9sMӱK;U[sTv-y}O5O B 9ʑZ Ss2wUV&0EjJD='HlՏN+/N~*pUUgXlhZ6f$t~DqF=8~YOdA%d)2KQEIG*V PQwRdZk8p:wOdϢѶ[DMv_S3w#F9y[X\FgfKl:N(hɊO((7Aϋٽy[vb04ӆѴlwoV=UHmPLN;:ݜ^!{`xpy%p.eAǍ-kz=>zH YFvzE¬mǐc5u.N$sNY*qO+_!ÌDrK;d?ڋT+i݈k:OQ K~ /P"U,kDvU?gR2 ]y!?u:-^[&P ֲɠ UJ봙JW~ޞxTޑ&l JYVedHt3Jk׏#@g1<-3u H%J#? v;y̑ f6Z <@4Fd)"~ b!MWn[8_$ g<뻖 uBk$9tQjNk=X9deXt8P)8}TDXWWHۗȬ]d^aRNܖ eぱivGoRx4]s.r̽ dTCUA NR;(\NkE57K M!M1gxMHS9$i ?[=r[yu^Hy> &@{m{:+]J/ % LQ>餕]k`?uaG4g0$ C;cZqrī:fqꮸgD3Gc sdnk PuUHLʔ@DU@mr/{v<1%SG,bx"*C#DP ^!#XdžYBY@zAw ̤RbʡXnӱ<NjBҟB$8OI٪n&:z_B^X{|dԳ]8N;%gjbե#SE^K4`2ntC_?ӣ 2_rD(y; OJb(dv.里_tB:1g"j ~V;xH׵gxϑu&-P}C \onJP;N>9DGzMDr^D#tD)cwfN. gmu:IV  "L?RA+#0Ui8; 0B_Q3. ,,,lHo` D@œri[St}&U05)K [(cD= ^!:@!ecAAYY<7Nd7}Tu z KO'vLrCUnWbv& g;4kK\xv߿]^~σ{^TaqC!YiE-cE'wPMhvԟH@ Zs9(e|'@L$<ա! ufZ',:_̩3~${<|seg܆1w)#e'bq#D 39}ǕJu]q04KNG]׫bL8xxɔ0'R&U!V A͇\eJ_WDўŠHe1+#))!$Fa2 r >(&N$nJZɳ3%btxU* ձ7:/OVdIHܾ@2#Qq]E*g`U(ږZk\sؿ}r}{"zAA7N8՘ \4OՇ#['C9ٲ?#ߧ*1 :z)/]wCd쿥Uj9vS!gmyYi)̮!羇, ՗3y@m~'} ]T"CŬM9GCw ֔Z3VW]vmHQanܘ93։a̐L'"jHTl9U_>tD 쨜)^%$M$'A`:6-Y_∤XDQ/LbdI3 , S 2$rc^j\Q㟷0q!dB-y,D\v6fǕgf>KQ *@ERca-8\}&y)M^|iJ!*k(v rh3طLԙ՛F!` /tDԂ#9w~7u9'CYK;[ A~_\B3lDc,mF!cjM 5]va:K ~]Ѷ/:@ *cK,@ٹ[Pw=>gck@KqHF8u[>f>P(YAj[,yvN)4R{9kf>I??\'7$z Ⱪ͋)ũ zEH9jv*A'" ~5W|px2TtU$ ZTh_$2T[!Ԍqe(0@{F:~ᴍ]f).#]F 0!cw})tRwn5~Fi /_RW+k˩%tJglF5<:h\sY ®]ZK?6bo+U"Ka'͔j ^E YwxN2:kd*|0Er.΢6r/L[qN7i.t#P[m .lQe_/oެ R_&iQ;e.`DkGQaQMTvo |Ʒ,OFawcRk)(U_RP(b/% F CowTdβ=h Q}tC]P"L%×)7N5mؐiW:`a*D@bu q &S*8bS$d@q.d܌Na-Fҙ"pC2پ8z߃n9äBZi\ pyr- ۗe|{*T&vؿաLnTk:]'d65f9j8(w/n`AO0/ݮN!!JD4bJ܈=͗{fΖ6'fdNGPgE0TqkWGdW \iܕ_ϲ3ѣnq=(~g+* zpJ! 7 LoT(BU BBLaUOZ:C)e?Z |Q#$;-)6˄Fak P%9Bok=T~;.9Lp@7S覶6&mZ3t:>Y:@q*QF))FJ ۭ˿J~kXk>yW"x$̑#AȈי ݠY\"VXG>W*F=6_P(J E!Q,"lAwf|{A9n Uyb((53Vg^sf+KEޠ&?/hm&hZ3V-kDQʎXNyX8͈KZؒY%]ƘG^v { Ч*J,p_“ J4 o9GϔT9zqnz koJ@>bzk~ N@)B"9Hك:ЁҲ#Õ?ՇNNc>CVO$M꾗'K9&$ՋqA4I4SAঅfSh57&ҟlB0yIl9L1^Kq3LO`Z7{ϕ%(4Uʞ*Ȅl՞tVogwE^t`g}bN狮 *8|LJ ox\EdB%Cپt rJ $s 4EF$ZgZ; b2r<Z?C߄~h1M=FLcZtB/ZbcR)9=aA5 |;ѦSt5nv??/ލf/}WRG PL)'2J9f;HRVbmhGb5GCi϶TTrChe o`@9)43(퀈*mK̫kS7 u1]jvB<d&65M|UVx׵7RG Uh ̚P؄b#TS?K&'R; \Ba_ ?`vti7/`i!Fq%(f?wS9u>De'¸jON~w+3mVO58,-+IzZ}xwO D]=9D":B#u[/DDX4^h.>18Wq#03 ,4CLĥG6v^ ES'׮ʲ!VqgnƯ0/~tꆡ0AJ~[0[0 <8gD_Oy]#ݵXk~WPaRm).$@QgP9,lEݸ" {֞ɴYo@sl 0g^"\x64[@7S;6CHEZK##vY'jBXn-~q_^;}< v޳DCa*UTkb@ K(3uXSxiUwl(( X($y :x wJsה)6b2;ALRJs]3Pt><+mA3QOGh1'8Nmm*m+hpl;)֖ȭ xpcX~m'?v~ > !_@9=UQPUr (:{rsc4^1v^";D\N(]I?AzgEG `n/?o;\RJ IN%dȣEDIH` %BklBiK4F48ck?x# =EQu RڢRH2XlLSzv2[/|]E#\iM6) @*N6F;`jWRz2ߎ'uj}-*P,ҿMRe,3ߋTT4y0(Qt"YG0@3N'q E ߓ|k7:Vw|ϟͷ* EkifCٱ}[b!37~-.ß3_Yw@*V]9]#UݎFާCA'D,Jb*UrL6MsPjPaP(]72vh$mZRP4v4J-z^4fpqǐXh ixcuO?p]hJP;bL`ԎK`N_x9rIq_qha~=9UieWv%dH䕢c`tșc>^m1U9z; @9؅,5MgOe^ő6hђ3@"l-<CNbL.^{~qn<@btgy?Z_ٗ?od M4A!Wcit;-@ ᛞsp뭷_Iص nSx]}I%#`T N KKQ@+ێ 4*ȳT57ݟco WO_}|JBqtSAqq,A ɵ! N!3ޅ|C%!ɲVqJ%:Ey9rϹt|?Ot7>yXL*N0PA9{a \q~Q5qkO}FA7-f"ix{*tS/r9Sd@Wb&-Xֿ{ͧrdm@ @?9}˪(aP(("wJ#OSɏvDU@ ɅiB3jL?$?{"'A]i/wl\tΩv§? ^|b 1O9xVZbރ~;MIɞ5~Vr&gP f9 &WdqmWMDPVH&QOhpIIzфJ)5i-LCx7;I\bo,ڥ ? _o?Os:2y-c߾}`flǙmSxr)]CJƇvtB}~&ZypϜpTY2+#-:dTG: $7\ԤsjwIATLk  $x*gM&Ψ`quEGdeI(IdH*J6C5%0IG)9ZO1BbǼVz~_x9 R{3~gg}êf"= fwangɐ}>ɛqCwmU@e_E!eJ(̖N5È)NE2" Ӭ\a_h:o×2ap޾@r {?|pfP*ڂ ;yRN> [n~ce#[lH^6J|׳oiP7EXU"|7c={=¯-]+O~7[u!-GH]`/G:Aq{yc neP |&MP*Dn+˚-2PΪhNTXsPA QH_.cDrX, A ,NB<#/V'C|9'o o@ Pwݧ!/HF"Kn\H™yBObVB9U(s,N(dWiܫY NZ/e#5f7ЈY/4փuc{H*dJ}t(A 9u㧷 ?XWQwݏ?ƴn,C`V |7{;-IߣgN~CD,PN "3usrXF#0:W.MjBQT(4cOY49g 9 hfR U -efz,-mDű^UQ: ~K*%JCwe19W t5_-r]|7u. ^֑3>י&@رT8}nswO uŸ1rjY*˘ۤ]$FM8|n^'i L>ɏϜEa TÎ*!^'o$ͱ[J+R߿D A =0( ׶߽NwdC'm$˿}{,}~5DQ o>ݭ:Rq- U({P*d?OB-IR̢lη  %e'Pmhn}3.'b:pW*ֱh97; :f0V>y}sFNJZŸqxCK-_z>:?rhA骀*Nd%A쁈 N8D`֑bt wYRYGyZ"p~8;P%PT)@W X8 7KU)]9c;1O6ɐ}sO杻lN|J``v_ ȗK1謓'kyb u1gςPO蚋"FC<ʙ-_U[Zͳ/<ۏ P qYI_'D>݃}d4Ĕ@%q|w@Q+-䘲I "HGl'石o呢HRYs n3lEzg]ZǮy(Q@*QQ [^*lkO&H[HqI-& `)7S" i(I` E* G :C3@o]8r*SaêDh%N7+7NeߑȦ}#;6d׏#H"!?bZNӀvۊ塣S7OO, aII>ԸKôf;+ATBe 73GauR)yHIW^Xw[BrҟZ9V6P P P7a{_2ڛW$\uST°RT ZeLa$g"0IޜM(fZ!AfFW؇*gr䰾uFB~l3VA >v5݁'_vΚCU@UA#>Ooxg'рd;S"^HR6'hS9~vcqpJžk>?[$<yeFlL 0JZ hR-+wmЉj|hS$/6'Ǒg@ Mmy*03㼳Oga9GWN)>|Ã)+/9[6<,z/ރ/ݽ;Ua5rAګ %!z/\S,wh4Gl?ot7EFo~!۟;;-D4ߢ26&` m|ؽk׻bmİ2uON>fM.11b ³_dESP c]ivft ;WT@kWD߅ vl\xT9]\]ŭw#K *PCĘSU&$:Sy_60XJdCsG[ 'X*+Kye\%93 w4 ~$ }mK~?q[oTVSmzBG x#PtH^3wPaܢH92 \~&!qfCA_PHGdB: Z^UUh=wv2K=矵 uʆ}sw޻;PQX}:UA d PiAžAsP΋cڗG] ۀ}>iN@hj/ iUb V?_f=qtqqТPRPՌV>MQׯ*$+U|I 6K!DCwPt@wF&DeZC> FŸ[OTM7q_l5Ba8PU5 0P8DG`7Aǜ.ߛ-qq0ađBxtվonX\Zʗ{$JamY|}xJh])HPnMc<j[S&.X(,~b`x! ʞ^κyٿ?K[I]^Sҗϗ^r'ɭBI}猠y ]%`[qd خ5t?Ɵ?=EAAɴExå/H_%,Oxā Sߠ#2J`,st$T64k(4 (jV Ji 6 ||4[cu}T"HK`u*_vՂUD+Gb.$r\ 4Hth?Δ<Jc<ɖ dyf3ۥݷ9/}, zzUf T̠rQaGZ̝LK)qb$v"TӀbi &%"ӌyxr^_0{R:# 55H H`݀u 6 Mb#l%+ R W 2-,V[w~$Qx%\Ҫ;K^ISjM@2R5!sn, O Ql[ɜLߊ屸i`?roV*0(Hp2B#[rnODAR)jɢQ$&ɢlXoo< STԂL A%H7`](`O~n?葓] CN)(*BU`׫'+C2ll8|ѮHAI-CK|"[%Y-7\}'>_1VRKIn'2b0jvt1N\hU6 /W\pMUQbfPb8hP-Z -ʎHXf?V7) BK:IAzC*!Pbz N+`h?2J('JPLiQ!PD>ؘ~'ZyFtDH}WC>18d)^BKltv>,Q^ΛF*}, (f;gw:ZZ60}UG;`PbvP`-2r&zs~Y p(((>lJR@I/pd 6(O[%i_f0YuJ(6m[P%ꀸ Ʈ,fr<;HCE q?u#/ :2XtI@bw߶>K4W `@;2(V3`QrIqo}ܬgT6Svzag謇vOJuø:zt(5~>CL#FA Xv4S:E潇*Aj`Nuj9eN>r0Z|{/ S(+ Hπ~CiRX9;z~Z? 5d1(׫G\(d@d͙7p#k0(irX1C5 Vj6{{J>7k-S[n`4|?mRR#8fW@Q(+ a0/"aeuMRJjP1VGYp'GbPa !2'u':.[#* ? !ɮJ0̿HА4{ VF諵t눶˺T}}l6og#ÐA)j"fZ Rf|zASP8(hS~b}jf OEL$>OX ӾYMBYVT(pxYaD huF %$\|C6Z{kO}yFnMֶܶJhmU)D'EkGi__/ۛnڜ{'-~y$> ֵf$d3KDZaSOK)]E9cSP͟W;9O8fFcAqfn~$dH#F[̙uޔ_<0:.GBv6x }Ӻ5kh L0*Oin[V ,DWǕThŽ@ Z$6&Q>.muL㓂yC5F t̀V]:ңX-_tsù ?$'y`S~PyT[1tVy*HN(O (L}%߻繷̔Uư.Q7ed  CVP&)YEreQE@UMH6ʩ'?۷o~ ,k>hRy%^3Rqg_ux'LkxG$"H($A,D(*;?ܶso9$ժ~o<%oҺ`0Lbڴ[S(ɢ QF 1kF5%4 D}1R2FM>tU1xx~oygͶ-ݾ4w̌;-JH ;E4Jgm݆~+ƒ"A&ꌶx;p,-L+`_ Ԟ0qQ_j ֠; ^Tĵ Tu=>hW3{DkəV)C̣ݎ3p{~xٿwN&s^9BQ * R9AgӟsI;y>.iF)CI yPvq[1;}?'bnX@5m̟nj&Y5m{vD[rg[l%m+Иڕ蹶%=ve=ug>"vmtխ=y4~Jᗩt+Cɥ1^+-HFgJqNzBXWP,٭l:_|.Fw82@ I`W-pۨJ6hMKoўE|  w@~>r Y!,g`=YǛ;@13~m/=n|3w/XrފgC[;&UickFn T#{)|f -a9iOHw[mJHXw*.=4Gaw`V?5 O|ׄU'ywMp]HյO (oP0|/8ڵ'Z䪀6 <}W(5@UUK  .‘׹7r#JË8{`M~U'nމ婿554M n\ch5t[[{M,VkpVSjm R߶1m,4hR'`s6ۇ={DyBUyѶaGd1)VwF>c\>TͶv 6#w / >盛${Fv7|Փ PTeaUb F'_07b42VPsu;h(/ U F[ ޷0AΪ0;T^O :rж&HA_JVS;jx25ɤm[Sk[v_lKuWu _p>goe/tیFS0=%EjV=gJ G?,BQ݆͠j(Ƿǯ c|djUSלs3Z Pb4J"P wAl/)rY E5.Š@^IYlnXO9!J=#2XI茁;F~}gzm{ZۅM𩝾 )s7n|/47ԏ@H6 O{ő#Gpz njڀ hcҁ~,ʅt`]ǿ|))RFYzCd7:Fg[\UyMAY 1T*I*nkɦ ,ac@톖^DnCAdvJ ʫ@X@ 3 L+Xs9:󼮿N DpU(% rH0 _ܫ?PT3\T3(  eZ+9=Å,X)eq8 =e7"A5pfD<7~nRUゔ K_kT\V:\~ S0sh? p㓅LJ~ >_BWRʣ!2;HnDF;b-e'pf/]3Mrքۗ*fg &gqݢr@]fuLf/`0&Fd %F*$\deoW'ƫ/|Upi3c(d&2717 կ~u5vm7c޽)q::vh`>6ssnD}<12KCNs÷|<ũW˙ zZ}}BϿ?~?i5H`Z3]ìKѳ|y1cN>jܫ奼u qb.03<8wDUpSڛz24k;Ddwf{{0^c @ʔx5ç>1x{{kzZ 36 ~*"#%d4gPgq1v[ Maf(g?z(e/e?U'So(3^}ɷmr`j`*Qa(bNf\vA -aL]wNkKҼ@o[yf<ӱg03$[s\؉ _u>~v<{ +3*`鴎cvk.Yܹ󄮵O* / pF?LAOg6;jzeVTe켪Ml|O '-W_RV Grmo ⵗ|Jcpvn$Nxw"2c` '  }D ·j,--`fܵw+|1cEUQxMO RdxR[Zc`43س$t 0\/>0G~A@<-ϔ8eN{Zc5'3 9ƃmSN;n;GwϝIRz  %PVsL%PV E)A+ e;mA{@ b:uBbTK\[opۃ#,ԑe;XEoyFl5+{ݨ w}]~9] žx$`ѡ dr J0 ̑sbUNl^jQpE{'GYgMuTxG_pw`|c37J.`"A$u x+mvZ_ߥ2U{?z3.~eY5%I{Ӯ]'b+- q+|v0T892T sjlwL6D.#Y Qmp˙~.v}/?uΏ)_ ߃Awe䝧}}+UhtzJqזCdLȉY 4) ^BI1HX~sSnB\[9}cG?ڕ ]m^]:"u`{?z~_}b]C`y-LT4 #4і)YXC'=kR**fz=_ZcJ 4k3_ ȴ~Gͯ/#T8jC-У)l/DoM}8 t~\o@fm۾~i&KN1MX-:V*)~q(a_ DIpNjq[ٻXM~~.s:Tm`"t`1^H@ MSmր RI 4&bBJ- ^Z*hBe2ewyo{c^{\$'33Yk=kizkJd@F+!ɯwHY), ;l Hy/X@3UQxQےTPPMEO{HW1;rd]Ka@DKM1p~(;)MuyH=6t[5P@oB+,??d>N-Ȁ@+S jm[A6жz gnml|QzyH^uAւxe A m fl`, -ƁdO:I-6ЖT%Hr-@ !)C?P$?h6}Y^8NG$/Ȁ+K\m%b`z]"|y ڒ?ߔ;%`虷y[:T`;ik &H\ HJ=ƔNy6m YʠvbJ-8EN^$ڟ 4yl;퀢{O@a0ڞtB>- @ce(b~ @shΞ\r/<)Ӆ ?`ce ~}سϾ?oez~tϮg7r}) [T%0Y]۹?M]=-Tm=C4ж-t .\rL !BYQS_׾MW@=T^)IF}iikчlii0+K`H zF_^k!=^9z=plEB[}Qd ĩ̺eO]{=0X?g{Kf1˰OA-8БtҤ E2:'2 !T{-ϕĊ/:Ak!nGaal%Cf|+} Bs@>szOGPawVwpm蓚sG-+Pce’sO|~%wv% U P3K+ wU5,ZiizveagdBzlNvG!d1 fҔ4hp?@G g &շ2Y$y^q@rrO!"2\ᴥo3PWL~_/ڹgQ<} }'l͗Zz;'IQ*xP&*!k|1}QWAH͈溾"v[̮ZQRe~.zۍ} So.UQO A+`CFv`>#i{['zV-It)AHQ/ !(УWI;R `'l פ(؉Aϝo=o&?il(1Oo|q[ (@׶9=*IJ: }u23V~ێ٢~P< B603%[x'J dɪ;Wf6ݮ@#.bz߶ R@n'TK 0@.?;%*]_cw?͇=t _3Yi CN~G>Uq[mxcVg #G%_!`iFG6q5dKB(5# P6KXY3E s!mi_$EtOB.(X{tZ@tGOC"'xk(H/ڴceVnz!?͐})Q|Z@$pTXU5SP1gڐ+zN{.>p߁1SH"=(@sG#$jd:$(Ta W4DtE:\n-aH h̪v , wc5$@/ d5p>ڵ7gPi5Z{V'ӛ PQ[ `m@$KMAz=c+>\`G+ J)%Q]h=_p<|"rwZ@RDebB@vPSSv@ua+xZiHh›؀ڝ ;I2-@>#*^! A'Ɩ da~I7> q9 X>m,jg ^>Yzߏ7sVY?c~JgK=A@H`W?,ƪ>!v5jRO=rY]zkl|͛9e]S $~9+Q\cN!'MQ/Rew-m=QbpĽ<` (%HY 荡Co[gzs{ xʔ?ϔ{*q@r ؖ`t^ ^US P\j?J\ *.n([5Џ7S ǩ Jx3'g`DҦH菽,Scиό!QέeCٷ_݇O|MWjڄ;@R-AoI5j57j `W.;#VSp*s%L+({/KZ`H*Yp"bvEeQN_(= M, uo+{ANju_'&ϳ~){ A G ?vx+_i̤[3-PG k}}ws*k= .A:{ *u&HD; yd_\V>c@:ã%}?%]͊@wBpUgMv>{y{!A<بVLܘm|q(o5bbUME@3vJՀm#VS|FΝe,w V'!?q$iȌ13Y=(z01P7 +-F' 1 0 ҜY]7=~p䁏^rk"s$JoMxpn Y;{7U)zfv*Muމ6Z [̗t,HϼB6?( KJ踍KZ.ŋI5R  Ҭ> z]Л!8)D?$Ӭry^m:/k l57?phTWV/KƮOZ ఆKw>BMMT!7"ajes,0DL4 .fR>)ATeD9b`M@џToQ͢"Y?5Oxiɏ'*`s^ 3O"s^voS]5PjۂV@*J.nf ||[Oq.^G-A)3?_A'>"[ݕ@ayz#3_hz]P VGo}ꧾM2>5Y`) !A}yoN(+M>_Y$oV'KܫNր=9Wf42ŭ30@F#@%f7l6 U6"]~.}zN ;)!+} L0ANQ@P\ިƧڪ%"+S$ UĘ iUTw ]=jZ`W2^{ j1KDdpĽb>G%N<] 'XsY4'kfe wEo~ 1s{/X[ p~`x7\?gR3Py΂A㕂Q {H#`hW ^$Eԥc0 ]aF>#. M`a˾Yե~1Xrp SGo XS?TM'E^ Im r K/WWU;T T=eCVN>&눎}-t "2^L6uKj6Q@@ #0B``JTArX'?0x隽U %26<mA` r, ̜G`}9@B1c/*P/ɾ}ZZahpn!#?.;EO}&eo`*7w[kɫ-=d.d(kż*mBAL_~UE9۵ LET5Ƹj#W DbȤ~hB`榟~]=4`24A/>U(}5yMe}>~HBx6C5o"] G~|.h/UيmU=HR;Pv "8J=Dm$BoEo썴`doT={SrIufW'2=zT m8q@,L)P]?P}==XдHtI ::@5bo J󱀔ZNb! $hsn˹~ޕ/{##E~>ȩuɌhwRor@` gs^'TMgIn ;W7bKIO5_ړ1!i328qd($ޖ:Z[@6>z_|=Ae>UJ}u*6@ r`{Or%;_8Pm#%lvi0>BLU-@w}鲽, P4ƓG~w̟:Ae{ x7K>ߟҁ /  )PP(A:ڏ'WW:E9=PJά$[ӌ]IpH)}EDj{ŗ}硣D_- Na5ҩpr|Vd`\;9r[4N"nVu_~_D6UtM>EqI.<3WrA RBߧ C?:יw # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use Proc::ProcessTable; use PDLNA::Config; use PDLNA::Daemon; use PDLNA::Database; use PDLNA::Log; sub get_proc_information { my %statistics = ( 'ppid' => 0, 'start' => 0, 'priority' => 0, 'pctcpu' => 0, 'vmsize' => 0, 'rssize' => 0, 'pctmem' => 0, ); my $proc = Proc::ProcessTable->new(); my %fields = map { $_ => 1 } $proc->fields; return undef unless exists $fields{'pid'}; my $pid = PDLNA::Daemon::read_pidfile($CONFIG{'PIDFILE'}); foreach my $process (@{$proc->table()}) { if ($process->pid() eq $pid) { $statistics{'ppid'} = $process->{ppid} if defined($process->{ppid}); $statistics{'start'} = $process->{start} if defined($process->{start}); $statistics{'priority'} = $process->{priority} if defined($process->{priority}); $statistics{'pctcpu'} = $process->{pctcpu} if defined($process->{pctcpu}); $statistics{'vmsize'} = $process->{size} if defined($process->{size}); $statistics{'vmsize'} = $process->{vmsize} if defined($process->{vmsize}); $statistics{'rssize'} = $process->{rss} if defined($process->{rss}); $statistics{'rssize'} = $process->{rssize} if defined($process->{rssize}); $statistics{'pctmem'} = $process->{pctmem} if defined($process->{pctmem}); last; } } return %statistics; } sub write_statistics_periodic { PDLNA::Log::log('Starting thread for writing statistics periodically.', 1, 'default'); while(1) { my $dbh = PDLNA::Database::connect(); $dbh->{AutoCommit} = 0; # # MEMORY # my %proc_info = get_proc_information(); PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO stat_mem (date, vms, rss) VALUES (?,?,?)', 'parameters' => [ time(), $proc_info{'vmsize'}, $proc_info{'rssize'}, ], }, ); # # MEDIA ITEMS # my ($audio_amount, $audio_size) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'media_type', 'audio'); my ($image_amount, $image_size) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'media_type', 'image'); my ($video_amount, $video_size) = PDLNA::ContentLibrary::get_amount_size_items_by($dbh, 'media_type', 'video'); PDLNA::Database::insert_db( $dbh, { 'query' => 'INSERT INTO stat_items (date, audio, audio_size, image, image_size, video, video_size) VALUES (?,?,?,?,?,?,?)', 'parameters' => [ time(), $audio_amount, $audio_size, $image_amount, $image_size, $video_amount, $video_size, ], }, ); $dbh->commit(); PDLNA::Database::disconnect($dbh); sleep 60; } } 1; pDLNA/usr/lib/perl5/PDLNA/Daemon.pm0000700000175000017500000000522413366114774015747 0ustar geumageumapackage PDLNA::Daemon; # # pDLNA - a perl DLNA media server # Copyright (C) 2010-2018 Stefan Heumader-Rainer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # use strict; use warnings; use POSIX qw(setsid); use Fcntl ':flock'; use PDLNA::Config; use PDLNA::Log; use PDLNA::SSDP; sub daemonize { my $SIG = shift; PDLNA::Log::log('Calling PDLNA::Daemon::daemonize().', 3, 'default'); my $ssdp = shift; # ugly, but works for now # # SIGNAL HANDLING GOT MESSED UP (currently not able to call ref of a function) # $SIG{'INT'} = sub { PDLNA::Log::log("Shutting down $CONFIG{'PROGRAM_NAME'} v".PDLNA::Config::print_version().". It may take some time ...", 0, 'default'); $$ssdp->send_byebye(4); remove_pidfile($CONFIG{'PIDFILE'}); exit(1); }; # $SIG{'INT'} = \&exit_daemon(); # $SIG{'HUP'} = \&exit_daemon(); # $SIG{'ABRT'} = \&exit_daemon(); # $SIG{'QUIT'} = \&exit_daemon(); # $SIG{'TRAP'} = \&exit_daemon(); # $SIG{'STOP'} = \&exit_daemon(); # $SIG{'TERM'} = \&exit_daemon(); $SIG{'TERM'} = sub { PDLNA::Log::log("Shutting down $CONFIG{'PROGRAM_NAME'} v".PDLNA::Config::print_version().". It may take some time ...", 0, 'default'); $$ssdp->send_byebye(4); remove_pidfile($CONFIG{'PIDFILE'}); exit(1); }; $SIG{'PIPE'} = 'IGNORE'; # SIGPIPE Problem: http://www.nntp.perl.org/group/perl.perl5.porters/2004/04/msg91204.html my $pid = fork; exit if $pid; die "Couldn't fork: $!" unless defined($pid); } sub exit_daemon { PDLNA::Log::log("Shutting down $CONFIG{'PROGRAM_NAME'} v".PDLNA::Config::print_version().". It may take some time ...", 0, 'default'); # $$ssdp->send_byebye(4); remove_pidfile($CONFIG{'PIDFILE'}); exit(1); } sub write_pidfile { my $pidfile = $_[0]; my $pid = $_[1]; open(FILE, ">$pidfile"); flock(FILE, LOCK_EX); print FILE $pid; flock(FILE, LOCK_UN); close(FILE); } sub read_pidfile { my $pidfile = $_[0]; my $pid = -1; if (-e $pidfile) { open(FILE, $pidfile); $pid = ; close(FILE); } chomp ($pid); return $pid; } sub remove_pidfile { my $pidfile = $_[0]; if (-e $pidfile) { unlink($pidfile); } } 1; pDLNA/TODO0000700000175000017500000000246012276452536011431 0ustar geumageuma- audio thumbnails (e.g. google search - what about limited requests by google) - audio thumbnails (images in the music folder?) - enable/disable webui (is it useful?) - webui: maybe we should do a webapp for remote control (ControlPoint) - webui: add authentication since it reveals more and more sensitive information - dvd support (basic support is existing) - seeking support (seeking works in most cases, why not in all? which ones (large files) ? - more subtitle support (text/x-subviewer) - transcode subtitle files - implement specificViews (samsung feature) - more external scripts (online picture services like picasa and so on, youtube, ...) - transcoding of videos - transcoding of images - per client transcoding profiles (currently only per ip address) - per client directory configuration - use multiple threads to crawl directories (multiple DBI objects, since DBI is not threadsafe, but glob is not threadsafe as well) - debian package, repo, rpm packages, ... - random music directory - more playlist support: Windows Media Player Playlist - set bookmark soap action (X_SetBookmark) - started, but tv does not send the requests ??? - ReuseAddr parameter for both SSDP sockets (working depends on installed modules and Perl version) - How to handle it? - add archives to the media library ??? - drop privileges pDLNA/VERSION0000700000175000017500000000002513366530760012001 0ustar geumageuma0.70.2 (2018-Nov-01) pDLNA/LICENSE0000700000175000017500000010451312127600402011726 0ustar geumageuma GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read .