Добавил проверку пакета Img. И поправил проверку типов изображений
All checks were successful
Gitea Actions Demo / Explore-Gitea-Actions (push) Successful in 1m23s
All checks were successful
Gitea Actions Demo / Explore-Gitea-Actions (push) Successful in 1m23s
This commit is contained in:
1
debian/changelog
vendored
1
debian/changelog
vendored
@@ -394,4 +394,3 @@ projman (2.0.0-alfa0) stable; urgency=medium
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -9,12 +9,42 @@
|
||||
|
||||
|
||||
namespace eval FileOper {
|
||||
variable types
|
||||
global packages
|
||||
variable types
|
||||
|
||||
set ::types {
|
||||
{"All files" *}
|
||||
}
|
||||
|
||||
# Проверка поддерживаемых типов изображений
|
||||
# в зависимости устновлен пакет или нет
|
||||
proc SupportImageType {type} {
|
||||
if {[PackagePresent Img] eq "true"} {
|
||||
switch $type {
|
||||
jpeg { return true }
|
||||
png { return true }
|
||||
gif { return true }
|
||||
bmp { return true }
|
||||
svg { return true }
|
||||
ppm { return true }
|
||||
pgm { return true }
|
||||
tiff { return true }
|
||||
xbm { return true }
|
||||
xpm { return true }
|
||||
default { return false}
|
||||
}
|
||||
} else {
|
||||
switch $type {
|
||||
png { return true }
|
||||
gif { return true }
|
||||
bmp { return true }
|
||||
svg { return true }
|
||||
ppm { return true }
|
||||
pgm { return true }
|
||||
default { return false}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc GetFileMimeType {fileFullPath {opt ""}} {
|
||||
global cfgVariables
|
||||
# Проверям наличие программы в системе, если есть то добавляем опции
|
||||
@@ -76,15 +106,15 @@ namespace eval FileOper {
|
||||
if {$fBinaryType ne ""} {
|
||||
switch $fBinaryType {
|
||||
"graphic" {
|
||||
if {$fBinaryInterp ne "png" && $fBinaryInterp ne "gif" && $fBinaryInterp ne "ppm" && $fBinaryInterp ne "pgm"} {
|
||||
if {[SupportImageType $fBinaryInterp] eq "true"} {
|
||||
return image
|
||||
} else {
|
||||
set answer [tk_messageBox -message [::msgcat::mc "The file looks like a image. Support not implemented yet."] -icon question -type ok]
|
||||
switch $answer {
|
||||
ok {
|
||||
return false
|
||||
}
|
||||
}
|
||||
} else {
|
||||
return image
|
||||
}
|
||||
}
|
||||
default {
|
||||
@@ -99,14 +129,15 @@ namespace eval FileOper {
|
||||
return text
|
||||
}
|
||||
"image" {
|
||||
if {$fBinaryInterp ne "png" && $fBinaryInterp ne "gif" && $fBinaryInterp ne "ppm" && $fBinaryInterp ne "pgm" && $fBinaryInterp} {
|
||||
if {[SupportImageType $fBinaryInterp] eq "true"} {
|
||||
return image
|
||||
} else {
|
||||
set answer [tk_messageBox -message [::msgcat::mc "The file looks like a image. Support not implemented yet."] -icon question -type ok]
|
||||
switch $answer {
|
||||
ok {
|
||||
return false
|
||||
}
|
||||
}
|
||||
return image
|
||||
}
|
||||
}
|
||||
"empty" {
|
||||
|
||||
@@ -54,7 +54,7 @@ proc ImageBase64Encode {text} {
|
||||
{"GIF" {.gif}}
|
||||
{"JPEG" {.jpg}}
|
||||
{"BMP" {.bmp}}
|
||||
# {"SVG" {.svg}}
|
||||
{"SVG" {.svg}}
|
||||
{"All files" *}
|
||||
}
|
||||
set img [tk_getOpenFile -initialdir $env(HOME) -filetypes $types -parent .]
|
||||
|
||||
20
projman.tcl
20
projman.tcl
@@ -1,6 +1,6 @@
|
||||
#!/bin/sh
|
||||
# Tcl ignores the next line -*- tcl -*- \
|
||||
exec wish8.6 "$0" -- "$@"
|
||||
exec wish9.0 "$0" -- "$@"
|
||||
|
||||
######################################################
|
||||
# Tcl/Tk Project manager 2.0
|
||||
@@ -43,6 +43,24 @@ package require fileutil
|
||||
# package require Thread
|
||||
package require fileutil::magic::filetype
|
||||
|
||||
# Определим установлен ли пакет Img для расширенной поддержки изображений
|
||||
proc PackagePresent {pkg} {
|
||||
# puts $pkg
|
||||
foreach item [package names] {
|
||||
# puts [string match -nocase Img $item]
|
||||
if {[string match -nocase Img $item] == 1} {
|
||||
puts "The $pkg package was found"
|
||||
return true
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[PackagePresent "Img"] eq "true"} {
|
||||
package require Img
|
||||
} else {
|
||||
puts "Img not present"
|
||||
}
|
||||
|
||||
# Устанавливаем текущий каталог
|
||||
set dir(root) [pwd]
|
||||
set dir(doc) [file join $dir(root) doc]
|
||||
|
||||
@@ -6,8 +6,8 @@
|
||||
#
|
||||
# $Id: black.tcl,v 1.2 2009/10/25 19:21:30 oberdorfer Exp $
|
||||
|
||||
package require Tk 8.4; # minimum version for Tile
|
||||
package require tile 0.8; # depends upon tile
|
||||
package require Tk; # minimum version for Tile
|
||||
package require tile; # depends upon tile
|
||||
|
||||
|
||||
namespace eval ttk {
|
||||
|
||||
Reference in New Issue
Block a user