home *** CD-ROM | disk | FTP | other *** search
/ PC World 1998 October / PCWorld_1998-10_cd.bin / software / prehled / komix / DATA.Z / pbllibrary.tcl < prev    next >
Encoding:
Text File  |  1997-07-25  |  14.1 KB  |  514 lines
  1. #---------------------------------------------------------------------------
  2. #
  3. #      (c)     Cayenne Software Inc.    1997
  4. #
  5. #      File:           @(#)pbllibrary.tcl    /main/titanic/2
  6. #      Author:         <generated>
  7. #      Description:
  8. #---------------------------------------------------------------------------
  9. # SccsId = @(#)pbllibrary.tcl    /main/titanic/2   25 Jul 1997 Copyright 1997 Cayenne Software Inc.
  10.  
  11. # Start user added include file section
  12. require "platform.tcl"
  13. require "pb_msg.tcl"
  14.  
  15. # keep this in sync with orca.h & genpbl.hsxx #define  statements
  16. # Operation successful
  17. global PBORCA_OK;               set PBORCA_OK                  0
  18.  # Invalid parameter list
  19. global PBORCA_INVALIDPARMS;     set PBORCA_INVALIDPARMS        1
  20. # Duplicate operation    
  21. global PBORCA_DUPOPERATION;     set PBORCA_DUPOPERATION        2
  22. # Object not found 
  23. global PBORCA_OBJNOTFOUND;      set PBORCA_OBJNOTFOUND         3
  24. # Bad library name
  25. global PBORCA_BADLIBRARY;       set PBORCA_BADLIBRARY          4
  26. # Library list not   set
  27. global PBORCA_LIBLISTNOTSET;    set PBORCA_LIBLISTNOTSET       5
  28. # Library not in lib list
  29. global PBORCA_LIBNOTINLIST;     set PBORCA_LIBNOTINLIST        6
  30. # Library I/O error          
  31. global PBORCA_LIBIOERROR;       set PBORCA_LIBIOERROR          7
  32. # Object exists          
  33. global PBORCA_OBJEXISTS;        set PBORCA_OBJEXISTS           8
  34. # Invalid name
  35. global PBORCA_INVALIDNAME;      set PBORCA_INVALIDNAME         9
  36. # Buffer size is too small          
  37. global PBORCA_BUFFERTOOSMALL;   set PBORCA_BUFFERTOOSMALL     10
  38. # Compile error
  39. global PBORCA_COMPERROR;        set PBORCA_COMPERROR          11
  40. # Link error
  41. global PBORCA_LINKERROR;        set PBORCA_LINKERROR          12
  42. # Current appl not   set
  43. global PBORCA_CURRAPPLNOTSET;   set PBORCA_CURRAPPLNOTSET     13
  44. # Object has no ancestors          
  45. global PBORCA_OBJHASNOANCS;     set PBORCA_OBJHASNOANCS       14
  46. # Object has no references          
  47. global PBORCA_OBJHASNOREFS;     set PBORCA_OBJHASNOREFS       15
  48. # Invalid # of PBD's          
  49. global PBORCA_PBDCOUNTERROR;    set PBORCA_PBDCOUNTERROR      16
  50. # PBD create error
  51. global PBORCA_PBDCREATERROR;    set PBORCA_PBDCREATERROR      17
  52. global PBORCA_CHECKOUTERROR;    set PBORCA_CHECKOUTERROR      18 
  53.  
  54. global GENPBL_CANNOTOPENFILE;   set GENPBL_CANNOTOPENFILE    100
  55. global GENPBL_ENTRYCHECKEDOUT;  set GENPBL_ENTRYCHECKEDOUT   101
  56. global GENPBL_NOPBORCATYPE;     set GENPBL_NOPBORCATYPE      102
  57. global GENPBL_MULTIPLERUNERROR; set GENPBL_MULTIPLERUNERROR  103
  58. global GENPBL_FILENOTEXIST;     set GENPBL_FILENOTEXIST      104
  59. global GENPBL_NOFILETOIMPORT;   set GENPBL_NOFILETOIMPORT    105
  60.  
  61. # End user added include file section
  62.  
  63.  
  64. # A shell around genpbl
  65.  
  66. Class PblLibrary : {GCObject} {
  67.     constructor
  68.     method destructor
  69.     method createLibrary
  70.     method existsLibrary
  71.     method removeLibrary
  72.     method createOldLibrary
  73.     method existsOldLibrary
  74.     method removeOldLibrary
  75.     method restoreLibrary
  76.     method export
  77.     method exportFiles
  78.     method import
  79.     method importFiles
  80.     method getLibName
  81.     method getInclFiles
  82.     method getSrcFiles
  83.     attribute libraryName
  84. }
  85.  
  86. constructor PblLibrary {class this} {
  87.     set this [GCObject::constructor $class $this]
  88.     $this libraryName ""
  89.     # Start constructor user section
  90.     # End constructor user section
  91.     return $this
  92. }
  93.  
  94. method PblLibrary::destructor {this} {
  95.     # Start destructor user section
  96.     # End destructor user section
  97. }
  98.  
  99. proc PblLibrary::createLibraryByName {libName} {
  100.     # this function creates the file, so if remove an existing file!!
  101.     set errornr 0
  102.     global errorCode errorInfo
  103.     
  104.     set libName [$this getLibName]
  105.     set libNameExt "$libName.pbl"
  106.     set libNameType "$libName.library"
  107.     m4_message $MPB_CREATINGLIB $libNameExt
  108.  
  109.     set cc [ClientContext::global]
  110.     set sysV [$cc currentSystem]
  111.     set dir [$sysV path]
  112.  
  113.     set genpbl [m4_path_name bin genpbl$EXE_EXT]
  114.  
  115.     set fp [fstorage::open $libNameType w]
  116.     fstorage::close $fp
  117.     # first create entry in browser. This also results in 
  118.     # afile. Now only create (by force: -f) the file by genpbl
  119.     #  (else genpbl says file already exists)
  120.     # .main updateView
  121.  
  122.     set ret [catch {exec $genpbl -Ccreate -L$dir\\$libNameExt -c\"Generated by ObjectTeam\" -f} msg]
  123.  
  124.     if {$ret == 0} {
  125.         # file was created so,
  126.     } else {
  127.         set errorRet [expr {([lindex $errorCode 0] == "CHILDSTATUS") ? \
  128.                                 [lindex $errorCode 2] : "unknown" }]
  129.         if {$errorRet == $PBORCA_OBJEXISTS} {
  130.             # library already exists, but not shocking
  131.         } else {
  132.             incr errornr 1
  133.             m4_error $EPB_RETURNED $genpbl $errorRet
  134.             m4_message $MPB_MSG $msg
  135.         }
  136.     }    
  137. }
  138.  
  139. method PblLibrary::createLibrary {this} {
  140. # this function creates the file, so if remove an existing file!!
  141.     set errornr 0
  142.     global errorCode errorInfo
  143.     
  144.     set libName [$this getLibName]
  145.     set libNameExt "$libName.pbl"
  146.     set libNameType "$libName.library"
  147.     m4_message $MPB_CREATINGLIB $libNameExt
  148.  
  149.     set cc [ClientContext::global]
  150.     set sysV [$cc currentSystem]
  151.     set dir [$sysV path]
  152.  
  153.     set genpbl [m4_path_name bin genpbl$EXE_EXT]
  154.  
  155.     set fp [fstorage::open $libNameType w]
  156.     fstorage::close $fp
  157.     # first create entry in browser. This also results in 
  158.     # afile. Now only create (by force: -f) the file by genpbl
  159.     #  (else genpbl says file already exists)
  160.     # .main updateView
  161.  
  162.     set ret [catch {exec $genpbl -Ccreate -L$dir\\$libNameExt -c\"Generated by ObjectTeam\" -f} msg]
  163.  
  164.     if {$ret == 0} {
  165.         # file was created so,
  166.     } else {
  167.         set errorRet [expr {([lindex $errorCode 0] == "CHILDSTATUS") ? \
  168.                                 [lindex $errorCode 2] : "unknown" }]
  169.         if {$errorRet == $PBORCA_OBJEXISTS} {
  170.             # library already exists, but not shocking
  171.         } else {
  172.             incr errornr 1
  173.             m4_error $EPB_RETURNED $genpbl $errorRet
  174.             m4_message $MPB_MSG $msg
  175.         }
  176.     }    
  177. }
  178.  
  179. method PblLibrary::existsLibrary {this} {
  180.     set errornr 0
  181.     set cc [ClientContext::global]
  182.     set sysV [$cc currentSystem]
  183.     set dir [$sysV path]
  184.     
  185.     set libName [$this getLibName]
  186.     set libNameType "$libName.library"
  187.     set libNameExt "$libName.pbl"
  188.     if {[fstorage::exists $libNameType]} {
  189.         return 1 
  190.     } 
  191.     return 0
  192. }
  193.  
  194. method PblLibrary::removeLibrary {this} {
  195.     set errornr 0
  196.     
  197.     set libName [$this getLibName]
  198.     set libNameExt "$libName.pbl"
  199.     set libNameType "$libName.library"
  200.     
  201.     if {[fstorage::exists $libNameType]} {
  202.         fstorage::remove $libNameType
  203.     }
  204. }
  205.  
  206. method PblLibrary::createOldLibrary {this} {
  207.     global errorCode errorInfo
  208.     set cc [ClientContext::global]
  209.     set sysV [$cc currentSystem]
  210.     set dir [$sysV path]
  211.     
  212.     set libName [$this getLibName]
  213.     set libNameExt "$libName.pbl"
  214.     set libNameType "$libName.library"
  215.     set libNameOldExt "$libName.old.pbl"
  216.     set libNameOldType "$libName.old.library"
  217.  
  218.     m4_message $MPB_OLDLIBCREATED $libNameOldType
  219.  
  220.     set fp [fstorage::open $libNameOldType w]
  221.     fstorage::close $fp
  222.     # first create entry in browser. This also results in 
  223.     # afile. Now only create (by force: -f) the file by copy
  224.  
  225.     set script "cmd /C copy $dir\\$libNameExt $dir\\$libNameOldExt"
  226.     #copy just the file    
  227.     set ret [catch {exec cmd /C copy $dir\\$libNameExt \
  228.                         $dir\\$libNameOldExt} msg]
  229.     if {$ret == 0} {
  230.         #ok
  231.     } else {
  232.         set errorRet [expr {([lindex $errorCode 0] == "CHILDSTATUS") ? \
  233.                                 [lindex $errorCode 2] : "unknown" }]
  234.         set cmd "cmd /C copy $dir\\$libNameExt $dir\\$libNameOldExt"
  235.         m4_error $EPB_RETURNED $cmd $errorRet
  236.         m4_message $MPB_MSG $msg
  237.         
  238.         incr errornr $ret
  239.     }
  240. }
  241.  
  242. method PblLibrary::existsOldLibrary {this} {
  243.     set errornr 0
  244.     
  245.     set libName [$this getLibName]
  246.     set libNameExt "$libName.old.pbl"
  247.     set libNameType "$libName.old.library"
  248.     
  249.     if {[fstorage::exists $libNameType]} {
  250.         return 1
  251.     }
  252.     return 0
  253. }
  254.  
  255. method PblLibrary::removeOldLibrary {this} {
  256.     set errornr 0
  257.  
  258.     set libName [$this getLibName]
  259.     set libNameExt "$libName.old.pbl"
  260.     set libNameType "$libName.old.library"
  261.     
  262.     m4_message $MPB_OLDLIBDELETE
  263.     if {[fstorage::exists $libNameType]} {
  264.         fstorage::remove $libNameType
  265.     }
  266. }
  267.  
  268. method PblLibrary::restoreLibrary {this} {
  269.     set errornr 0
  270.     if [$this existsOldLibrary] {
  271.         global errorCode errorInfo
  272.         set cc [ClientContext::global]
  273.         set sysV [$cc currentSystem]
  274.         set dir [$sysV path]
  275.         
  276.         set libName [$this getLibName]
  277.         set libNameExt "$libName.pbl"
  278.         set libNameType "$libName.library"
  279.         set libNameOldExt "$libName.old.pbl"
  280.         set libNameOldType "$libName.old.library"
  281.         
  282.         #copy just the file    
  283.         set ret [catch {exec cmd /C copy $dir\\$libNameOldExt \
  284.                             $dir\\$libNameExt} msg]
  285.         if {$ret == 0} {
  286.             #ok
  287.             m4_message $MPB_ORIGRESTORED
  288.             # now remove in browser.
  289.             if {[fstorage::exists $libNameOldType]} {
  290.                 fstorage::remove $libNameOldType
  291.             }
  292.         } else {
  293.             set errorRet [expr {([lindex $errorCode 0] == "CHILDSTATUS") ? \
  294.                                     [lindex $errorCode 2] : "unknown" }]
  295.             set cmd "cmd /C copy $dir\\$libNameOldExt $dir\\$libNameExt"
  296.             #print error msg
  297.             m4_error $EPB_RETURNED $cmd $errorRet
  298.             m4_message $MPB_MSG $msg
  299.  
  300.             set errornr $errorRet
  301.         }
  302.     }
  303. }
  304.  
  305. method PblLibrary::export {this classList} {
  306.     set errornr 0
  307.     global errorCode errorInfo
  308.     set cc [ClientContext::global]
  309.     set sysV [$cc currentSystem]
  310.     set dir [$sysV path]
  311.     
  312.     set libName [$this getLibName]
  313.     set libNameExt "$libName.pbl"
  314.     
  315.     set genpbl [m4_path_name bin genpbl$EXE_EXT]
  316.     
  317.     $classList foreach class {
  318.         if ![$class isGlobalType] {
  319.             continue
  320.         }
  321.         set kind [$class getPBClassKind]
  322.         if {$kind == ${PBClassKind::NotSupported}} {
  323.             continue
  324.         }
  325.         set entryName [$class getName]
  326.         set entryType [PBLibraryEntry::getFileTypeByKind $kind]
  327.         if {$entryType == ""} {
  328.             continue
  329.         }
  330.         set entryExt [PBLibraryEntry::getSrcFileTypeByFileType $entryType]
  331.         set fileName "$entryName\.$entryExt"
  332.         
  333.         set ret [catch {exec $genpbl -Cexport -L$libNameExt \
  334.                             -s$dir $fileName} msg]
  335.         
  336.         if {$ret == 0} {
  337.             #ok
  338.         } elseif {$ret == 1} {
  339.             set errorRet [expr {([lindex $errorCode 0] == "CHILDSTATUS") ? \
  340.                                     [lindex $errorCode 2] : "unknown" }]
  341.             if {$errorRet == $PBORCA_OBJNOTFOUND} {
  342.                 # if genpbl return PBORCA_OBJNOTFOUND then the entry 
  343.                 #  was not present, so 
  344.                 # no error...
  345.             } else {
  346.                 m4_error $EPB_RETURNED $genpbl $errorRet
  347.                 m4_message $MPB_MSG $msg
  348.                 incr errornr $ret
  349.             }
  350.         } else {
  351.             #return, break, continue, ??
  352.             incr errornr $ret
  353.         }
  354.     }
  355.     # because also an error is generate when the source files 
  356.     # are not present, zero is returned.
  357.     return $errornr
  358.  
  359. }
  360.  
  361. method PblLibrary::exportFiles {this srcFile {inclFile ""} {dir ""}} {
  362.     if {$srcFile == ""} {
  363.         return 1
  364.     }
  365.     set libName [$this getLibName]
  366.     set libName "$libName.pbl"
  367.     set optCmd "-Cexport"
  368.     set optLib "-L$libName"
  369.     set optIncl [expr {($inclFile != "") ? "-i${inclFile}" : ""}]
  370.     set optSrc [expr {($srcFile != "") ? "-F${srcFile}" : ""}]
  371.     set optDir [expr {($dir != "") ? "-s${dir}" : ""}]
  372.     
  373.     set genpbl [m4_path_name bin genpbl$EXE_EXT]
  374.        set ret [catch {exec $genpbl $optCmd $optLib $optIncl $optSrc $optDir} msg]
  375.  
  376.     if {$ret == 0} {
  377.             #ok
  378.     } elseif {$ret == 1} {
  379.         set errorRet [expr {([lindex $errorCode 0] == "CHILDSTATUS") ? \
  380.                                 [lindex $errorCode 2] : "unknown" }]
  381.         if {$errorRet == $PBORCA_OBJNOTFOUND} {
  382.             # if genpbl return PBORCA_OBJNOTFOUND then the entry 
  383.             #  was not present, so 
  384.             # no error...
  385.         } else {
  386.             m4_error $EPB_RETURNED $genpbl $errorRet
  387.             m4_message $MPB_MSG $msg
  388.             return 1
  389.         }
  390.     } else {
  391.         #return, break, continue, ??
  392.         return 1
  393.     }
  394.     return 0
  395. }
  396.  
  397. method PblLibrary::import {this classList} {
  398.     set errornr 0
  399.     global errorCode errorInfo
  400.  
  401.     set cc [ClientContext::global]
  402.     set sysV [$cc currentSystem]
  403.     set dir [$sysV path]
  404.  
  405.  
  406.     set srcFile [$this getSrcFiles $classList]
  407.     set inclFile [$this getInclFiles]
  408.  
  409.     set ret [$this importFiles $srcFile $inclFile $dir]
  410.     
  411.     if {$ret == 0} {
  412.         return 0
  413.     } 
  414.     return 1
  415. }
  416.  
  417. method PblLibrary::importFiles {this srcFile {inclFile ""} {dir ""}} {
  418.     if {$srcFile == ""} {
  419.         return 1
  420.     }
  421.     set libName [$this getLibName]
  422.     set libName "$libName.pbl"
  423.     set optCmd "-Cimportlist"
  424.     set optLib "-L$libName"
  425.     set optIncl [expr {($inclFile != "") ? "-i${inclFile}" : ""}]
  426.     set optSrc [expr {($srcFile != "") ? "-F${srcFile}" : ""}]
  427.     set optDir [expr {($dir != "") ? "-s${dir}" : ""}]
  428.  
  429.     set genpbl [m4_path_name bin genpbl$EXE_EXT]
  430.     set ret [catch {exec $genpbl $optCmd $optLib $optIncl $optSrc $optDir} msg]
  431.     
  432.     if {$ret == 0} {
  433.         #ok
  434.     } elseif {$ret == 1} {
  435.         #error
  436.         set errorRet [expr {([lindex $errorCode 0] == "CHILDSTATUS") ? \
  437.                                 [lindex $errorCode 2] : "unknown" }]
  438.         m4_error $EPB_RETURNED $genpbl $errorRet
  439.         m4_message $MPB_MSG $msg
  440.         
  441.         return 1
  442.     } else {
  443.         #return, break, continue, ??
  444.         return 1
  445.     }
  446.     return 0
  447. }
  448.  
  449. method PblLibrary::getLibName {this} {
  450.     if {[$this libraryName] == ""} {
  451.         set cc [ClientContext::global]
  452.         set sysV [$cc currentSystem]
  453.         set libName [[$sysV system] name]
  454.         set libName [string tolower $libName]
  455.         $this libraryName $libName
  456.     }
  457.     return [$this libraryName]
  458. }
  459.  
  460. method PblLibrary::getInclFiles {this} {
  461.     set cc [ClientContext::global]
  462.     set sysV [$cc currentSystem]
  463.     set dir [$sysV path]
  464.  
  465.     # include file for classes in other libraries
  466.     set phaseV [$cc currentPhase]
  467.     set inclFile [args_file {}]
  468.     set fid [open $inclFile w]
  469.     set inclPattern [path_name concat [location [$phaseV path] *] \
  470.                     * pbl]
  471.     # thanks our good old windows:
  472.     set x [regsub -all {\\} $inclPattern {/} inclPattern]
  473.     set incl [glob -nocomplain $inclPattern]
  474.     foreach elem $incl {
  475.         # thanks our good old windows:
  476.         set x [regsub -all {/} $elem {\\} elem]    
  477.         puts $fid $elem
  478.     }
  479.     close $fid
  480.  
  481.     if {[llength $incl] > 0} {
  482.         return $inclFile
  483.     } else {
  484.         return ""
  485.     }
  486. }
  487.  
  488. method PblLibrary::getSrcFiles {this classList} {
  489.     # source file of classes to be imported
  490.     set srcFile [args_file {}]
  491.     set fid [open $srcFile w]
  492.     $classList foreach class {
  493.         if ![$class isGlobalType] {
  494.             continue
  495.         }
  496.         set kind [$class getPBClassKind]
  497.         if {$kind == ${PBClassKind::NotSupported}} {
  498.             continue
  499.         }
  500.         set entryName [$class getName]
  501.         set entryType [PBLibraryEntry::getFileTypeByKind $kind]
  502.         set entryExt [PBLibraryEntry::getSrcFileTypeByFileType $entryType]
  503.         set source "$entryName.$entryExt"
  504.  
  505.         puts $fid $source
  506.     }
  507.     close $fid
  508.  
  509.     return $srcFile
  510. }
  511.  
  512. # Do not delete this line -- regeneration end marker
  513.  
  514.