Version 1 of FreeDB

Updated 2011-04-15 14:00:03 by joheid

if {0} { The www.freedb.org internet data base provides information on artists, album- and songtitles on audio CDs.

This information can be used when ripping the CDs to genarate playlists etc. The query key is an ID which is calculated from the track-offsets of the CD (details cf. freedb-FAQ from freedb.org).

As this ID might not be unique a category (jazz, rock ...,) are added. Both information together provide the unique key into freedb.org. This package handles the queries to freedb.org namely the lscat read and query commands }

 #
 # (C) Joachim Heidemeier 2011
 # published under the same licence terms as Tcl
 #
 package provide cddb 0.1
 #
 # requires discid 
 #
 package require discid
 #
 #
 #
 namespace eval cddb {
 namespace export startConn lscat read query select_match

 global done
 set done 0
 # counter for autoincrement
   variable counter 0
 #
 # storage for cddb_data information
 # 
   variable cdInfo
 #
 # config variables for the connection
 #
    set cddb(-servers) [list freedb.freedb.org]
    set cddb(-port) 8880
    set cddb(-clientName) {tcl_cddb_lib}
    set cddb(-clientVersion) 0.1
    set cddb(-myHost) {}
    set cddb(-userName) anonymous
    set cddb(-EOT) {.}

 #
 # configure options, taken from http package
 #
 proc configure {args} {
    variable cddb       
    set options [lsort [array names cddb -*]]
    set usage [join $options ", "]
    if {[llength $args] == 0} {
    set result {}
    foreach name $options {
        lappend result $name $cddb($name)
    }
    return $result
    }
    regsub -all -- - $options {} options
    set pat ^-([join $options |])$
    if {[llength $args] == 1} {
        set flag [lindex $args 0]
        if {[regexp -- $pat $flag]} {
                return $cddb($flag)
        } else {
            return -code error "Unknown option $flag, must be: $usage"
        }
    } else {
        foreach {flag value} $args {
            if {[regexp -- $pat $flag]} {
                set cddb($flag) $value
            } else {
                return -code error "Unknown option $flag, must be: $usage"
            }
        }
    }   
 }
 #
 # returns a unique name for the connection
 # 
 proc autoName {{prefix conn}} {
    variable counter
    set an "$prefix$counter"
    incr counter
    return $an
 }

# # defines a simple statemachine for the decoding # (taken from Tclers Wiki http://wiki.tcl.tk/8363 , slightly modified) # this time token is linked to variable conn to avoid # state / states typos # proc Statemachine {token codeMulti states} { #

   upvar #0 $token conn
   variable cddb
   variable cdInfo
   global done
   array set S $states
   proc Goto label {
       uplevel 1 set this $label
       return -code continue
   }
   set this [lindex $states 0]
   while 1 {eval $S($this)}
   rename Goto {}

} # # external user drive selection of # several "near matches" # unsets the _nr_entries in cdInfo # sets _entries # proc select_match {token} {

    upvar #0 $token state
    global done
    variable cdInfo


    Statemachine $token {} {
        START {
            set keys [array names cdInfo -glob {_[0-9]*}]
            set categs [lsort [lsearch -inline -all -glob $keys *categ*]]
            set dtitles [lsort [lsearch -inline -all -glob $keys *dtitle*]]
            set discids [lsort [lsearch -inline -all -glob $keys *discid*]]
            set matches [llength $dtitles]
            puts "Found $matches possible matches. Please enter the number of the selected match, n for no selection"   
            for {set l 0} {$l < $matches} {incr l} {
                puts stdout "Match No. $l discid $cdInfo([lindex $discids $l]) categ $cdInfo([lindex $categs $l]) \n\t\
                dtitle $cdInfo([lindex $dtitles $l])"
            }
            Goto READ
        } READ {
            gets stdin line
            if {($line eq {n}) || ([string is integer -strict $line] && ($line < $matches))} {
                set selected $line
                Goto END 
            } else {
                Goto REPEAT
            }
        } REPEAT {
            puts "Please enter the number of the selected match or n for no selection"
            Goto READ
        } END {
            if {$selected eq n} {
                puts "no match selected"
            } else {
                set cdInfo(_categ) $cdInfo([lindex $categs $selected])
                set cdInfo(_discid) $cdInfo([lindex $discids $selected])
                set cdInfo(_dtitle) $cdInfo([lindex $dtitles $selected])
                set cdInfo(match) single
            }
            foreach {categ discid dtitle} "$categs $discids $dtitles" {
                unset cdInfo($categ)
                unset cdInfo($discid)
                unset cdInfo($dtitle)
            }
            break
        }
    }
 }

# # takes a response line with code # and splits it into code and message part # the results are stored in the state arry # proc evaluate_code_line {token inp} {

    upvar #0 $token state
    set x [split $inp \n]
    set lx [llength $x]
    if {$lx != 1} {return -code error "expected one line, received several"}
    if {[regexp {([0-9]{3})(.*)} $inp -> code message]}  {
    set state(code) $code
    set state(message) [string trim $message]
    return -code ok
    } else {
        return -code error "unknown response structure! \n $inp"
    }

} # # parseTitle evaluates the response of a query # and stores the response in # cdInfo indexed by number_name # response is # one or several lines consisting of # categ discid dtitle # proc parseTitle {response} {

    variable cdInfo
    set prefix {_}
    set pattern {([a-z]+) ([0-9,a-f]+) (.*)}
    if {[llength $response] > 1} {
        set i 0
    } else {
        set i ""
    }
    foreach line $response {
        if {[string is integer -strict $i]} {
            set prefix "_${i}_"
            incr i
        }
        regexp -- $pattern $line -> categ discid dtitle
        array set cdInfo [list ${prefix}categ $categ ${prefix}discid $discid ${prefix}dtitle [string trim $dtitle]]
    }

} # # # process response # processing is done in Statemachine which handles # single or multiple lines depending on provided codelist # multiline responses are indicated in the protocol by codeMulti # return codes from the first line which always start with the numeric return code # a ReturnCode from codeMulti triggers multiline mode # the use data from the response are in token(text) /as list/ # which in the case of single line responses is equal to token(message) # proc processResponse {token {codeMulti {}}} {

    upvar #0 $token state
    global done
    variable cddb
    Statemachine $token $codeMulti {
    START {
        set conn(text) [list] 
        set res [list]
        set rp [gets $conn(sock)]
        if {$rp != -1} {
            evaluate_code_line $token $rp
            if {[llength $codeMulti] && [lsearch -exact $codeMulti $conn(code)] > -1} {
                Goto MULTI
            } elseif  {$conn(code) < 400} {
                            set conn(text) [list $conn(message)]
                            Goto END
                } else {
                    Goto ERR ;# RC >= 400
                }
        } else {
        Goto EOF ;# rp == -1
        }
    } MULTI {

        set rp [gets $conn(sock)]
        if {$rp != -1} {
            if {$rp != $cddb(-EOT)} { 
                if {$rp != {}} {
                    lappend conn(text) $rp
                    Goto MULTI
                }        
            } else {Goto END}
        } else {Goto EOT}

    } ERR {

        set conn(status) commandFailed

        return -code continue $conn(message);# Fehlerbehandlung erfolgt in aufrufender Routine
    } EOF {
        set conn(status) EOF
        return -code continue EOF

    } END {
        set conn(status) success
        incr done
        break
        }
    }

}

# # each connection is handeled in one global array # (variable autonamed) # # startConn # setup a connection to a freedb_server # receives and evaluates server login message # and handles initial handshake # parameter serverIdx is the index of the cddb-server to access default 0 proc startConn {{serverIdx 0} args} { # protocoll description # Server sign-on banner: #---------------------- #<- code hostname CDDBP server version ready at date # # code: # 200 OK, read/write allowed # 201 OK, read only # 432 No connections allowed: permission denied # 433 No connections allowed: X users allowed, Y currently active # 434 No connections allowed: system load too high # hostname: # Server host name. Example: xyz.fubar.com # version: # Version number of server software. Example: v1.0PL0 # date: # Current date and time. Example: Wed Mar 13 00:41:34 1996 #

if {llength $args > 0} {

    if {![expr {[llength $args] % 2}]} {
    configure {*}$args

} else {error "uneven number of options given"} } set token autoName variable cddb variable responseCode global done upvar #0 $token state set state(server) lindex $cddb(-servers) $serverIdx set state(port) $cddb(-port) set state(sock) socket $state(server) $state(port) set state(exp_response) code_line set state(command) startConn set state(status) inCommand

fconfigure $state(sock) -translation {auto crlf} -blocking 0 fileevent $state(sock) readable [namespace code [list processResponse $token] vwait done set done 0 switch -exact -- $state(code) {

    200 {set state(accessmode) rw}
    201 {set state(accessmode) ro}
    431 -
    432 -
    433 {return -code error  $state(message)}

} # #Initial client-server handshake: #-------------------------------- #Note: This handshake must occur before other cddb commands # are accepted by the server. # #Client command: #-> cddb hello username hostname clientname version # # username: # Login name of user. Example: johndoe # hostname: # Host name of client. Example: abc.fubar.com # clientname: # The name of the connecting client. Example: xmcd, cda, EasyCD, # et cetera. Do not use the name of another client which already # exists. # version: # Version number of client software. Example: v1.0PL0 # #Server response: #<- code hello and welcome [email protected] running clientname version # # code: # 200 Handshake successful # 431 Handshake not successful, closing connection # 402 Already shook hands

        set state(status) inCommand
        set message "cddb hello  $cddb(-userName) $cddb(-myHost) $cddb(-clientName) $cddb(-clientVersion)"
        puts $state(sock) $message
        flush $state(sock)
        fileevent $state(sock) readable [namespace code [list processResponse $token]]
        vwait done
        set done 0
        switch -exact -- $state(code) {
            200 -
            402 {set state(status) ready}
            431 {return -code error  $state(message)}
        }
        return $token
    } ;#end startConn

# # # proc lscat {token} { #List the genre categories:<- .jetzt erst mal read, weil das auch mit cddbReadMultipleLines geht #-------------------------- #Client command: #-> cddb lscat # #Server response: #<- code Okay category list follows (until terminating marker) #<- category #<- category #<- (more categories...) #<- . # # code: # 210 Okay category list follows # category: # CD category. Example: rock variable cddb variable responseCode global done upvar #0 $token state set state(status) inCommand set state(lnr) 0 set code_multi list 210 puts $state(sock) "cddb lscat" flush $state(sock) fileevent $state(sock) readable [namespace code [list processResponse $token $code_multi] vwait done set done 0 set categList $state(text) return $categList } ;#end lscat # # proc read {token} {

#Read entry from database: #------------------------- # #Client command: #-> cddb read categ discid # # categ: # CD category. Example: rock # discid: # CD disc ID number. Example: f50a3b13 # # #Server response: #<- code categ discid #<- # xmcd 2.0 CD database file #<- # ... #<- (CDDB data...) # # or #<- code categ discid No such CD entry in database. # # code: # 210 OK, CDDB database entry follows (until terminating marker) # 401 Specified CDDB entry not found. # 402 Server error. # 403 Database entry is corrupt. # 409 No handshake. # categ: # CD category. Example: rock # discid: # CD disc ID number. Example: f50a3b13

    variable cdInfo
    variable cddb
    variable responseCode
    global done
    upvar #0 $token state
    set code_multi [list 210]
    set state(status) inCommand
    puts $state(sock) "cddb read $cdInfo(_categ) $cdInfo(_discid)"
    flush $state(sock)
    fileevent $state(sock) readable [namespace code [list processResponse $token $code_multi]]
    vwait done
    set done 0

# drop empty playorder fields

    set cdInfo(entry) [lrange $state(text) 0 [lsearch -exact $state(text) {PLAYORDER=} ]]

} # # proc query {token} { # # #Query database for matching entries: #------------------------------------ #Client command: #-> cddb query discid ntrks off1 off2 ... nsecs# # # discid: # CD disc ID number. Example: f50a3b13 # ntrks: # Total number of tracks on CD. # off1, off2, ...: # Frame offset of the starting location of each track. # nsecs: # Total playing length of CD in seconds. # #Server response: #<- code categ discid dtitle # or #<- code close matches found #<- categ discid dtitle #<- categ discid dtitle #<- (more matches...) #<- . # code: # 200 Found exact match # 211 Found inexact matches, list follows (until terminating marker) # 202 No match found # 403 Database entry is corrupt # 409 No handshakpTe # categ: # CD category. Example: rock # discid: # CD disc ID number of the found entry. Example: f50a3b13 # dtitle: # The Disc Artist and Disc Title (The DTITLE line). For example: # Pink Floyd / The Dark Side of the Moon # the TOC data are in variable cdtoc

    variable cdtoc
        variable cddb
        variable cdInfo 
        variable responseCode
        global done
        upvar #0 $token state
        set state(status) inCommand

# # build argumentlist for query from cdtoc #

        set code_multi [list 211]        
        set arglist [list $cdtoc(cddbID) $cdtoc(num_trks)]
        for {set i 0} {$i < $cdtoc(num_trks)} {incr i} {
            lappend arglist [tocList2TrackOffset $cdtoc($i)]
        }
        lappend arglist $cdtoc(total_seconds)

# perform query

        puts $state(sock) "cddb query [join $arglist]"
        flush $state(sock)
        fileevent $state(sock) readable [namespace code [list processResponse $token $code_multi]]
        vwait done
        set done 0
        switch -exact -- $state(code) {
            200 {set cdInfo(match) single; parseTitle $state(text) }
            211 {set cdInfo(match) multi; parseTitle $state(text) }
            default {return $state(message)}

        }

};#end query };#end namespace cddb # # testprogram # cdrom device is /dev/sr0 if {1} {

    cddb::configure -myHost ttiger.dnsalias.net
    cddb::read_TOC /dev/sr0
    cddb::cddbID
    set token [cddb::startConn]
    cddb::query $token
    if {$cddb::cdInfo(match) eq {multi}} {
      cddb::select_match $token  
    }
    cddb::read $token
    parray cddb::cdInfo

}

Enter page contents here, upload content using the button above, or click cancel to leave it empty.