Ugarit Manifest Maker
Check-in [8c7d300113]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Improved resilience of ogg metadata scanner.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | trunk
Files: files | file ages | folders
SHA1: 8c7d300113edf7254b9050ce899965b82176e566
User & Date: alaric 2016-04-07 23:26:15
Context
2016-04-07
23:26
Improved resilience of ogg metadata scanner. Leaf check-in: 8c7d300113 user: alaric tags: trunk
2015-06-12
21:55
Added release-info file check-in: 6dca55b750 user: alaric tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ugarit-manifest-maker.scm.

38
39
40
41
42
43
44
45


46
47
48
49
50
51
52
    (dc:spatial . #f)
    (dc:temporal . #f)
    (dc:creator . #f)
    (dc:created . #f)
    (dc:subject . #f)))

(define debug (lambda x (void)))
#;(define debug printf)



(define (alist-update! alist key value)
  (let ((pair (assq key alist)))
    (if (and (pair? pair)
             (not (cdr pair)))
        (begin
          (set-cdr! pair value) ;; Exists but is #f, so overwrite







|
>
>







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
    (dc:spatial . #f)
    (dc:temporal . #f)
    (dc:creator . #f)
    (dc:created . #f)
    (dc:subject . #f)))

(define debug (lambda x (void)))
#;(define debug (lambda x
                (apply printf x)
                (flush-output (current-output-port))))

(define (alist-update! alist key value)
  (let ((pair (assq key alist)))
    (if (and (pair? pair)
             (not (cdr pair)))
        (begin
          (set-cdr! pair value) ;; Exists but is #f, so overwrite
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555




556
557

558
559
560

561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
                                 fid
                                 (if (< (string-length data) 160)
                                     data
                                     (string-append
                                      (substring data 0 100)
                                      "...")))
                         (loop md)))))))))
        (when (not (= (read-byte) #x49))
              (abort))
        (when (not (= (read-byte) #x44))
              (abort))
        (when (not (= (read-byte) #x33))
              (abort))
        (let ((version1 (read-byte))
              (version2 (read-byte)))
          (case version1
            ((2) (read-id3v22))
            ((3) (read-id3v23))
            (else (abort)))))))))

(define (read-ogg-lacing)
  (let loop ((lacing 0)
             (bytes 1))
    (let ((byte (read-byte)))




      (if (= byte 255)
          (loop (+ lacing byte) (+ bytes 1))

          (values bytes (+ lacing byte))))))

(define (read-ogg-page abort)

  (when (not (= (read-byte) #x4f)) ;; OggS magic number
        (abort))
  (when (not (= (read-byte) #x67))
        (abort))
  (when (not (= (read-byte) #x67))
        (abort))
  (when (not (= (read-byte) #x53))
        (abort))
  (when (not (= (read-byte) #x00)) ;; Version
        (abort))
  (read-byte) ;; Header type
  (read-byte) ;; Granule position
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte)







|

|

|








|



>
>
>
>
|
|
>
|


>
|

|

|

|

|







534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
                                 fid
                                 (if (< (string-length data) 160)
                                     data
                                     (string-append
                                      (substring data 0 100)
                                      "...")))
                         (loop md)))))))))
        (when (not (equal? (read-byte) #x49))
              (abort))
        (when (not (equal? (read-byte) #x44))
              (abort))
        (when (not (equal? (read-byte) #x33))
              (abort))
        (let ((version1 (read-byte))
              (version2 (read-byte)))
          (case version1
            ((2) (read-id3v22))
            ((3) (read-id3v23))
            (else (abort)))))))))

(define (read-ogg-lacing abort)
  (let loop ((lacing 0)
             (bytes 1))
    (let ((byte (read-byte)))
      (cond
       ((eof-object? byte)
        (debug "EOF found during lacing - lacing=~a bytes=~a\n" lacing bytes)
        (abort))
       ((equal? byte 255)
        (loop (+ lacing byte) (+ bytes 1)))
       (else
        (values bytes (+ lacing byte)))))))

(define (read-ogg-page abort)
  (debug "Reading an ogg page...\n")
  (when (not (equal? (read-byte) #x4f)) ;; OggS magic number
        (abort))
  (when (not (equal? (read-byte) #x67))
        (abort))
  (when (not (equal? (read-byte) #x67))
        (abort))
  (when (not (equal? (read-byte) #x53))
        (abort))
  (when (not (equal? (read-byte) #x00)) ;; Version
        (abort))
  (read-byte) ;; Header type
  (read-byte) ;; Granule position
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte)
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600



601
602

603
604
605


606
607
608
609
610
611
612
613
  (read-byte)
  (read-byte)
  (read-byte) ;; Page checksum
  (read-byte)
  (read-byte)
  (read-byte)
  (let ((segments (read-byte)))

    (let ((segment-sizes
           (reverse
            (let loop ((segments-left segments)
                       (segment-sizes '()))
              (if (zero? segments-left)
                  segment-sizes
                  (receive (bytes lacing)
                           (read-ogg-lacing)



                           (loop (- segments-left bytes)
                                 (cons lacing segment-sizes))))))))

      (let loop ((ss segment-sizes)
                 (segments '()))
        (if (null? ss)


            (reverse segments)
            (let ((data (read-string (car ss))))
              (loop (cdr ss)
                    (cons data segments))))))))

(define (read-ogg-u32)
  (let* ((s1 (read-byte))
         (s2 (read-byte))







>




|


|
>
>
>
|
|
>



>
>
|







594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
  (read-byte)
  (read-byte)
  (read-byte) ;; Page checksum
  (read-byte)
  (read-byte)
  (read-byte)
  (let ((segments (read-byte)))
    (debug "Reading ~a bytes of segment sizes...\n" segments)
    (let ((segment-sizes
           (reverse
            (let loop ((segments-left segments)
                       (segment-sizes '()))
              (if (<= segments-left 0)
                  segment-sizes
                  (receive (bytes lacing)
                           (read-ogg-lacing abort)
                           (begin
                             (debug "segments-left: ~a bytes: ~a lacing: ~a\n"
                                    segments-left bytes lacing)
                             (loop (- segments-left bytes)
                                   (cons lacing segment-sizes)))))))))
      (debug "Got segment sizes table: ~s\n" segment-sizes)
      (let loop ((ss segment-sizes)
                 (segments '()))
        (if (null? ss)
            (begin
              (debug "Read ogg page: ~s\n" segments)
              (reverse segments))
            (let ((data (read-string (car ss))))
              (loop (cdr ss)
                    (cons data segments))))))))

(define (read-ogg-u32)
  (let* ((s1 (read-byte))
         (s2 (read-byte))
625
626
627
628
629
630
631
632
633
634
635
636
637

638
639

640
641

642
643

644
645

646




647




648
649




650

651
652
653
654
655
656
657

(define (parse-ogg-comment str)
  (let ((sep-pos (string-index str #\=)))
    (if sep-pos
        (cons (string-take str sep-pos)
              (string-drop str (+ sep-pos 1)))
        str)))

(define (parse-ogg-comments comments abort)
  (with-input-from-string comments
    (lambda ()
      (let ((type (read-byte)))
        (unless (= type 3)

                (abort)))
      (unless (= (read-byte) #x76) #; "vorbis"

              (abort))
      (unless (= (read-byte) #x6f)

              (abort))
      (unless (= (read-byte) #x72)

              (abort))
      (unless (= (read-byte) #x62)

              (abort))




      (unless (= (read-byte) #x69)




              (abort))
      (unless (= (read-byte) #x73)




              (abort))

      (let ((vendor (read-ogg-string)))
        (debug "Vendor: [~S]\n" vendor))
      (let loop ((comments-left (read-ogg-u32))
                 (comments '()))
        (if (zero? comments-left)
            comments
            (begin








|
<
<
|
<
>
|
|
>
|
|
>
|
|
>
|
|
>
|
>
>
>
>
|
>
>
>
>
|
|
>
>
>
>
|
>







640
641
642
643
644
645
646
647
648


649

650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687

(define (parse-ogg-comment str)
  (let ((sep-pos (string-index str #\=)))
    (if sep-pos
        (cons (string-take str sep-pos)
              (string-drop str (+ sep-pos 1)))
        str)))

(define (read-orbis abort)


  (unless (equal? (read-byte) #x6f)

          (debug "Bad comment magic")
          (abort))
  (unless (equal? (read-byte) #x72)
          (debug "Bad comment magic")
          (abort))
  (unless (equal? (read-byte) #x62)
          (debug "Bad comment magic")
          (abort))
  (unless (equal? (read-byte) #x69)
          (debug "Bad comment magic")
          (abort))
  (unless (equal? (read-byte) #x73)
          (debug "Bad comment magic")
          (abort)))

(define (parse-ogg-comments comments abort)
  (with-input-from-string comments
    (lambda ()
      (let ((type (read-byte)))
        (cond
         ((equal? type 3)
          (unless (equal? (read-byte) #x76) #; "vorbis"
                  (debug "Bad comment magic")
                  (abort))
          (read-orbis abort))
         ((equal? type #x76)
          (read-orbis abort))
         (else
          (debug "Unknown comment type ~s\n" type)
          (abort))))

      (let ((vendor (read-ogg-string)))
        (debug "Vendor: [~S]\n" vendor))
      (let loop ((comments-left (read-ogg-u32))
                 (comments '()))
        (if (zero? comments-left)
            comments
            (begin