DBCompact ;;Утилита сжатия баз данных Cache' 4.x и 5.x | вер.1.0.1 бета | Квирикадзе В.Р.(с) | 7 Января 2005
 ;
 new i,db,mgr,x,list,f,msg,replace
 goto interfaceFOOL
 quit
 ;
 ;d %swset^|"%SYS"|SWSET(10,1) ; запрет активности
 ;
 ;d %swset^|"%SYS"|SWSET(10,0) ; разрешение
 ;
 ;
 ; Основная рабочая точка входа
 ;__$$compact^%ZDBCompact(dataset,[inplace],[show])
 ;   где:
 ;      dataset = ^^путь\к\базе\данных\
 ;      inplace = 1 - сжать и заменить существующую (опасно! осторожно!)
 ;                0 - создать сжатую копию (безопасно)
 ;      show    = 1 - показывать индикатор (точки)          
 ;                0 - не показывать индикатор
 ;   возврат: меньше или = 0 - Завершено более-менее нормально (особенно когда 0 или -2)
 ;            больше 0 - Ошибка
 ;   расшифровка ошибки = $t(errs+(errnum+2)^%ZDBCompact) где errnum = код ошибки         
compact(ds,inplace,showdots)
 new i,dir,dt,mgr,dsd,globref,grs,grd,status,f,dtgtd,dsbak,dsstat,dtstat,err,dirn
 if $$cmver<4 quit 25
 set inplace=$g(inplace)
 if inplace'= 1  set inplace= 0  
 set showdots=$g(showdots)
 if showdots'=1 set showdots=0 
 set ds=$g(ds)
 if $e(ds,1,2)'="^^" quit  3 
 if ds="" quit  5 
 if $e(ds,$l(ds))'=$$fschr set ds=ds_$$fschr
 set dsd=$p(ds,"^",3)
 if dsd="" quit 2
 set dtgt=ds_"~COMPRESSED~"_$$fschr
 if $e(dtgt,1,2)'="^^" quit  3 
 if $e(dtgt,$l(dtgt))'=$$fschr set dtgt=dtgt_$$fschr
 set dtgtd=$p(dtgt,"^",3)
 if dtgtd="" quit 2
 set mgr="^^"_$zu(12)
 if '$d(^|mgr|SYS("UCI",dsd)) quit  6 
 set dir=dtgtd
 set dirn=$e(dir, 1 ,$l(dir)- 1 )
 if $zu( 140 , 4 ,dirn)= 0  do
 . for i= 1 : 1 : 20  set status=$zu( 3 ,dir) quit:status> 0   hang  1 
 . if $$Delete^%Wsdb(dir)
 . if $zu( 140 , 5 ,dir_"CACHE.DAT")
 . quit
 ;
 ;path1=source
 ;path2=destination
 ;
 ;ds = ^^[path1]\
 ;dtgt = ^^[path2]\
 ;dsd = [path1]\
 ;dtgtd = [path2]\
 ;dir = [path2]\
 ;dt = ^^[path2]\
 ;
 if $zu( 140 , 4 ,dirn)'=0 if $zu(140,9,dir)<0 quit 13
 set $zt="errdel"
 set status=$$Delete^%Wsdb(dir)
 set $zt=""
 if $zu(140,1,dir_"CACHE.DAT")'< 0  quit  1 
 if $zu( 140 , 1 ,dir_"cache.dat")'<0 quit 1
 if $zu(140,1,dir_"Cache.DAT")'< 0  quit  1 
 if $zu( 140 , 1 ,dir_"Cache.dat")'<0 quit 1
 if $zu(140,1,dir_"cache.DAT")'< 0  quit  1 
 if $zu( 140 , 1 ,dir_"CACHE.dat")'<0 quit 1
 set $zt="errcreate"
 if $$cmver=4 set status=$$Create^%Wsdb(dir,1,8192)
 if $$cmver=5 set status=$$Create^%Wsdb(dir,1,8192,5)
 set $zt=""
 if +status=0 quit 2
 set dt="^^"_dir
 set globref=""
 for  set globref=$o(^$|ds|GLOBAL(globref)) quit:globref=""  do
  . set grs="^|"""_ds_"""|"_$p(globref,"^",2)
  . set grd="^|"""_dt_"""|"_$p(globref,"^",2)
  . merge @grd=@grs
  . if showdots write "."
  . quit
 for i=1:1:20 set status=$zu(3,dir) quit:status>0  hang 1
 hang 1
 set dtstat=status
 set status=$zu(36,dir,0,0,dsd)  ;__Изменяем метку базы!
 do clearUCI(dir)
 if 'inplace quit - 2 
 if dtstat'>0 quit 14
 ;__Проверим соответствуют ли наименования существующих файлов (это скорее для Юникса)
 if $zu(140,1,dir_"CACHE.DAT")<0 quit 16
 if $zu(140,1,dsd_"CACHE.DAT")<0 quit 17
 set dsbak=dsd_"CACHE."_$p($h,",",1)_"."_$p($h,",",2)_".BAK"
 hang 1
 ;__Теперь надо аккуратно подменить базу!
 ; для этого:
 ; отмонтировать dsd (database source dir)
 ; если удачно: скопировать старую базу в ВАК
 ;              скопировать новую на место старой
 ;              попытаться смонтировать старую базу (уже новую)
 ;              если удалось:
 ;                            удалить компрессированую target базу
 ;                            все
 ;              если не удалось:
 ;                            вернуть ВАК на место
 ;                            попытаться смонтировать старую базу
 ;                            если не вышло: Все! "пришел полярный лис"!
 ;                            если вышло: Говорим что не смогли... хай ищут сжатую базу и руцями...
 ; если не удачно:  Говорим что не смогли... хай ищут сжатую базу и руцями...
 ; 
 ;
 ;
 ;__пытаемся отмонтировать старую базу
 for i=1:1:20 set status=$zu(3,dsd) quit:status>0  hang 1
 hang 1
 set dsstat=status
 if dsstat'> 0  quit  15    ;__если не удалось (крепко держится!)
 set status=$zu( 140 , 11 ,dsd_"CACHE.DAT",dsbak)
 if status'=0 quit $s($$mountold:18,1:19)
 set status=$zu(140,11,dir_"CACHE.DAT",dsd_"CACHE.DAT")
 if status'= 0  quit $s($$mountold: 20 , 1 : 21 )
 set status=$$mountold
 if 'status set err=22 do  quit err
  . set status=$zu(140,11,dsbak,dsd_"CACHE.DAT")
  . if status'= 0  set err= 23  quit
  . set status=$$mountold
  . if 'status set err=24
  . quit
 if '$$delcompressed quit - 1 
 quit  0 
 ;
clearUCI(dirname)
 if $g(dirname)="" quit
 if $d(^SYS("UCI",dirname)) if $zu( 49 ,dirname, 0 )< 0  kill ^SYS("UCI",dirname)
 quit
 ;
mountold()
 new i,status
 for i= 1 : 1 : 20  set status=$zu( 17 ,dsd, 0 , 0 ) quit:status> 0   hang  1 
 hang  1 
 quit $s(status> 0 : 1 , 1 : 0 )
 ;
delcompressed()
 new status,lst
 kill lst
 set status=+$$Delete^%Wsdb(dir)
 set status='status
 if $zu(140,4,dir_"CACHE.DAT")=0 set status=$zu(140,5,dir_"CACHE.DAT")
 if status'= 0  quit  0 
 set status=$$ListDir(dir_"*","lst")
 if '$d(lst) quit $s($zu(140,10,dir)=0:1,1:0)
 quit 1
 ;
errcreate set $zt="" quit 2
errdel set $zt="" quit 7
 ;
 ;
ListDir(spec,ref) 
 new path,fatr,n,atr,fn,char
 set char=$$fschr
 kill @ref
 set path=$tr(spec,"/\",$tr($j("",2)," ",char))
 if $$FindFirst for  if '$$FindNext quit
 quit  0 
FindFirst() 
 set n=$zsearch(path)
 if n'="" do GetFileAttr
 quit n'=""
FindNext() 
 set n=$zsearch("")
 if n'="" do GetFileAttr
 quit n'=""
GetFileAttr
 set fn=$p(n,char,$l(n,char))
 if $tr(fn,".")="" quit
 set @ref@(fn)=""
 quit
 ;
fschr() if $$isUNIX quit "/"
 quit "\"
 ;
isUNIX() quit $zv["UNIX"
 ;
cmver() if $zv[" 4." quit  4 
 if $zv[" 5." quit  5 
 quit  3 
 ;
cachedir()
 quit $p($zu( 86 ),$$fschr, 1 ,$l($zu( 86 ),$$fschr)- 1 )
 ;
 ;
 ;
 ;
 ;
errs ;;- 2 ;Successful! Compressed DB placed in ;Успешно! Сжатая БД находится в 
 ;;- 1 ;Successful, but can't remove Temporary DB;Успешно, но не удалось удалить временную БД
 ;;0;Successful, all done;Успешно, все готово
 ;;1;Temporary DB already exists;Временная БД уже существует
 ;;2;Can't create temporary DB;Не удалось создать временную БД
 ;; 3 ;Only be local DB (^^path);Только для локальных БД (^^путь)
 ;; 4 ;Can't compact SYSMGR DB;Не могу сжимать БД SYSMGR
 ;;5;DB not specified for compaction;Не указана ДБ для сжатия
 ;;6;DB not exists;БД не существует
 ;;7;Can't delete temporary DB;Не могу удалить временную БД
 ;; 8 ;;
 ;; 9 ;;
 ;; 10 ;;
 ;; 11 ;;
 ;; 12 ;;
 ;; 13 ;Can't create directory for temporary DB;Не могу создать директорию для временной БД
 ;;14;Can't dismount temporary DB after compaction;Не удалось размонтировать временную БД после сжатия
 ;; 15 ;Can't dismount source DB after compaction;Не удалось размонтировать исходную БД после сжатия
 ;;16;Can't find file appropriate to temporary DB;Не могу найти файл соответствующий временной БД (CACHE.DAT)
 ;; 17 ;Can't find file appropriate to source DB;Не могу найти файл соответствующий исходной БД (CACHE.DAT)
 ;;18;Can't create backup copy of source DB;Не удалось сделать резервную копию исходной БД
 ;; 19 ;FATAL! Can't mount source DB! Can't create backup copy;FATAL! Не могу смонтировать исходную БД! Не удалось сделать резервную копию
 ;; 20 ;Can't copy temporary DB to source DB;Не могу скопировать временную БД в исходную БД
 ;;21;FATAL! Can't mount source DB on copying temporary DB to source DB;FATAL! Не могу смонтировать исходную БД при копиров. временной БД в исходную
 ;; 22 ;Can't mount compressed DB, returned to previous state;Не удалось смонтировать сжатую БД, возвращено в исходное состояние
 ;;23;FATAL! Can't restore of source DB from backup copy!;FATAL! Не удалось восстановить исходную БД из резервной копии!
 ;; 24 ;FATAL! Can't mount source DB after restoration from backup copy!;FATAL! Не удалось смонтировать исходную БД восстановленную резервной копии!
 ;;25;FATAL! Cache version not supported by this utility!;FATAL! Версия Cache' не поддерживается данной утилитой!
 ;; 26 
 ;;
 ;
 ;
 ;
createDBlist
 kill db
 kill list
 if $$cmver= 4  goto createDBlist4
 for i= 0 : 1  set db=$zu( 49 ,i, 3 ) quit:db< 0   if $e(db, 1 )= 0  set db=$p(db,"^", 2 ) set db(i)=db
 quit
createDBlist4
 new mgr
 set mgr="^^"_$zu( 12 )
 set db=""
 for i= 0 : 1  set db=$o(^|mgr|SYS("UCI",db)) quit:db=""  do
  . if $p($zu( 49 ,db, 0 ),",", 1 )< 1  quit
  . if $p($zu( 49 ,db, 0 ),",", 1 )> 254  quit
  . set db(i)=db
 quit
 ;
interfaceFOOL
 set mgr=$zu( 12 )
 do createDBlist
 do BasesView
readadd write !,"Add to compress list: " read x write !
 if x="" goto readdel
 set x=+x
 if '$d(db(x)) write "No such number!",! goto readadd
 if $d(list(db(x))) write "Database "_db(x)_" currently is in list",! goto readadd
 set list(db(x))=""
 do BasesView
 goto readadd
readdel if '$d(list) goto foolnext
 write !,"Delete from compress list: " read x write !
 if x="" goto foolnext
 set x=+x
 if '$d(db(x)) write "No such number!",! goto readdel
 if '$d(list(db(x))) write "Database "_db(x)_" is not in list",! goto readdel
 kill list(db(x))
 do BasesView
 goto readdel
BasesView write #
 write " Database Compression Utility for Cache' 4.x & 5.x",!
 write "---------------------------------------------------",!
 write "Select Databases for compression:",!
 set i=""
 for  set i=$o(db(i)) quit:i=""  do
  . if db(i)'="",$d(list(db(i))) write $j(i,2)_". * "_db(i),!
  . else  write $j(i,2)_".   "_db(i),!
  . quit
 quit
foolnext if '$d(list) goto foolend       
 write "Replace LIVE Dataset [y\n] "
 read x write !
 set x=$e($zcvt(x,"L"))
 if x="y" set x="yes"
 if x'="yes" set replace=0
 else  set replace=1
 if replace do  if 'x goto foolnext
  . write !!!!!
  . write "WARNING! This procedure may be unsafely! Dataset replacement may",!
  . write "CORRUPT YOUR DATA! We strongly recommend don't do it on production",!
  . write "Dataset! You may continue this procedure on your own risk...",!!
  . write "Continue compression with Dataset replacement? [y\n] "
  . read x write !
  . set x=$e($zcvt(x,"L"))
  . if x="y" set x="yes"
  . set x=$s(x'="yes":0,1:1)
  . quit
 set i=""
 set f=0
 for  set i=$o(list(i)) quit:i=""  set f=$$onecompress("^^"_i,replace,$G(lang,"en")) if f quit
 if f write "FATAL errors occured! Compression STOPPED!",!,"Notify Database Administrator please!!!",!
foolend write !!!," *** Finished ***",!
 quit
 ;
onecompress(ds,live,lang)
 new stat,result,fatal
 set lang=$g(lang)
 if lang'="ru",lang'="en" set lang="en"
 write !
 write $s(lang="en":"Compacting dataset ",1:"Сжатие базы ")_ds,!
 d %swset^|"%SYS"|SWSET(10,1) ; запрет активности
 set stat=$$compact(ds,live,1)
 d %swset^|"%SYS"|SWSET(10,0) ; запрет активности
 write !
 set result=$p($t(errs+(stat+2)),";",$s(lang="ru":5,1:4))
 if result["FATAL" set fatal=1
 else  set fatal=0
 if fatal write $s(lang="en":"FATAL ERROR:",1:"ФАТАЛЬНАЯ ОШИБКА:"),!,result,!,$s(lang="en":"DATASET NOT MOUNTED AGAIN!",1:"БАЗА ДАННЫХ НЕ СМОНТИРОВАНА НА СВОЕ МЕСТО"),!,$s(lang="en":"NEED FOR DATABASE ADMINISTRATOR HELP",1:"НЕОБХОДИМО ВМЕШАТЕЛЬСТВО АДМИНИСТРАТОРА"),!
 if 'fatal,stat> 0  write $s(lang="en":"ERROR Compression dataset ", 1 :"ОШИБКА Сжатия набора данных")_ds,!,result,!
 if 'fatal,stat'> 0  write $s(lang="en":"Dataset "_ds_" compressed", 1 :"База "_ds_" сжата"),!,result,$s(stat=- 2 :$e(ds, 3 ,$l(ds))_"~compressed~", 1 :""),!
 write !
 quit fatal
 ;