Complete refactoring for rktplayer, in order to make it play on DLNA renderers and also use UpNP media server resources.

2026-08-08 14:29:01 +02:00
parent 186b3bb8d7
commit f5fdc38e67
69 changed files with 5953 additions and 1647 deletions
@@ -0,0 +1,82 @@
+#lang racket/base
+
+(require racket/class
+         racket-audio
+         racket/list
+         racket/path
+         racket/string
+         "base/media-container.rkt"
+         "../misc/utils.rkt")
+
+(provide mc-filesystem%)
+
+(define mc-filesystem%
+  (class media-container%
+    (init-field
+     library
+     [relative-path '()])
+
+    (check/c mc-filesystem% relative-path list?)
+
+    (define/private (full-path)
+      (send library resolve-path relative-path))
+
+    (define/private (music-file-name? path)
+      (let ((file-name
+             (string-downcase (path->string path))))
+        (for/or ((extension
+                  (in-list (audio-known-exts?))))
+          (string-suffix?
+           file-name
+           (string-append "." extension)))))
+
+    (define/private (item-kind path)
+      (cond
+        ((directory-exists? path)
+         (let ((name
+                (path->string
+                 (file-name-from-path path))))
+           (and (not (string-prefix? name "."))
+                'container)))
+        ((music-file-name? path) 'track)
+        (else #f)))
+
+    (define/override (get-title)
+      (if (null? relative-path)
+          (send (send library get-cfg) get-name)
+          (path->string (last relative-path))))
+
+    (define/override (get-items)
+      (let ((path (full-path)))
+        (if (directory-exists? path)
+            (for*/list ((entry (in-list
+                               (sort (directory-list path)
+                                     path<?)))
+                       (entry-path
+                        (in-value (build-path path entry)))
+                       (kind
+                        (in-value (item-kind entry-path)))
+                       #:when kind)
+              (let ((entry-relative-path
+                     (append relative-path (list entry))))
+                (if (eq? kind 'container)
+                    (send library
+                          make-container
+                          entry-relative-path)
+                    (send library
+                          make-track
+                          entry-relative-path))))
+            '())))
+
+    (define/override (get-track-reliver)
+      (lambda (track-factory-id track-relive-info)
+        (case track-factory-id
+          ((file)
+           (send library
+                 make-track
+                 track-relive-info))
+          (else #f))))
+
+    (super-new
+     [id (cons (send (send library get-cfg) get-id)
+               relative-path)])))