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
Changes to ugarit-manifest-maker.scm.
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 ... 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 ... 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 ... 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 |
(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
................................................................................
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)
................................................................................
(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))
................................................................................
(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
|
| > > | | | | > > > > | | > | > | | | | | > | | > > > | | > > > | | < < | < > | | > | | > | | > | | > | > > > > | > > > > | < > > > > > | > |
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 ... 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 ... 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 ... 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 |
(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
................................................................................
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)
................................................................................
(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))
................................................................................
(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
|