Der nachfolgende Code schreibt das in eine Datei presets.xml für Bose-Boxen um. Kann leicht angepasst werden für andere Zwecke.
#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use Getopt::Long qw(GetOptions);
use LWP::UserAgent;
use URI;
use XML::LibXML;
use XML::Writer;
use IO::File;
# ---------------- CLI ----------------
my $location = undef; # Pflicht, z.B. http://192.168.0.254:49000/MediaServerDevDesc.xml
my $out_file = "presets.xml";
my $start_id = 1;
my $max_presets = 99;
my $timeout_s = 12;
my $debug = 0;
GetOptions(
"location=s" => \$location,
"out=s" => \$out_file,
"start=i" => \$start_id,
"max=i" => \$max_presets,
"timeout=i" => \$timeout_s,
"debug!" => \$debug,
) or die "Usage: $0 --location <URL> [--out presets.xml] [--start 1] [--max 99] [--timeout 12] [--debug]\n";
die "Fehlt: --location (z.B. http://192.168.0.254:49000/MediaServerDevDesc.xml)\n"
if !$location;
# ---------------- Helpers ----------------
sub norm { my $s = shift // ""; $s =~ s/^\s+|\s+$//g; return $s; }
sub lc_norm { return lc(norm(shift)); }
# ---------------- HTTP Client ----------------
my $ua = LWP::UserAgent->new(
agent => "fritz-favs-to-presets/1.0",
timeout => $timeout_s,
);
$ua->env_proxy;
# ---------------- 1) Device Description holen ----------------
my $desc_res = $ua->get($location);
die "GET DeviceDesc fehlgeschlagen: " . $desc_res->status_line . "\n"
if !$desc_res->is_success;
my $desc_xml = $desc_res->decoded_content;
my $desc_doc = XML::LibXML->load_xml(string => $desc_xml);
# Base-URL für relative controlURL
my $loc_uri = URI->new($location);
my $base = $loc_uri->scheme . "://" . $loc_uri->host_port;
# UDN (ohne uuid:)
my ($udn_node) = $desc_doc->findnodes('//*[local-name()="UDN"]');
my $udn = $udn_node ? norm($udn_node->textContent) : "";
$udn =~ s/^uuid://i;
die "Konnte UDN nicht aus DeviceDesc lesen.\n" if !$udn;
# ContentDirectory Service finden -> controlURL
my ($cd_service) = $desc_doc->findnodes(
'//*[local-name()="service"]/*[local-name()="serviceType" and contains(., "ContentDirectory:1")]/..'
);
die "Kein ContentDirectory:1 Service in DeviceDesc gefunden.\n" if !$cd_service;
my ($control_node) = $cd_service->findnodes('./*[local-name()="controlURL"]');
die "Kein controlURL im ContentDirectory Service.\n" if !$control_node;
my $control_url = norm($control_node->textContent);
$control_url = $base . $control_url if $control_url =~ m{^/};
print "Using FRITZ!Box ContentDirectory controlURL: $control_url\n" if $debug;
print "sourceAccount: $udn/0\n" if $debug;
# ---------------- 2) SOAP Browse ----------------
sub soap_browse {
my (%p) = @_;
my $object_id = $p{ObjectID} // "0";
my $flag = $p{BrowseFlag} // "BrowseDirectChildren";
my $body =
qq{<?xml version="1.0" encoding="utf-8"?>\n}
. qq{<s:Envelope xmlns:s="http://schemas.xmlsoap.org/soap/envelope/" s:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">\n}
. qq{ <s:Body>\n}
. qq{ <u:Browse xmlns:u="urn:schemas-upnp-org:service:ContentDirectory:1">\n}
. qq{ <ObjectID>$object_id</ObjectID>\n}
. qq{ <BrowseFlag>$flag</BrowseFlag>\n}
. qq{ <Filter>*</Filter>\n}
. qq{ <StartingIndex>0</StartingIndex>\n}
. qq{ <RequestedCount>0</RequestedCount>\n}
. qq{ <SortCriteria></SortCriteria>\n}
. qq{ </u:Browse>\n}
. qq{ </s:Body>\n}
. qq{</s:Envelope>\n};
my $req = HTTP::Request->new(POST => $control_url);
$req->header('Content-Type' => 'text/xml; charset="utf-8"');
$req->header('SOAPACTION' => '"urn:schemas-upnp-org:service:ContentDirectory:1#Browse"');
$req->content($body);
my $res = $ua->request($req);
if (!$res->is_success) {
die "SOAP Browse fehlgeschlagen (ObjectID=$object_id): " . $res->status_line . "\n"
. $res->decoded_content . "\n";
}
my $soap = XML::LibXML->load_xml(string => $res->decoded_content);
# <Result> enthält DIDL-Lite als escaped XML
my ($result_node) = $soap->findnodes('//*[local-name()="Result"]');
my $result = $result_node ? $result_node->textContent : "";
$result = norm($result);
return $result;
}
# ---------------- 3) DIDL-Lite parsen ----------------
sub parse_didl {
my ($didl_str) = @_;
return ([], []) if !$didl_str;
my $didl_doc = XML::LibXML->load_xml(string => $didl_str);
my @containers;
for my $c ($didl_doc->findnodes('//*[local-name()="container"]')) {
my $id = $c->getAttribute("id") // "";
my ($t) = $c->findnodes('./*[local-name()="title"]');
my $title = $t ? norm($t->textContent) : "";
push @containers, { id => norm($id), title => $title };
}
my @items;
for my $it ($didl_doc->findnodes('//*[local-name()="item"]')) {
my $id = $it->getAttribute("id") // "";
my ($t) = $it->findnodes('./*[local-name()="title"]');
my $title = $t ? norm($t->textContent) : "";
my ($art) = $it->findnodes('.//*[local-name()="albumArtURI"]');
my $albumart = $art ? norm($art->textContent) : "";
push @items, { id => norm($id), title => $title, art => $albumart };
}
return (\@containers, \@items);
}
# ---------------- 4) Debug: Container/Items auflisten ----------------
sub dump_children_one_level {
my ($parent_id, $limit_items) = @_;
$limit_items //= 15;
my $didl = soap_browse(ObjectID => $parent_id, BrowseFlag => "BrowseDirectChildren");
my ($containers, $items) = parse_didl($didl);
print "\n== Children of $parent_id ==\n";
print "Containers: " . scalar(@$containers) . "\n";
for my $c (@$containers) {
printf " [C] %-45s id=%s\n", ($c->{title} // ""), ($c->{id} // "");
}
print "Items: " . scalar(@$items) . "\n";
my $max = @$items < $limit_items ? @$items : $limit_items;
for (my $i=0; $i<$max; $i++) {
my $it = $items->[$i];
printf " [I] %-45s id=%s\n", ($it->{title} // ""), ($it->{id} // "");
}
}
# ---------------- 5) BFS: Container per Titel finden ----------------
sub find_container_bfs {
my (%p) = @_;
my $root = $p{root} // "0";
my $want_re = $p{want_re}; # regex auf lowercased title
my $max_nodes = $p{max_nodes} // 12000;
my @q = ($root);
my %seen;
my $visited = 0;
while (@q) {
my $cur = shift @q;
next if $seen{$cur}++;
last if ++$visited > $max_nodes;
my $didl = soap_browse(ObjectID => $cur, BrowseFlag => "BrowseDirectChildren");
my ($containers, undef) = parse_didl($didl);
for my $c (@$containers) {
my $t = lc_norm($c->{title});
return $c->{id} if defined($want_re) && $t =~ $want_re;
push @q, $c->{id};
}
}
return undef;
}
# ---------------- 6) Fallback: "beste Senderliste" finden ----------------
# Heuristik: Container mit vielen Items und wenigen Subcontainern
sub find_best_station_list_container {
my (%p) = @_;
my $root = $p{root} // "0";
my $max_nodes = $p{max_nodes} // 20000;
my @q = ($root);
my %seen;
my $visited = 0;
my $best_id = undef;
my $best_score = -1;
my $best_items = 0;
my $best_conts = 0;
while (@q) {
my $cur = shift @q;
next if $seen{$cur}++;
last if ++$visited > $max_nodes;
my $didl = soap_browse(ObjectID => $cur, BrowseFlag => "BrowseDirectChildren");
my ($containers, $items) = parse_didl($didl);
my $num_items = scalar(@$items);
my $num_conts = scalar(@$containers);
# Favoritenlisten sind oft: viele Items, wenig Untercontainer
my $score = $num_items * 10 - $num_conts;
if ($num_items > 0 && $score > $best_score) {
$best_score = $score;
$best_id = $cur;
$best_items = $num_items;
$best_conts = $num_conts;
}
# weiter runter
for my $c (@$containers) {
push @q, $c->{id};
}
}
print "Fallback best container: $best_id (items=$best_items containers=$best_conts score=$best_score)\n"
if $debug && defined $best_id;
return $best_id;
}
# ---------------- 7) MAIN: Radio -> Favoriten -> Items ----------------
# 7.1: Radio/Internetradio Container finden (global)
my $radio_id = find_container_bfs(
root => "0",
want_re => qr/(internet\s*radio|internetradio|radio)/,
max_nodes => 20000
) or die "Konnte keinen Container 'Internetradio/Radio' finden.\n";
print "Radio container found: $radio_id\n" if $debug;
dump_children_one_level($radio_id) if $debug;
# 7.2: Favoriten darunter finden (per Titel), sonst Fallback (beste Liste)
my $fav_id = find_container_bfs(
root => $radio_id,
want_re => qr/(favorit|favorite|lieblings|favourites)/,
max_nodes => 20000
);
if (!$fav_id) {
print "Kein Favoriten-Container per Titel gefunden – nutze Fallback (Container mit den meisten Sender-Items)...\n"
if $debug;
$fav_id = find_best_station_list_container(root => $radio_id, max_nodes => 30000);
}
die "Konnte keine Senderliste unterhalb von '$radio_id' finden.\n" if !$fav_id;
print "Station list container: $fav_id\n" if $debug;
dump_children_one_level($fav_id) if $debug;
# 7.3: Items (Sender) direkt aus Favoritencontainer lesen
my $fav_didl = soap_browse(ObjectID => $fav_id, BrowseFlag => "BrowseDirectChildren");
my (undef, $items) = parse_didl($fav_didl);
die "Keine Sender-Items im Container ($fav_id) gefunden.\n" if !@$items;
# ---------------- 8) presets.xml schreiben ----------------
my $fh = IO::File->new(">$out_file") or die "Kann $out_file nicht schreiben: $!\n";
binmode($fh, ":utf8");
my $w = XML::Writer->new(OUTPUT => $fh, DATA_MODE => 1, DATA_INDENT => 2, ENCODING => "UTF-8");
my $now = time();
$w->xmlDecl("UTF-8");
$w->startTag("presets");
my $pid = int($start_id);
my $count = 0;
for my $st (@$items) {
last if $count >= $max_presets;
my $name = $st->{title} || "Unbenannt";
my $oid = $st->{id};
next if !$oid;
$w->startTag("preset", id => $pid, createdOn => $now, updatedOn => $now);
$w->startTag("ContentItem",
source => "STORED_MUSIC",
location => $oid,
sourceAccount => $udn . "/0",
isPresetable => "true",
);
$w->dataElement("itemName", $name);
$w->dataElement("containerArt", $st->{art}) if $st->{art};
$w->endTag("ContentItem");
$w->endTag("preset");
$pid++;
$count++;
}
$w->endTag("presets");
$w->end();
$fh->close();
print "OK: $count Sender nach $out_file geschrieben.\n";
exit 0;