Abfrage der Radiosender einer FritzBox

[Prof. Dr. Peter Henning]

Der nachfolgende Code schreibt das in eine Datei presets.xml für Bose-Boxen um. Kann leicht angepasst werden für andere Zwecke.

Code Auswählen Erweitern

#!/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;



[Prof. Dr. Peter Henning]

Ich habe den Code jetzt noch einmal geändert. Für jeden auf der FB gefundenen Stream wird abgefragt, welche Kanalnummer auf einer Bose-Box man haben möchte (1..20). Wenn diese 1..6 beträgt, wird eine xml-Datei für das Senden an die Box erstellt, wenn diese >6 ist, wird eine Attributdefinition für das BOSEST-Modul geschrieben.

Code Auswählen Erweitern

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
use open ':std', ':encoding(UTF-8)';

use Getopt::Long qw(GetOptions);
use LWP::UserAgent;
use HTTP::Request::Common qw(POST GET);
use URI;
use XML::LibXML;

# ------------------------------------------------------------
# CLI options
# ------------------------------------------------------------
my $desc_url = '';
my $host     = '';
my $port     = 49000;
my $timeout  = 10;
my $maxdepth = 50;
my $debug    = 0;

GetOptions(
  'desc=s'     => \$desc_url,   # full URL to MediaServerDevDesc.xml
  'host=s'     => \$host,       # host/IP of fritzbox
  'port=i'     => \$port,
  'timeout=i'  => \$timeout,
  'maxdepth=i' => \$maxdepth,
  'debug!'     => \$debug,
) or die usage();

if (!$desc_url) {
  $host or die usage();
  $desc_url = "http://$host:$port/MediaServerDevDesc.xml";
}

my $ua = LWP::UserAgent->new(
  timeout => $timeout,
  agent   => "fritz_interactive_channels_and_presets/1.0",
);

# ------------------------------------------------------------
# Discover ContentDirectory + UDN
# ------------------------------------------------------------
my ($base_url, $control_url, $service_type, $udn) = get_contentdirectory_control_and_udn($ua, $desc_url);

my $source_account = normalize_udn($udn) . "/0";

print "Device description: $desc_url\n" if $debug;
print "Base URL:          $base_url\n"   if $debug;
print "Control URL:       $control_url\n"if $debug;
print "ServiceType:       $service_type\n"if $debug;
print "UDN raw:           $udn\n"        if $debug;
print "sourceAccount:     $source_account\n" if $debug;

# ------------------------------------------------------------
# Ask FHEM device name (needed for boseattr.txt output)
# ------------------------------------------------------------
print "\nFHEM Device-Name für boseattr.txt (z.B. WohnzimmerBose): ";
chomp(my $fhem_dev = <STDIN>);
$fhem_dev ||= "BoseDevice";

# Output files
my $file_presets = "payload_storepreset.xml";
my $file_attrs   = "boseattr.txt";

open my $fh_preset, ">:encoding(UTF-8)", $file_presets
  or die "Cannot write $file_presets: $!\n";
open my $fh_attr, ">:encoding(UTF-8)", $file_attrs
  or die "Cannot write $file_attrs: $!\n";

print "\nSchreibe Preset-Payload nach: $file_presets\n";
print "Schreibe FHEM attrs nach:     $file_attrs\n";
print "\nEingabe pro Item: 1..6 = Preset-ID, >=10 = channel_xx, n = skip, q = quit\n\n";

# Keep track of assigned presets 1..6
my %preset_used;

my %seen_containers;
my $quit = 0;

interactive_crawl(
  ua            => $ua,
  base_url      => $base_url,
  control_url   => $control_url,
  service_type  => $service_type,
  container_id  => '0',
  depth         => 0,
  maxdepth      => $maxdepth,
  seen          => \%seen_containers,
  debug         => $debug,
  quit_ref      => \$quit,
  fh_preset     => $fh_preset,
  fh_attr       => $fh_attr,
  fhem_dev      => $fhem_dev,
  source_account=> $source_account,
  preset_used   => \%preset_used,
);

close $fh_preset;
close $fh_attr;

print "\nFertig.\n";
print " - $file_presets (Preset-Payload, max 6 Einträge)\n";
print " - $file_attrs   (FHEM attr Zeilen)\n";
exit 0;

# ============================================================
# Helpers
# ============================================================

sub usage {
  return <<"TXT";
Usage:
  $0 --host <ip|fritz.box> [--port 49000] [--timeout 10] [--maxdepth 50] [--debug]
  $0 --desc <url_to_MediaServerDevDesc.xml> [--timeout 10] [--maxdepth 50] [--debug]

Example:
  $0 --host 192.168.0.254 --debug
TXT
}

sub normalize_udn {
  my ($udn) = @_;
  $udn //= '';
  $udn =~ s/^\s+|\s+$//g;
  $udn =~ s/^uuid://i;   # deine Bose/FHEM Beispiele sind ohne "uuid:"
  return $udn || 'UNKNOWN';
}

sub get_contentdirectory_control_and_udn {
  my ($ua, $desc_url) = @_;

  my $res = $ua->request(GET($desc_url));
  die "GET $desc_url failed: " . $res->status_line . "\n" if !$res->is_success;

  my $xml  = XML::LibXML->load_xml(string => $res->decoded_content);
  my $root = $xml->documentElement();

  my $u = URI->new($desc_url);
  my $base_url = $u->scheme . "://" . $u->host;
  $base_url .= ":" . $u->port if defined $u->port;

  my $udn = '';
  my ($udn_node) = $root->findnodes('//*[local-name()="UDN"]/text()');
  if ($udn_node) {
    $udn = $udn_node->data;
    $udn =~ s/^\s+|\s+$//g;
  }
  $udn ||= 'uuid:UNKNOWN';

  my ($service_type, $control_url);
  for my $svc ($root->findnodes('//*[local-name()="serviceList"]/*[local-name()="service"]')) {
    my ($st) = $svc->findnodes('./*[local-name()="serviceType"]/text()');
    next if !$st;
    my $stval = $st->data;
    next if $stval !~ /ContentDirectory/i;

    my ($cu) = $svc->findnodes('./*[local-name()="controlURL"]/text()');
    $control_url  = $cu ? $cu->data : undef;
    $service_type = $stval;
    last;
  }

  die "No ContentDirectory service in description.\n" if !$control_url || !$service_type;

  my $control_abs = URI->new_abs($control_url, $base_url)->as_string;
  return ($base_url, $control_abs, $service_type, $udn);
}

sub interactive_crawl {
  my %a = @_;

  my $ua           = $a{ua};
  my $base_url     = $a{base_url};
  my $control_url  = $a{control_url};
  my $service_type = $a{service_type};
  my $container_id = $a{container_id};   # << current container (this is what we need for location)
  my $depth        = $a{depth};
  my $maxdepth     = $a{maxdepth};
  my $seen         = $a{seen};
  my $dbg          = $a{debug};
  my $quit_ref     = $a{quit_ref};

  return if $$quit_ref;
  return if $depth > $maxdepth;
  return if $seen->{$container_id}++;

  print "Browse container id=$container_id depth=$depth\n" if $dbg;

  my $start = 0;
  my $count = 200;

  while (1) {
    return if $$quit_ref;

    my $r = soap_browse(
      ua           => $ua,
      control_url  => $control_url,
      service_type => $service_type,
      object_id    => $container_id,
      starting     => $start,
      requested    => $count,
    );

    my $entries = parse_didl($r->{Result}, $base_url);

    my $returned = $r->{NumberReturned} // 0;
    my $total    = $r->{TotalMatches}   // 0;

    for my $e (@$entries) {
      return if $$quit_ref;

      if ($e->{type} eq 'container') {
        interactive_crawl(
          %a,
          container_id => $e->{id},
          depth        => $depth + 1,
        );
      }
      elsif ($e->{type} eq 'item') {
        # Show metadata and ask for channel number
        show_item_with_container($e, $container_id);

        my $ans = ask_channel();

        if ($ans eq 'n') {
          print "-> übersprungen.\n\n";
          next;
        }
        if ($ans eq 'q') {
          $$quit_ref = 1;
          print "-> beendet.\n\n";
          return;
        }

        # numeric channel
        my $x = int($ans);

        if ($x >= 1 && $x <= 6) {
          # Preset: MUST use container location starting with "4"
          if ($container_id !~ /^4:/) {
            print "!! Abgelehnt: Für Preset 1..6 muss location ein Container sein, der mit '4:' beginnt.\n";
            print "   Aktueller Container: $container_id\n\n";
            next;
          }
          if ($a{preset_used}{$x}) {
            print "!! Abgelehnt: Preset-ID $x ist schon vergeben. (Nur 1..6, keine Duplikate)\n\n";
            next;
          }

          my $epoch = time();
          my $title = $e->{title} // '';
          my $logo  = $e->{logo}  // '';

          print {$a{fh_preset}} build_preset_xml(
            preset_id      => $x,
            epoch          => $epoch,
            location       => $container_id,         # << EXACTLY container id
            source_account => $a{source_account},
            item_name      => $title,
            container_art  => $logo,
          );

          $a{preset_used}{$x} = 1;
          print "-> Preset $x geschrieben.\n\n";
          next;
        }

        if ($x >= 10) {
          # FHEM attr: channel_xx
          my $title = $e->{title} // '';
          $title =~ s/\r|\n/ /g;

          my $logo = $e->{logo} // ''; # can be empty
          my $val  = join('|',
            '',            # we will inject " Stream" after title, and keep "||" structure below
          );

          # EXACT requested format:
          # attr <device> channel_{x} 80er Hits Stream||4:cont2:...|STORED_MUSIC|<sourceAccount>
          my $line = "attr $a{fhem_dev} channel_$x $title Stream||$container_id|STORED_MUSIC|$a{source_account}\n";
          print {$a{fh_attr}} $line;

          print "-> channel_$x geschrieben.\n\n";
          next;
        }

        # any other numeric
        print "!! Hinweis: Erlaubt sind Preset 1..6 oder channel >= 10. Eingabe '$x' wird ignoriert.\n\n";
      }
    }

    last if $returned <= 0;
    $start += $returned;
    last if $start >= $total;
  }
}

sub ask_channel {
  while (1) {
    print "Kanalnr (1..6 Preset, >=10 channel_xx) oder n/q: ";
    chomp(my $ans = <STDIN>);
    $ans = lc($ans // '');
    $ans =~ s/^\s+|\s+$//g;

    return 'n' if $ans eq 'n';
    return 'q' if $ans eq 'q';

    if ($ans =~ /^\d+$/) {
      return $ans;
    }
    print "Ungültig. Bitte Zahl, n oder q.\n";
  }
}

sub show_item_with_container {
  my ($e, $container_id) = @_;
  my $title = $e->{title} // '';
  my $id    = $e->{id}    // '';
  my $class = $e->{class} // '';
  my $res   = $e->{res}   // '';
  my $logo  = $e->{logo}  // '';

  print "----------------------------------------\n";
  print "Title:     $title\n";
  print "Item ID:   $id\n" if $id ne '';
  print "Class:     $class\n" if $class ne '';
  print "res:       $res\n"   if $res ne '';
  print "Logo:      $logo\n"  if $logo ne '';
  print "Container: $container_id\n";
  print "----------------------------------------\n";
}

sub xml_escape {
  my ($s) = @_;
  $s //= '';
  $s =~ s/&/&amp;/g;
  $s =~ s/</&lt;/g;
  $s =~ s/>/&gt;/g;
  $s =~ s/"/&quot;/g;
  $s =~ s/'/&apos;/g;
  return $s;
}

sub build_preset_xml {
  my %p = @_;
  my $pid   = $p{preset_id};
  my $epoch = $p{epoch};
  my $loc   = $p{location};
  my $sa    = $p{source_account};
  my $name  = $p{item_name} // '';
  my $art   = $p{container_art} // '';

  $name = xml_escape($name);
  $loc  = xml_escape($loc);
  $sa   = xml_escape($sa);

  my $xml = qq{<preset id="$pid" createdOn="$epoch" updatedOn="$epoch">\n}
          . qq{    <ContentItem source="STORED_MUSIC" location="$loc"\n}
          . qq{        sourceAccount="$sa" isPresetable="true">\n}
          . qq{        <itemName>$name</itemName>\n};

  if ($art ne '') {
    $art = xml_escape($art);
    $xml .= qq{        <containerArt>\n$art\n        </containerArt>\n};
  }

  $xml .= qq{    </ContentItem>\n}
       .  qq{</preset>\n};

  return $xml;
}

sub soap_browse {
  my %a = @_;
  my $ua           = $a{ua};
  my $control_url  = $a{control_url};
  my $service_type = $a{service_type};
  my $object_id    = $a{object_id};
  my $starting     = $a{starting}  // 0;
  my $requested    = $a{requested} // 200;

  my $soap = qq{<?xml version="1.0" encoding="utf-8"?>
<s:Envelope xmlns:s="http://schemas.xmlsoap.org/soap/envelope/" s:encodingStyle="http://schemas.xmlsoap.org/soap/encoding/">
  <s:Body>
    <u:Browse xmlns:u="$service_type">
      <ObjectID>$object_id</ObjectID>
      <BrowseFlag>BrowseDirectChildren</BrowseFlag>
      <Filter>*</Filter>
      <StartingIndex>$starting</StartingIndex>
      <RequestedCount>$requested</RequestedCount>
      <SortCriteria></SortCriteria>
    </u:Browse>
  </s:Body>
</s:Envelope>};

  my $req = POST($control_url,
    Content_Type => 'text/xml; charset="utf-8"',
    Content      => $soap,
  );
  $req->header('SOAPACTION' => qq{"$service_type#Browse"});

  my $res = $ua->request($req);
  die "SOAP Browse failed ($control_url): " . $res->status_line . "\n" if !$res->is_success;

  my $xml = XML::LibXML->load_xml(string => $res->decoded_content);

  my ($result) = $xml->findnodes('//*[local-name()="BrowseResponse"]/*[local-name()="Result"]/text()');
  my ($nr)     = $xml->findnodes('//*[local-name()="BrowseResponse"]/*[local-name()="NumberReturned"]/text()');
  my ($tm)     = $xml->findnodes('//*[local-name()="BrowseResponse"]/*[local-name()="TotalMatches"]/text()');

  return {
    Result         => $result ? $result->data : '',
    NumberReturned => $nr     ? int($nr->data) : 0,
    TotalMatches   => $tm     ? int($tm->data) : 0,
  };
}

sub parse_didl {
  my ($didl_escaped, $base_url) = @_;
  return [] if !$didl_escaped;

  my $didl = $didl_escaped;

  # Sometimes escaped inside SOAP Result
  if ($didl =~ /&lt;DIDL-Lite/i) {
    $didl =~ s/&lt;/</g;
    $didl =~ s/&gt;/>/g;
    $didl =~ s/&quot;/"/g;
    $didl =~ s/&amp;/&/g;
  }

  my $doc;
  eval { $doc = XML::LibXML->load_xml(string => $didl); 1 } or return [];

  my @out;

  for my $c ($doc->findnodes('//*[local-name()="container"]')) {
    my $id = $c->getAttribute('id') // '';
    push @out, { type => 'container', id => $id };
  }

  for my $i ($doc->findnodes('//*[local-name()="item"]')) {
    my $id = $i->getAttribute('id') // '';
    my ($title) = $i->findnodes('./*[local-name()="title"]/text()');
    my ($class) = $i->findnodes('./*[local-name()="class"]/text()');
    my ($res)   = $i->findnodes('./*[local-name()="res"]/text()');

    my $logo = '';
    my ($art) = $i->findnodes('.//*[local-name()="albumArtURI"]/text()');
    if ($art) {
      $logo = $art->data;
      $logo =~ s/^\s+|\s+$//g;
      if ($logo && $logo !~ m{^https?://}i) {
        $logo = URI->new_abs($logo, $base_url)->as_string;
      }
    }

    push @out, {
      type  => 'item',
      id    => $id,
      title => $title ? $title->data : '',
      class => $class ? $class->data : '',
      res   => $res   ? $res->data   : '',
      logo  => $logo,
    };
  }

  return \@out;
}