[Tkabber-dev] [tclgpg] r54 committed - * tclgpg.tcl, doc/gpg.man: Broke compatibility with TclGPGME by...

codesite-noreply at google.com codesite-noreply at google.com
Mon Aug 3 17:19:59 MSD 2009


Revision: 54
Author: sgolovan
Date: Mon Aug  3 06:18:50 2009
Log: 	* tclgpg.tcl, doc/gpg.man: Broke compatibility with TclGPGME by
	  turning option -operation into a subcommand. Let password callback
	  return break code which means no passphrase. Modified set command
	  to query a given property if the value isn't specified. Added unset
	  command. Removed start-key, next-key and done-key commands (in favor
	  of list-keys).

	* tclgpg.tcl: Added encoding property, so that data supplied to and
	  received from GPG executable are encoded properly.

http://code.google.com/p/tclgpg/source/detail?r=54

Modified:
  /trunk/ChangeLog
  /trunk/doc/gpg.man
  /trunk/tclgpg.tcl

=======================================
--- /trunk/ChangeLog	Wed Feb  4 12:28:56 2009
+++ /trunk/ChangeLog	Mon Aug  3 06:18:50 2009
@@ -1,3 +1,15 @@
+2009-08-03  Sergei Golovan  <sgolovan at nes.ru>
+
+	* tclgpg.tcl, doc/gpg.man: Broke compatibility with TclGPGME by
+	  turning option -operation into a subcommand. Let password callback
+	  return break code which means no passphrase. Modified set command
+	  to query a given property if the value isn't specified. Added unset
+	  command. Removed start-key, next-key and done-key commands (in favor
+	  of list-keys).
+
+	* tclgpg.tcl: Added encoding property, so that data supplied to and
+	  received from GPG executable are encoded properly.
+
  2009-02-04  Sergei Golovan  <sgolovan at nes.ru>

  	* tclgpg.tcl: Fixed indices of returned serialised arrays.
=======================================
--- /trunk/doc/gpg.man	Fri Jan 30 11:15:17 2009
+++ /trunk/doc/gpg.man	Mon Aug  3 06:18:50 2009
@@ -16,91 +16,72 @@
  [section "COMMANDS"]

  [list_begin definitions]
-[call [cmd "::gpg::context"]]
+[call [cmd "::gpg::new"]]

  Create a new GPG context token.

+[call [cmd "\$token"] [arg "free"]]
+
+Destroy GPG token and free its resources.
+
  [call [cmd "\$token"] \
-        [arg "-operation set"] \
-        [arg "-property property"] \
-        [opt [arg "-value value"]]]
-
-Set a specified property.
+      [arg "set"] \
+      [arg "-property property"] \
+      [opt [arg "-value value"]]]
+
+Set or query a specified property.

  [call [cmd "\$token"] \
-        [arg "-operation get"] \
+        [arg "unset"] \
          [arg "-property property"]]

-Get a specified property.
+Unset a specified property.

  [call [cmd "\$token"] \
-        [arg "-operation list-keys"] \
-        [opt [arg "-patterns patterns"]] \
-        [opt [arg "-secretonly boolean"]] \
-        [opt [arg "-command command"]]]
+      [arg "list-keys"] \
+      [opt [arg "-patterns patterns"]] \
+      [opt [arg "-secretonly boolean"]] \
+      [opt [arg "-command command"]]]

  Return list of key tokens which match any of a specified patterns in the
  patterns list [arg patterns].

  [call [cmd "\$token"] \
-        [arg "-operation info-key"] \
-        [arg "-key keytoken"]]
+      [arg "info-key"] \
+      [arg "-key keytoken"]]

  Return a serialized array of key properties.

-[para]
-
-The following three operations are implemented only for compatibility with
-TclGPGME. Otherwise using operation [arg list-keys] is preferable.
-
  [call [cmd "\$token"] \
-        [arg "-operation start-key"] \
-        [opt [arg "-patterns patterns"]] \
-        [opt [arg "-secretonly boolean"]]]
-
-Start searching for keys which match any of a specified patterns in the
-patterns list [arg patterns].
-
-[call [cmd "\$token"] \
-        [arg "-operation next-key"]]
-
-Return the next key token in a search list.
-
-[call [cmd "\$token"] \
-        [arg "-operation done-key"]]
-
-Stop searching for keys.
-
-[call [cmd "\$token"] \
-        [arg "-operation encrypt"] \
-        [arg "-input input"] \
-        [opt [arg "-recipients recipients"]] \
-        [opt [arg "-sign boolean"]] \
-        [opt [arg "-command command"]]]
+      [arg "encrypt"] \
+      [arg "-input input"] \
+      [opt [arg "-recipients recipients"]] \
+      [opt [arg "-sign boolean"]] \
+      [opt [arg "-command command"]]]

  Encrypt message (using either symmetric or asymmetric algorithm).

  [call [cmd "\$token"] \
-        [arg "-operation decrypt"] \
-        [arg "-input input"] \
-        [opt [arg "-checkstatus boolean"]] \
-        [opt [arg "-command command"]]]
+      [arg "decrypt"] \
+      [arg "-input input"] \
+      [opt [arg "-checkstatus boolean"]] \
+      [opt [arg "-command command"]]]

  Decrypt message.

  [call [cmd "\$token"] \
-        [arg "-operation sign"] \
-        [arg "-input input"] \
-        [opt [arg "-mode mode"]] \
-        [opt [arg "-command command"]]]
+      [arg "sign"] \
+      [arg "-input input"] \
+      [opt [arg "-mode mode"]] \
+      [opt [arg "-command command"]]]

  Sign message.

  [call [cmd "\$token"] \
-        [arg "-operation verify"] \
-        [arg "-signature signature"] \
-        [opt [arg "-input input"]] \
-        [opt [arg "-command command"]]]
+      [arg "verify"] \
+      [arg "-signature signature"] \
+      [opt [arg "-input input"]] \
+      [opt [arg "-command command"]]]

  Verify signature.

@@ -109,24 +90,29 @@
  Create recipients token.

  [call [cmd "\$recipient"] \
-        [arg "-operation add"] \
-        [arg "-name name"] \
-        [opt [arg "-validity valid"]]]
+      [arg "add"] \
+      [arg "-name name"] \
+      [opt [arg "-validity valid"]]]

  Add name to a recipient token.

  [call [cmd "\$recipient"] \
-        [arg "-operation count"]]
-
-Return a number of recipients in a recipient token.
-
-[call [cmd "\$recipient"] \
-        [arg "-operation list"]]
+      [arg "list"]]

  Return a list of recipients in a recipient token.

  [list_end]

+[section ASYNCHRONOUS MODE]
+
+Many GPG subcommands may posess [arg "-command"] options. It turns
+asynchronous mode on and specifies a callback which is called to return
+operation result. This means that the command returns immediately, the pipe
+to GPG is switched to non-blocking mode and data from it is read only when
+it is available. After the operation is completed the callback is invoked
+with appended status (\"ok\" or \"error\") and the operation result in the
+same form as it would be returned in synchronous mode.
+
  [section EXAMPLES]

  Encrypt the word Hello using a symmetric encryption using
@@ -134,9 +120,13 @@

  [comment {Spaces after trailing \ are essential}]
  [example {
-set ctx [::gpg::context]
-$ctx -operation set passphrase-callback {puts abcdefgh}
-$ctx -operation encrypt -input Hello
+proc pass {args} {return abcdefgh}
+set gpg [::gpg::new]
+$gpg set -property armor -value true
+$gpg set -property encoding -value utf-8
+$gpg set -property passphrase-callback -value pass
+puts [$gpg encrypt -input Hello]
+$gpg free
  }]

  [section "AUTHORS"]
=======================================
--- /trunk/tclgpg.tcl	Wed Feb  4 12:28:56 2009
+++ /trunk/tclgpg.tcl	Mon Aug  3 06:18:50 2009
@@ -11,7 +11,7 @@

  package require Tcl 8.4

-if {[::info commands ::gpg::CExecGPG] eq ""} {
+if {[info commands ::gpg::CExecGPG] eq ""} {
      if {[package vsatisfies $::tcl_version 8.6]} {
          interp alias {} pipe {} chan pipe
      } elseif {[catch {package require pipe}]} {
@@ -29,15 +29,14 @@
  if {[package vsatisfies $gpgVersion 2.0] && \
          ![info exists ::env(GPG_AGENT_INFO)]} {
      unset gpgVersion
-    return -code error \
-           "GnuPG 2 cannot be used without gpg-agent"
+    return -code error "GnuPG 2 cannot be used without gpg-agent"
  }

  namespace eval ::gpg {
      variable validities [list unknown undefined never marginal full  
ultimate]

      variable Version $::gpgVersion
-    unset gpgVersion
+    unset ::gpgVersion

      # Variable to store public keys
      variable keys
@@ -46,79 +45,24 @@
  }

  # ::gpg::executable --
-# Purpose:
-#  Finds a GnuPG executable in the system using the same rules [exec] does.
-# Returns:
-#  Full pathname of the first occurence of the GnuPG executable found
-#  or an empty string if the search yielded no results.
+#
+#       Find a GnuPG executable in the system using the same rules [exec]  
does.
+#
+# Arguments:
+#       None.
+#
+# Result:
+#       Full pathname of the first occurence of the GnuPG executable found
+#       or an empty string if the search yielded no results.
+#
  # Side effects:
-#  Updates the global Tcl array auto_execs on success (see library(3tcl)).
+#       Updates the global Tcl array auto_execs on success (see  
library(3tcl)).
+
  proc ::gpg::executable {} {
      lindex [auto_execok gpg] 0
  }

-# ::gpg::info --
-#
-
-proc ::gpg::info {args} {
-    variable validities
-
-    switch -- [llength $args] {
-        0 {
-            return [list datatypes signature-status signature-modes \
-                         attributes validity capabilities protocols \
-                         keylist-modes]
-        }
-        1 {
-            set option [lindex $args 0]
-            switch -- $option {
-                datatypes {
-                    return [list none mem fd file cb]
-                }
-                signature-status {
-                    return [list none good bad nokey nosig error diff \
-                                 expired expiredkey revokedkey]
-                }
-                signature-modes {
-                    return [list normal detach clear]
-                }
-                attributes {
-                    return [list keyid fingerprint algorithm length  
created \
-                                 expires owner-trust userid name email  
comment \
-                                 validity level type is-secret key-revoked  
\
-                                 key-invalid uid-revoked uid-invalid \
-                                 key-capability key-expired key-disabled \
-                                 serial issuer chainid signature-status \
-                                 error-token signature-summary]
-                }
-                validity {
-                    return $validities
-                }
-                capabilities {
-                    return [list encrypt sign certify]
-                }
-                protocols {
-                    return [list openpgp cms auto]
-                }
-                keylist-modes {
-                    return [list local extern sigs]
-                }
-                default {
-                    return -code error \
-                           [format "bad option \"%s\": must be datatypes,\
-                                    signature-status, signature-modes,\
-                                    attributes, validity, capabilities,\
-                                    protocols, or keylist-modes" $option]
-                }
-            }
-        }
-        default {
-            return -code error [format "usage: %s option" [lindex [::info  
level 0] 0]]
-        }
-    }
-}
-
-# ::gpg::context --
+# ::gpg::new --
  #
  #       Create a new GPG context token.
  #
@@ -132,10 +76,10 @@
  #       A new procedure and a state variable are created. Also deleting of
  #       the procedure is traced to unset the state variable.

-proc ::gpg::context {} {
+proc ::gpg::new {} {
      variable id

-    if {![::info exists id]} {
+    if {![info exists id]} {
          set id 0
      }

@@ -148,32 +92,33 @@
      # Default settings
      set state(armor) false
      set state(textmode) false
-
-    proc $token {args} "eval {[namespace current]::Exec} {$token} \$args"
-
-    trace add command $token delete [namespace code [list Free $token]]
+    set state(encoding) [encoding system]
+
+    proc $token {args} "eval {[namespace current]::Exec $token} \$args"

      return $token
  }

-# ::gpg::Free --
-#
-#       Unset state variable corresponding to a context token.
+# ::gpg::free --
+#
+#       Unset state variable corresponding to a context token and destroy
+#       the token procedure.
  #
  # Arguments:
  #       token       A GPG context token created in ::gpg::context.
-#       args        (unused) Arguments added by trace.
  #
  # Result
  #       An empty string.
  #
  # Side effects:
-#       A state variable is destroyed.
-
-proc ::gpg::Free {token args} {
+#       A state variable and token procedure are destroyed.
+
+proc ::gpg::Free {token} {
      variable $token
      upvar 0 $token state

+    rename $token ""
+
      catch {unset state}
      return
  }
@@ -181,12 +126,12 @@
  # ::gpg::Exec --
  #
  #       Execute a GPG context operation. This procedure is invoked when a  
user
-#       calls [$token -operation ...].
+#       calls [$token operation ...].
  #
  # Arguments:
  #       token       A GPG context token created in ::gpg::context.
-#       args        Arguments serialized array. It must contain pair
-#                   -operation <op>. The other arguments are operation-
+#       operation   An operation to perform
+#       args        Arguments serialized array. The arguments are  
operation-
  #                   dependent.
  #
  # Result:
@@ -195,45 +140,32 @@
  # Side effects:
  #       The side effects of a corresponding operation.

-proc ::gpg::Exec {token args} {
-    set newArgs {}
-    foreach {key val} $args {
-        switch -- $key {
-            -operation { set op $val }
-            default    { lappend newArgs $key $val }
-        }
-    }
-
-    if {![::info exists op]} {
-        return -code error "missing operation"
-    }
-
-    switch -- $op {
-        cancel    { set res [eval [list Cancel   $token] $newArgs] }
-        wait      { set res [eval [list Wait     $token] $newArgs] }
-        get       { set res [eval [list Get      $token] $newArgs] }
-        set       { set res [eval [list Set      $token] $newArgs] }
-        list-keys { set res [eval [list ListKeys $token] $newArgs] }
-        start-key { set res [eval [list StartKey $token] $newArgs] }
-        next-key  { set res [eval [list NextKey  $token] $newArgs] }
-        done-key  { set res [eval [list DoneKey  $token] $newArgs] }
-        info-key  { set res [eval [list InfoKey  $token] $newArgs] }
-        encrypt   { set res [eval [list Encrypt  $token] $newArgs] }
-        sign      { set res [eval [list Sign     $token] $newArgs] }
-        verify    { set res [eval [list Verify   $token] $newArgs] }
-        decrypt   { set res [eval [list Decrypt  $token] $newArgs] }
+proc ::gpg::Exec {token operation args} {
+    switch -- $operation {
+        cancel    { set res [eval [list Cancel   $token] $args] }
+        wait      { set res [eval [list Wait     $token] $args] }
+        set       { set res [eval [list Set      $token] $args] }
+        unset     { set res [eval [list Unset    $token] $args] }
+        list-keys { set res [eval [list ListKeys $token] $args] }
+        info-key  { set res [eval [list InfoKey  $token] $args] }
+        encrypt   { set res [eval [list Encrypt  $token] $args] }
+        sign      { set res [eval [list Sign     $token] $args] }
+        verify    { set res [eval [list Verify   $token] $args] }
+        decrypt   { set res [eval [list Decrypt  $token] $args] }
+        free      { set res [eval [list Free     $token] $args] }
          default   {
              return -code error \
                     [format "unknown operation \"%s\":\
-                            must be %s" $op [JoinOptions {cancel wait get  
set
-                                                          encrypt decrypt  
sign
-                                                          verify start-key
-                                                          next-key done-key
-                                                          info-key}]]
+                            must be %s" $operation \
+                            [JoinOptions {cancel wait set unset encrypt  
decrypt
+                                          sign verify list-keys info-key
+                                          free}]]
          }
      }

-    set state(last-op-info) $op
+    if {![string equal $operation free]} {
+        set state(last-op-info) $operation
+    }
      return $res
  }

@@ -270,7 +202,6 @@

      Debug 2 "$token $args"

-    set value ""
      foreach {key val} $args {
          switch -- $key {
              -property { set prop  $val }
@@ -278,39 +209,47 @@
              default   {
                  return -code error \
                         [format "unknown option \"%s\":\
-                                must be %s" $op [JoinOptions {-operation
-                                                              -property
-                                                              -value}]]
+                                must be %s" $key [JoinOptions {-property
+                                                               -value}]]
              }
          }
      }

      variable properties [list protocol armor textmode number-of-certs \
                                keylistmode passphrase-callback \
-                              progress-callback idle-callback signers]
-
-    if {![::info exists prop]} {
+                              progress-callback idle-callback signers \
+                              encoding]
+
+    if {![info exists prop]} {
          return -code error \
                 [format "missing property:\
                          must be %s" $prop [JoinOptions $properties]]
      } elseif {[lsearch -exact $properties $prop] >= 0} {
-        switch -- $prop {
-            armor -
-            textmode {
-                if {[string is boolean -strict $value]} {
+        if {![info exists value]} {
+            if {[info exists state($prop)]} {
+                return $state($prop)
+            } else {
+                return -code error [format "property \"%s\" isn't set"  
$prop]
+            }
+        } else {
+            switch -- $prop {
+                armor -
+                textmode {
+                    if {[string is boolean -strict $value]} {
+                        set state($prop) $value
+                    } else {
+                        return -code error \
+                               [format "invalid %s value \"%s\":\
+                                        must be boolean" $prop $value]
+                    }
+                }
+                default {
+                    # TODO: Checking other properties values
                      set state($prop) $value
-                } else {
-                    return -code error \
-                           [format "invalid %s value \"%s\":\
-                                    must be boolean" $prop $value]
                  }
              }
-            default {
-                # TODO: Checking other properties values
-                set state($prop) $value
-            }
-        }
-        return
+            return $state($prop)
+        }
      } else {
          return -code error \
                 [format "unknown property \"%s\":\
@@ -318,23 +257,21 @@
      }
  }

-# ::gpg::Get --
-#
-#       Return the value of a given GPG context property.
+# ::gpg::Unset --
+#
+#       Unset a given GPG context property.
  #
  # Arguments:
  #       token           A GPG context token created in ::gpg::context.
  #       -property prop  A property name.
  #
  # Result:
-#       A given property value if it's set, or empty string if it's unset
-#       in case of success, or an error if a property is missing
-#       or unknown.
+#       Empty string or error if property is missing or unknown.
  #
  # Side effects:
-#       None.
-
-proc ::gpg::Get {token args} {
+#       Property variable is unset.
+
+proc ::gpg::Unset {token args} {
      variable $token
      upvar 0 $token state

@@ -346,8 +283,7 @@
              default   {
                  return -code error \
                         [format "unknown option \"%s\":\
-                                must be %s" $op [JoinOptions {-operation
-                                                              -property}]]
+                                must be %s" $key [JoinOptions {-property}]]
              }
          }
      }
@@ -355,23 +291,23 @@
      set properties [list protocol armor textmode number-of-certs \
                           keylistmode passphrase-callback \
                           progress-callback idle-callback signers \
-                         last-op-info]
-
-    if {![::info exists prop]} {
+                         encoding last-op-info]
+
+    if {![info exists prop]} {
          return -code error \
                 [format "missing property:\
                          must be %s" $prop [JoinOptions $properties]]
      } elseif {[lsearch -exact $properties $prop] >= 0} {
-        if {[::info exists state($prop)]} {
-            return $state($prop)
-        } else {
-            return ""
+        if {[info exists state($prop)]} {
+            unset state($prop)
          }
      } else {
          return -code error \
                 [format "unknown property \"%s\":\
                          must be %s" $prop [JoinOptions $properties]]
      }
+
+    return
  }

  # ::gpg::Sign --
@@ -404,19 +340,18 @@
              default {
                  return -code error \
                         [format "unknown option \"%s\":\
-                                must be %s" $op [JoinOptions {-operation
-                                                              -input
-                                                              -mode
-                                                              -command}]]
+                                must be %s" $key [JoinOptions {-input
+                                                               -mode
+                                                               -command}]]
              }
          }
      }

-    if {![::info exists input]} {
+    if {![info exists input]} {
          return -code error "missing input to sign"
      }

-    if {[Get $token -property armor]} {
+    if {![catch {Set $token -property armor} armor] && $armor} {
          set params {--armor}
      } else {
          set params {--no-armor}
@@ -436,7 +371,10 @@
      }

      array set tmp {}
-    foreach key [Get $token -property signers] {
+    if {[catch {Set $token -property signers} signers]} {
+        set signers {}
+    }
+    foreach key $signers {
          array unset tmp
          array set tmp [InfoKey $token -key $key]
          lappend params -u $tmp(keyid)
@@ -496,20 +434,19 @@
              default {
                  return -code error \
                         [format "unknown option \"%s\":\
-                                must be %s" $op [JoinOptions {-operation
-                                                              -input
-                                                              -recipients
-                                                              -sign
-                                                              -command}]]
+                                must be %s" $key [JoinOptions {-input
+                                                               -recipients
+                                                               -sign
+                                                               -command}]]
              }
          }
      }

-    if {![::info exists input]} {
+    if {![info exists input]} {
          return -code error "missing input to encrypt"
      }

-    if {[Get $token -property armor]} {
+    if {![catch {Set $token -property armor} armor] && $armor} {
          set params {--armor}
      } else {
          set params {--no-armor}
@@ -518,16 +455,19 @@
      if {$sign} {
          lappend params --sign
          array set tmp {}
-        foreach key [Get $token -property signers] {
+        if {[catch {Set $token -property signers} signers]} {
+            set signers {}
+        }
+        foreach key $signers {
              array unset tmp
              array set tmp [InfoKey $token -key $key]
              lappend params -u $tmp(keyid)
          }
      }

-    if {[::info exists recipients]} {
+    if {[info exists recipients]} {
          if {[RecipientCount $recipients] == 0} {
-            return -code error "no recipents in token"
+            return -code error "no recipients in token"
          }

          lappend params --encrypt
@@ -591,19 +531,18 @@
              default    {
                  return -code error \
                         [format "unknown option \"%s\":\
-                                must be %s" $op [JoinOptions {-operation
-                                                              -signature
-                                                              -input
-                                                              -command}]]
+                                must be %s" $key [JoinOptions {-signature
+                                                               -input
+                                                               -command}]]
              }
          }
      }

-    if {![::info exists signature]} {
+    if {![info exists signature]} {
          return -code error "missing signature to verify"
      }

-    if {[::info exists input]} {
+    if {[info exists input]} {
          set gpgChannels [ExecGPG $token --verify -- $signature]
          return [UseGPG $token verify $commands $gpgChannels $input]
      } else {
@@ -653,15 +592,14 @@
              default {
                  return -code error \
                         [format "unknown option \"%s\":\
-                                must be %s" $op [JoinOptions {-operation
-                                                              -input
-                                                              -checkstatus
-                                                              -command}]]
+                                must be %s" $key [JoinOptions {-input
+                                                               -checkstatus
+                                                               -command}]]
              }
          }
      }

-    if {![::info exists input]} {
+    if {![info exists input]} {
          return -code error "missing input to decrypt"
      }

@@ -723,8 +661,7 @@
              default {
                  return -code error \
                         [format "unknown option \"%s\":\
-                                must be %s" $key [JoinOptions {-operation
-                                                               -patterns
+                                must be %s" $key [JoinOptions {-patterns
                                                                 -secretonly
                                                                 -command}]]
              }
@@ -733,119 +670,6 @@

      return [FindKeys $token $operation $commands $patterns]
  }
-
-# ::gpg::StartKey --
-#
-#       Start an element-by-element traversing through a key list.
-#
-# Arguments:
-#       token               A GPG context token created in ::gpg::context.
-#       -patterns patterns  A list of patterns to search for in keys  
available
-#                           to GnuPG. Patterns may contain key ID,  
fingerprint,
-#                           user ID etc. See gpg(1) manual page for  
details.
-#       -secretonly bool    (optional, defaults to false) A boolean which  
shows
-#                           if secret keys should be found. If false then  
only
-#                           public keys are searched.
-#
-# Result:
-#       Empty string or error if a search is already started earlier.
-#
-# Side effects:
-#       A global keys array is populated by keys which match given  
patterns.
-#       Also, NextKey becomes usable.
-
-proc ::gpg::StartKey {token args} {
-    variable $token
-    upvar 0 $token state
-
-    if {[::info exists state(keyidx)]} {
-        return -code error \
-               "already doing a key listing, end that one first"
-    }
-
-    set patterns {}
-    set operation --list-keys
-
-    foreach {key val} $args {
-        switch -- $key {
-            -patterns {
-                set patterns $val
-            }
-            -secretonly {
-                if {[string is true -strict $val]} {
-                    set operation --list-secret-keys
-                } elseif {![string is false -strict $val]} {
-                    return -code error \
-                           [format "invalid -secretonly value \"%s\":\
-                                    must be boolean" $val]
-                }
-            }
-            default {
-                return -code error \
-                       [format "unknown option \"%s\":\
-                                must be %s" $key [JoinOptions {-operation
-                                                               -patterns
-                                                                
-secretonly}]]
-            }
-        }
-    }
-
-    set state(keylist) [FindKeys $token $operation {} $patterns]
-    set state(keyidx) -1
-
-    return
-}
-
-# ::gpg::NextKey --
-#
-#       Return the next element in a key search started by StartKey.
-#
-# Arguments:
-#       token               A GPG context token created in ::gpg::context.
-#
-# Result:
-#       A key fingerprint or empty string if a list is ended. Error is
-#       returned if a search wasn't started yet.
-#
-# Side effects:
-#       None.
-
-proc ::gpg::NextKey {token} {
-    variable $token
-    upvar 0 $token state
-
-    if {![::info exists state(keyidx)]} {
-        return -code error "not doing a key listing"
-    }
-
-    return [lindex $state(keylist) [incr state(keyidx)]]
-}
-
-# ::gpg::DoneKey --
-#
-#       Finish a key search started by StartKey.
-#
-# Arguments:
-#       token               A GPG context token created in ::gpg::context.
-#
-# Result:
-#       Empty string or error if a search isn't started yet.
-#
-# Side effects:
-#       Search is finished, so NextKey will return error.
-
-proc ::gpg::DoneKey {token} {
-    variable $token
-    upvar 0 $token state
-
-    if {![::info exists state(keyidx)]} {
-        return -code error "not doing a key listing"
-    }
-
-    unset state(keylist)
-    unset state(keyidx)
-    return
-}

  # ::gpg::InfoKey --
  #
@@ -874,17 +698,16 @@
              default {
                  return -code error \
                      [format "unknown option \"%s\":\
-                             must be %s" $key [JoinOptions {-operation
-                                                            -key}]]
+                             must be %s" $key [JoinOptions {-key}]]
              }
          }
      }

-    if {![::info exists fingerprint]} {
+    if {![info exists fingerprint]} {
          return -code error "missing key"
      }

-    if {[::info exists keys($fingerprint)]} {
+    if {[info exists keys($fingerprint)]} {
          return $keys($fingerprint)
      } else {
          return -code error "invalid key"
@@ -954,7 +777,7 @@
      variable $fd
      upvar 0 $fd state

-    if {![::info exists state(res)]} {
+    if {![info exists state(res)]} {
          set state(res) {}
          set state(key) {}
          set state(subkey) {}
@@ -980,7 +803,7 @@
                      lappend state(key) subkeys $state(subkeys)
                  }
                  array set tmp $state(key)
-                if {[::info exists tmp(fingerprint)]} {
+                if {[info exists tmp(fingerprint)]} {
                      set keys($tmp(fingerprint)) $state(key)
                      lappend state(res) $tmp(fingerprint)
                  }
@@ -1030,7 +853,7 @@
              lappend state(key) state(subkeys) $state(subkeys)
          }
          array set tmp $state(key)
-        if {[::info exists tmp(fingerprint)]} {
+        if {[info exists tmp(fingerprint)]} {
              set keys($tmp(fingerprint)) $state(key)
              lappend state(res) $tmp(fingerprint)
          }
@@ -1244,7 +1067,9 @@

      # Set --textmode option before calling CExecGPG to make it simpler.

-    set textmode [Get $token -property textmode]
+    if {[catch {Set $token -property textmode} textmode]} {
+        set textmode false
+    }

      if {$textmode} {
          set args [linsert $args 0 --textmode]
@@ -1254,7 +1079,13 @@
          set args [linsert $args 0 --no-textmode]
      }

-    if {[::info commands [namespace current]::CExecGPG] ne ""} {
+    # Set proper encoding
+
+    if {[catch {Set $token -property encoding} encoding]} {
+        set encoding [encoding system]
+    }
+
+    if {[info commands [namespace current]::CExecGPG] ne ""} {

          # C-based GPG invocation will use pipes instead of temporary files,
          # so in case of decryption or verification of a detached signature
@@ -1268,6 +1099,8 @@
              set channels [eval CExecGPG [executable] $args]
              set input_fd [lindex $channels end]

+            fconfigure $input_fd -encoding $encoding
+
              if {$textmode} {
                  fconfigure $input_fd -translation crlf
              }
@@ -1275,10 +1108,25 @@
              puts -nonewline $input_fd $input
              close $input_fd

-            return [linsert [lrange $channels 0 end-1] 0 ""]
+            set channels [lrange $channels 0 end-1]
          } else {
-            return [linsert [eval CExecGPG [executable] $args] 0 ""]
-        }
+            set channels [eval CExecGPG [executable] $args]
+        }
+
+        # stdin
+        fconfigure [lindex $channels 0] -encoding $encoding -buffering none
+        # stdout
+        fconfigure [lindex $channels 1] -encoding $encoding
+        # stderr
+        fconfigure [lindex $channels 2] -encoding utf-8
+        # status-fd
+        fconfigure [lindex $channels 3] -encoding utf-8
+        if {[llength $channels] == 5} {
+            # command-fd
+            fconfigure [lindex $channels 4] -encoding $encoding -buffering  
none
+        }
+
+        return [linsert $channels 0 ""]
      }

      # For decryption or verification of a detached signature we use a
@@ -1318,6 +1166,8 @@
          set name_fd [TempFile]
          foreach {filename fd} $name_fd break

+        fconfigure $input_fd -encoding $encoding
+
          if {$textmode} {
              fconfigure $fd -translation crlf
          }
@@ -1352,6 +1202,7 @@

      set pList [pipe]
      foreach {pRead pWrite} $pList break
+    fconfigure $pRead -encoding $encoding

      set qList [pipe]
      foreach {qRead qWrite} $qList break
@@ -1364,7 +1215,7 @@
      Debug 2 [linsert $args 0 [executable]]

      set fd [open |[linsert $args 0 [executable]] w]
-    fconfigure $fd -translation binary -buffering none
+    fconfigure $fd -encoding $encoding -buffering none
      close $pWrite
      close $qWrite

@@ -1414,13 +1265,10 @@
          verify {
              # Here $input contains either a signature, or a signed material
              # if a signature is detached.
-            fconfigure $stdin_fd -encoding binary
              puts -nonewline $stdin_fd $input
              catch {close $stdin_fd}
          }
      }
-
-    fconfigure $status_fd -encoding utf-8

      if {[llength $commands] == 0} {
          # Synchronous mode, so make channel blocking and parse its contents
@@ -1454,7 +1302,7 @@

      # Collect signatures if any (if operation is decrypt-check or verify)

-    if {![::info exists state(signatures)]} {
+    if {![info exists state(signatures)]} {
          set state(signatures) {}
      }

@@ -1474,54 +1322,46 @@
                  break
              }
              USERID_HINT {
-                set state(userid_hint) [join [lrange $fields 2 end]]
+                set state(userid_hint) [join [lrange $fields 3 end]]
              }
              NEED_PASSPHRASE {
                  if {![package vsatisfies $Version 2.0]} {
-                    if {![::info exists state(hint)]} {
-                        set state(hint) ENTER
+                    if {![info exists state(hint)]} {
+                        set state(hint) enter
                      } else {
-                        set state(hint) TRY_AGAIN
-                    }
-                    set pcb [Get $token -property passphrase-callback]
-                    if {$pcb eq ""} {
-                        CleanupGPG $channels
-                        if {[llength $commands] == 0} {
-                            return -code error "No passphrase"
-                        } else {
-                            uplevel #0 [lindex $commands 0] \
-                                       [list error "No passphrase"]
-                            return
-                        }
-                    }
-                    set desc \
-                        [join [list $state(hint) $state(userid_hint) \
-                                    [join [lrange $fields 2 end] " "]] \
-                              "\n"]
-                    Debug 2 $desc
-                    puts $command_fd \
-                         [eval $pcb [list [list token $token \
-                                                description $desc]]]
-                    flush $command_fd
+                        set state(hint) try_again
+                    }
+                    if {[catch {Set $token -property passphrase-callback}  
pcb]} {
+                        NoPassphrase $channels $commands
+                    }
+                    set arglist [list token $token \
+                                      hint $state(hint) \
+                                      userid $state(userid_hint) \
+                                      keyid [lindex $fields 2] \
+                                      subkeyid [lindex $fields 3]]
+                    Debug 2 $arglist
+                    if {[catch {eval $pcb [list $arglist]} passphrase]} {
+                        NoPassphrase $channels $commands
+                    } else {
+                        puts $command_fd $passphrase
+                        flush $command_fd
+                    }
                  }
              }
              NEED_PASSPHRASE_SYM {
                  if {![package vsatisfies $Version 2.0]} {
-                    set pcb [Get $token -property passphrase-callback]
-                    if {$pcb eq ""} {
-                        CleanupGPG $channels
-                        if {[llength $commands] == 0} {
-                            return -code error "No passphrase"
-                        } else {
-                            uplevel #0 [lindex $commands 0] \
-                                       [list error "No passphrase"]
-                            return
-                        }
-                    }
-                    puts $command_fd \
-                         [eval $pcb [list [list token $token \
-                                                description ENTER]]]
-                    flush $command_fd
+                    if {[catch {Set $token -property passphrase-callback}  
pcb]} {
+                        NoPassphrase $channels $commands
+                    }
+                    if {[catch {
+                            eval $pcb [list [list token $token \
+                                                  hint enter]]
+                         } passphrase]} {
+                        NoPassphrase $channels $commands
+                    } else {
+                        puts $command_fd $passphrase
+                        flush $command_fd
+                    }
                  }
              }
              KEYEXPIRED {
@@ -1619,7 +1459,7 @@
                      set state(sig:expires) [lindex $fields 5]
                  }
                  set state(sig:key) [lindex $fields 11]
-                if {![::info exists keys($state(sig:key))]} {
+                if {![info exists keys($state(sig:key))]} {
                      FindKeys $token --list-keys {} $state(sig:key)
                  }
              }
@@ -1671,6 +1511,16 @@

      return
  }
+
+proc ::gpg::NoPassphrase {channels commands} {
+    CleanupGPG $channels
+    if {[llength $commands] == 0} {
+        return -code error "No passphrase"
+    } else {
+        uplevel #0 [lindex $commands 0] [list error "No passphrase"]
+        return
+    }
+}

  proc ::gpg::FinishGPG {token operation channels input} {
      foreach {filename stdin_fd stdout_fd stderr_fd status_fd command_fd} \
@@ -1726,14 +1576,13 @@
              puts -nonewline $stdin_fd $input
              catch {close $stdin_fd}

-            if {![Get $token -property armor]} {
-                fconfigure $stdout_fd -translation binary
+            if {[catch {Set $token -property armor} armor] || !$armor} {
+                fconfigure $stdout_fd -translation lf
              }

              set data [read $stdout_fd]
          }
          decrypt {
-            fconfigure $stdout_fd -translation binary
              set plaintext [read $stdout_fd]
              set data [list plaintext $plaintext]
          }
@@ -1742,7 +1591,6 @@
              # "" means verifying non-detached signature, so gpg reports
              # the signed message to stdout.

-            fconfigure $stdout_fd -translation binary
              set plaintext [read $stdout_fd]
              set data [list plaintext $plaintext status $status \
                             signatures $state(signatures)]
@@ -1777,6 +1625,9 @@
      if {$filename ne ""} {
          file delete -force -- $filename
      }
+
+    # Clean up zombie which tclsh leaves when executes gpg in the  
background
+    catch {exec {}}

      return
  }
@@ -1798,7 +1649,7 @@
  proc ::gpg::recipient {} {
      variable rid

-    if {![::info exists rid]} {
+    if {![info exists rid]} {
          set rid 0
      }

@@ -1808,31 +1659,30 @@

      set state(recipients) {}

-    proc $token {args} "eval {[namespace current]::RecipientExec} {$token}  
\$args"
-
-    trace add command $token delete [namespace code [list RecipientFree  
$token]]
+    proc $token {args} "eval {[namespace current]::RecipientExec $token}  
\$args"

      return $token
  }
***The diff for this file has been truncated for email.***


More information about the Tkabber-dev mailing list