home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_tkcvs.idb / usr / freeware / lib / tkcvs / reports.tcl.z / reports.tcl
Encoding:
Text File  |  1999-04-16  |  16.4 KB  |  586 lines
  1. #
  2. # TCL Library for tkCVS
  3. #
  4.  
  5. #
  6. # $Id: reports.tcl,v 1.10 1995/11/07 01:06:29 davide Exp $
  7. #
  8. # Procedures for CVS reports.
  9. #
  10.  
  11. proc reports_setup {} {
  12. #
  13. # This sets up a dialog to determine whether a report should
  14. # be put on the screen, printed, or saved to a file.
  15. #
  16.   global printer_name
  17.   global file_name
  18.   global sorp
  19.   global sorp_button
  20.  
  21.   toplevel .sorp
  22.   frame .sorp.left
  23.   frame .sorp.right
  24.   frame .sorp.down -relief groove -border 2
  25.  
  26.   pack .sorp.down -side bottom -fill x
  27.   pack .sorp.left -side left -fill y
  28.   pack .sorp.right -side left -fill both -expand 1
  29.  
  30.   radiobutton .sorp.rprinter -text "Printer" \
  31.     -variable sorp -value "Printer" -anchor w
  32.   radiobutton .sorp.rfile -text "File" \
  33.     -variable sorp -value "File" -anchor w
  34.   radiobutton .sorp.rscreen -text "Screen" \
  35.     -variable sorp -value "Screen" -anchor w
  36.  
  37.   entry .sorp.tprinter -relief sunken -textvariable printer_name
  38.   entry .sorp.tfile -relief sunken -textvariable file_name
  39.  
  40.   # bind_motifentry .sorp.tprinter
  41.   # bind_motifentry .sorp.tfile
  42.  
  43.   pack .sorp.rprinter .sorp.rfile .sorp.rscreen -in .sorp.left \
  44.     -side top -anchor w -fill x -pady 2
  45.   pack .sorp.tprinter .sorp.tfile -in .sorp.right \
  46.     -side top -fill x -pady 3
  47.  
  48.   button .sorp.ok -text "OK" -command { set sorp_button 1 }
  49.   button .sorp.quit -text "Quit" -command { set sorp_button 0 }
  50.  
  51.   pack .sorp.ok .sorp.quit -in .sorp.down -side left \
  52.     -ipadx 2 -ipady 2 -padx 4 -pady 4 -fill both -expand 1
  53.  
  54.   wm withdraw .sorp
  55.   wm title .sorp "Select Report Destination"
  56.  
  57. #
  58. # Set up a dialog containing a text box that can be used to view
  59. # the report on the screen.
  60. #
  61.  
  62.   toplevel .viewer
  63.   text .viewer.text -setgrid yes -yscroll {.viewer.scroll set} \
  64.     -relief sunken -border 2
  65.   scrollbar .viewer.scroll -command {.viewer.text yview} -relief sunken
  66.   button .viewer.ok -text "OK" -command { wm withdraw .viewer }
  67.  
  68.   pack .viewer.ok -side bottom -fill x
  69.   pack .viewer.scroll -side right -fill y -padx 2 -pady 2
  70.   pack .viewer.text -fill both -expand 1
  71.  
  72.   wm withdraw .viewer
  73.   wm title .viewer "Report"
  74. }
  75.  
  76. proc screen_or_printer_run {} {
  77.   global sorp_button
  78.  
  79.   set sorp_button 2
  80.   wm deiconify .sorp
  81.   
  82.   set oldFocus [focus]
  83.   grab set .sorp
  84.   focus .sorp
  85.  
  86.   tkwait variable sorp_button
  87.   wm withdraw .sorp
  88.   focus $oldFocus
  89.   grab release .sorp
  90.   return $sorp_button
  91. }
  92.  
  93. proc modlist_by_name {versions tagname} {
  94. #
  95. # This produces a module listing by module name.
  96. #
  97.   global sorp
  98.   global dtitle
  99.   global mtitle
  100.  
  101.   if {! [info exists dtitle]} {
  102.     cvserror "You do not have any #D lines in your modules file."
  103.     return
  104.   }
  105.   if {! [info exists mtitle]} {
  106.     cvserror "You do not have any #M lines in your modules file."
  107.     return
  108.   }
  109.  
  110.   if [screen_or_printer_run] {
  111.     if {$tagname == ""} {
  112.       modlist_by_name_run $versions "head"
  113.     } else {
  114.       modlist_by_name_run $versions $tagname
  115.     }
  116.   }
  117. }
  118.  
  119. proc modlist_by_code {dcode versions tagname} {
  120. #
  121. # This produces a module listing by module code.
  122. # Set versions to 1 to give the file version numbers.
  123. #
  124.   global sorp
  125.   global dtitle
  126.   global mtitle
  127.  
  128.   if {! [info exists dtitle]} {
  129.     cvserror "You do not have any #D lines in your modules file."
  130.     return
  131.   }
  132.   if {! [info exists mtitle]} {
  133.     cvserror "You do not have any #M lines in your modules file."
  134.     return
  135.   }
  136.  
  137.   if [screen_or_printer_run] {
  138.     if {$tagname == ""} {
  139.       modlist_by_code_run $dcode $versions "head"
  140.     } else {
  141.       modlist_by_code_run $dcode $versions $tagname
  142.     }
  143.   }
  144. }
  145.  
  146. proc modlist_by_name_run {versions tagname} {
  147.   global modlist_by_title
  148.   global sorp
  149.   global file_name
  150.   global printer_name
  151.   global cvscfg
  152.  
  153.   feedback_cvs "Generating report, please wait"
  154.   if {$sorp == "Screen"} {
  155.     set linenum 1
  156.     .viewer.text configure -state normal
  157.     .viewer.text delete 1.0 end
  158.   } elseif {$sorp == "Printer"} {
  159.     set outfile [open "tkcvs.tmp" w]
  160.     set cvscfg(ycurrent) $cvscfg(ystart)
  161.     set cvscfg(pagenum) 1
  162.     postscript_setup $outfile
  163.   } else {
  164.     set outfile [open $file_name w]
  165.   }
  166.  
  167.   foreach item $modlist_by_title {
  168.     set items [split $item "\t"]
  169.     if {$sorp == "Screen"} {
  170.       set printme [format "%-55s %s" [lindex $items 0] [lindex $items 1]]
  171.       .viewer.text insert end "$printme\n"
  172.     } elseif {$sorp == "Printer"} {
  173.       postscript_line $outfile [lindex $items 0] [lindex $items 1]
  174.     } else {
  175.       set printme [format "%-55s %s" [lindex $items 0] [lindex $items 1]]
  176.       puts $outfile "$printme"
  177.     }
  178.     if {$versions} {
  179.       report_versions [lindex $items 1] $tagname
  180.     }
  181.   }
  182.  
  183.   if {$sorp == "Screen"} {
  184.     .viewer.text configure -state disabled
  185.     wm deiconify .viewer
  186.   } elseif {$sorp == "Printer"} {
  187.     postscript_end $outfile
  188.     close $outfile
  189.     exec lpr -P$printer_name tkcvs.tmp
  190.     exec rm tkcvs.tmp
  191.   } else {
  192.     close $outfile
  193.   }
  194.   feedback_cvs ""
  195. }
  196.  
  197. proc modlist_by_code_run {dcode versions tagname} {
  198. #
  199. # This does all the hard work in creating the module listing
  200. #
  201.   global dtitle
  202.   global mtitle
  203.   global sorp
  204.   global file_name
  205.   global printer_name
  206.   global cvscfg
  207.   
  208.   
  209.   feedback_cvs "Generating Report Please Wait"
  210.  
  211.   if {$sorp == "Screen"} {
  212.     set linenum 1
  213.     .viewer.text configure -state normal
  214.     .viewer.text delete 1.0 end
  215.   } elseif {$sorp == "Printer"} {
  216.     set outfile [open "tkcvs.tmp" w]
  217.     set cvscfg(ycurrent) $cvscfg(ystart)
  218.     set cvscfg(pagenum) 1
  219.     postscript_setup $outfile
  220.   } else {
  221.     set outfile [open $file_name w]
  222.   }
  223.  
  224.   # If dcode is "." then report the entire tree.  Otherwise restrict
  225.   # the report to a portion of the tree.
  226.  
  227.   # Special case where $dcode is not a top level.
  228.   if {$dcode != "." && [file dirname $dcode] != "."} {
  229.     if [info exists dtitle($dcode)] {
  230.       # Must be a subdirectory.
  231.       if {$sorp == "Screen"} {
  232.         .viewer.text insert end "\n$dtitle($dcode) \[$dcode\]\n"
  233.         .viewer.text tag add sublevel $linenum.0 "[expr $linenum + 1].0 lineend" 
  234.         incr linenum 2
  235.       } elseif {$sorp == "Printer"} {
  236.         postscript_subheading $outfile "   $dtitle($dcode)" $dcode
  237.       } else {
  238.         puts $outfile "\n$dtitle($dcode) \[$dcode\]"
  239.       }
  240.       report_on_dir $dcode $versions $tagname
  241.     }
  242.   } elseif {$dcode != "." && [info exists mtitle($dcode)]} {
  243.     # Must be a module.
  244.     if {$sorp == "Screen"} {
  245.       set printme [format "%-55s %s" $mtitle($dcode) $dcode]
  246.       .viewer.text insert end "$printme\n"
  247.       incr linenum
  248.     } elseif {$sorp == "Printer"} {
  249.       postscript_line $outfile "          $mtitle($dcode)" $dcode
  250.     } else {
  251.       set printme [format "%-55s %s" $mtitle($dcode) $dcode]
  252.       puts $outfile "$printme"
  253.     }
  254.     if {$versions} {
  255.       report_versions $dcode $tagname
  256.     }
  257.   # Either dcode is a toplevel or is "." which means do all toplevels.
  258.   } else {
  259.     foreach dname [array names dtitle] {
  260.       if {$dcode != "." && $dname != $dcode} {
  261.         continue
  262.       }
  263.       if {[file dirname $dname] == "."} {
  264.         if {$sorp == "Screen"} {
  265.           .viewer.text insert end "\n$dtitle($dname) \[$dname\]\n\n"
  266.           .viewer.text tag add toplevel $linenum.0 "[expr $linenum + 2].0 lineend"
  267.           incr linenum 3
  268.         } elseif {$sorp == "Printer"} {
  269.           postscript_heading $outfile $dtitle($dname) $dname
  270.         } else {
  271.           puts $outfile "\n$dtitle($dname) \[$dname\]\n"
  272.         }
  273.         report_on_dir $dname $versions $tagname
  274.       }
  275.     }
  276.   }
  277.  
  278.   if {$sorp == "Screen"} {
  279.     .viewer.text tag configure toplevel \
  280.       -font -Adobe-Helvetica-Bold-R-Normal-*-180-*
  281.     .viewer.text tag configure sublevel \
  282.       -font -Adobe-Helvetica-Bold-R-Normal-*-140-*
  283.     .viewer.text configure -state disabled
  284.     wm deiconify .viewer
  285.   } elseif {$sorp == "Printer"} {
  286.     postscript_end $outfile
  287.     close $outfile
  288.     exec lpr -P$printer_name tkcvs.tmp
  289.     exec rm tkcvs.tmp
  290.   } else {
  291.     close $outfile
  292.   }
  293.   feedback_cvs ""
  294. }  
  295.  
  296. proc report_on_dir {dname versions tagname} {
  297.   global mtitle
  298.   global dtitle
  299.   global dcontents
  300.   global dsubmenus
  301.   global sorp
  302.   upvar linenum linenum
  303.   upvar outfile outfile
  304.  
  305.   if [info exists dcontents($dname)] {
  306.     foreach mname $dcontents($dname) {
  307.       if {$sorp == "Screen"} {
  308.         set printme [format "%-55s %s" $mtitle($mname) $mname]
  309.         .viewer.text insert end "$printme\n"
  310.         incr linenum
  311.       } elseif {$sorp == "Printer"} {
  312.         postscript_line $outfile "          $mtitle($mname)" $mname
  313.       } else {
  314.         set printme [format "%-55s %s" $mtitle($mname) $mname]
  315.         puts $outfile "$printme"
  316.       }
  317.       if {$versions} {
  318.         report_versions $mname $tagname
  319.       }
  320.     }
  321.   }
  322.  
  323.   if [info exists dsubmenus($dname)] {
  324.     foreach subdir $dsubmenus($dname) {
  325.       if {$sorp == "Screen"} {
  326.         .viewer.text insert end "\n$dtitle($subdir) \[$subdir\]\n"
  327.         .viewer.text tag add sublevel $linenum.0 "[expr $linenum + 1].0 lineend" 
  328.         incr linenum 2
  329.       } elseif {$sorp == "Printer"} {
  330.         postscript_subheading $outfile "   $dtitle($subdir)" $subdir
  331.       } else {
  332.         puts $outfile "\n$dtitle($subdir) \[$subdir\]" 
  333.       }
  334.       report_on_dir $subdir $versions $tagname
  335.     }
  336.   }
  337. }
  338.  
  339. proc report_versions {mcode tagname} {
  340.   global filenames
  341.   global location
  342.   global cwd
  343.   global cvsroot
  344.   global sorp
  345.   global cvscfg
  346.   upvar linenum linenum
  347.   upvar outfile outfile
  348.  
  349.   # Aliases won't have locations so be careful.
  350.   if {! [info exists location($mcode)]} {
  351.     return
  352.   }
  353.  
  354.   # If a list of files does not exist for this module, create it now.
  355.   find_filenames $mcode
  356.  
  357.   # Be careful of empty modules.
  358.   if {! [info exists filenames($mcode)]} {
  359.     return
  360.   }
  361.  
  362.   # All of this stuff must be done from within the repository, so
  363.   # go there now.
  364.   if [catch {cd $cvsroot/$location($mcode)}] {
  365.     # If the directory doesn't exist, go home.
  366.     return
  367.   }
  368.  
  369.   # $filenames($mcode) now contains a list of files for this module
  370.   # relative to $cvsroot/$location($mcode).  Tell me all of
  371.   # their head version numbers.
  372.   foreach filename $filenames($mcode) {
  373.     set fd [open "|rlog -h $filename"]
  374.     while {[gets $fd line] != -1} {
  375.       set line [string trim $line]
  376.       # search for the tag name.
  377.       set text [split $line]
  378.       if {[llength $text] == 2} {
  379.         if {[lindex $text 0] == "$tagname:"} {
  380.           set version [lindex $text 1]
  381.         }
  382.       }
  383.     }
  384.     catch {close $fd}
  385.     # If version is unset then the file is missing or does not have that tag.
  386.     if {! [info exists version]} {
  387.       if {! $cvscfg(tagmissing)} {
  388.         continue
  389.       }
  390.       set version "missing"
  391.     }
  392.     # $version now has the version number.
  393.     if {$sorp == "Screen"} {
  394.       set printme [format "   %-55s %s" $filename $version]
  395.       .viewer.text insert end "$printme\n"
  396.       incr linenum
  397.     } elseif {$sorp == "Printer"} {
  398.       postscript_line $outfile "               $filename" $version
  399.     } else {
  400.       set printme [format "  %-55s %s" $filename $version]
  401.       puts $outfile "$printme"
  402.     }
  403.   }
  404.  
  405.   # Write out one blank line.
  406.   if {$sorp == "Screen"} {
  407.     .viewer.text insert end "\n"
  408.     incr linenum
  409.   } elseif {$sorp == "Printer"} {
  410.     postscript_line $outfile "" ""
  411.   } else {
  412.     puts $outfile ""
  413.   }
  414.  
  415.   # Go home now.
  416.   cd $cwd
  417. }
  418.  
  419. proc postscript_setup {outfile} {
  420.  
  421.   global cvscfg
  422.  
  423.   set col1 [expr $cvscfg(xend) * 0.55]
  424.  
  425.   puts $outfile "%!PS-Adobe-2.0"
  426.   puts $outfile "%%Title: module listing"
  427.   puts $outfile "%%Creator: tkCVS"
  428.   puts $outfile "%%DocumentFonts: Times-Roman"
  429.   puts $outfile "%%ProofMode: Substitute"
  430.   puts $outfile "%%Pages: (atend)"
  431.   puts $outfile "%%EndComments"
  432.   puts $outfile "%"
  433.   puts $outfile "% Constants definition"
  434.   puts $outfile "%"
  435.   puts $outfile "/ystart $cvscfg(ystart) def"
  436.   puts $outfile "/yend $cvscfg(yend) def"
  437.   puts $outfile "/xstart $cvscfg(xstart) def"
  438.   puts $outfile "/xend $cvscfg(xend) def"
  439.   puts $outfile "/col1 $col1 def"
  440.   puts $outfile "/div1 col1 xstart add 10 sub def"
  441.   puts $outfile "/pointsize $cvscfg(pointsize) def"
  442.   puts $outfile "/topsize $cvscfg(headingsize) def"
  443.   puts $outfile "/subsize $cvscfg(subheadingsize) def"
  444.   puts $outfile "/lineseparator pointsize 1 add def"
  445.   puts $outfile "/textfont /Times-Roman findfont pointsize scalefont def"
  446.   puts $outfile "/topfont /Helvetica findfont topsize scalefont def"
  447.   puts $outfile "/subfont /Helvetica findfont subsize scalefont def"
  448.   puts $outfile "/pagenum 1 def"
  449.   puts $outfile "%"
  450.   puts $outfile "% procedure definitions"
  451.   puts $outfile "%"
  452.   puts $outfile "/newpage"
  453.   puts $outfile "  {"
  454.   puts $outfile "   textfont setfont"
  455.   puts $outfile "   /ycurrent ystart def"
  456.   puts $outfile "   /xcurrent xstart def"
  457.   puts $outfile "   (Module Name) col1 showtab"
  458.   puts $outfile "   (Module Code) showln"
  459.   puts $outfile "   () showln"
  460.   puts $outfile "   /x1 xstart 5 sub def"
  461.   puts $outfile "   /x2 xend def"
  462.   puts $outfile "   /y1 ystart lineseparator add def"
  463.   puts $outfile "   /y2 yend lineseparator 3 mul sub def"
  464.   puts $outfile "   x1 y1 moveto"
  465.   puts $outfile "   x2 y1 lineto"
  466.   puts $outfile "   x2 y2 lineto"
  467.   puts $outfile "   x1 y2 lineto"
  468.   puts $outfile "   x1 y1 lineto"
  469.   puts $outfile "   x1 ystart 2 sub moveto"
  470.   puts $outfile "   x2 ystart 2 sub lineto"
  471.   puts $outfile "   div1 y1 moveto"
  472.   puts $outfile "   div1 y2 lineto"
  473.   puts $outfile "   stroke"
  474.   puts $outfile "   xstart ystart lineseparator 2 mul add moveto"
  475.   puts $outfile "   (tkCVS     Module Listing             Page ) show"
  476.   puts $outfile "   pagenum 10 string cvs show"
  477.   puts $outfile "   /pagenum pagenum 1 add def"
  478.   puts $outfile "  } def"
  479.   puts $outfile "%"
  480.   puts $outfile "/showtab"
  481.   puts $outfile "  {"
  482.   puts $outfile "   /xdelta exch def"
  483.   puts $outfile "   xcurrent ycurrent moveto show"
  484.   puts $outfile "   /xcurrent xcurrent xdelta add def"
  485.   puts $outfile "  } def"
  486.   puts $outfile "%"
  487.   puts $outfile "/showtop"
  488.   puts $outfile "  {"
  489.   puts $outfile "   /xdelta exch def"
  490.   puts $outfile "   topfont setfont"
  491.   puts $outfile "   /ycurrent ycurrent topsize sub def"
  492.   puts $outfile "   xcurrent ycurrent moveto show"
  493.   puts $outfile "   /xcurrent xcurrent xdelta add def"
  494.   puts $outfile "   xcurrent ycurrent moveto show"
  495.   puts $outfile "   /ycurrent ycurrent lineseparator 2 mul sub def"
  496.   puts $outfile "   /xcurrent xstart def"
  497.   puts $outfile "   textfont setfont"
  498.   puts $outfile "  } def"
  499.   puts $outfile "%"
  500.   puts $outfile "/showsub"
  501.   puts $outfile "  {"
  502.   puts $outfile "   /xdelta exch def"
  503.   puts $outfile "   subfont setfont"
  504.   puts $outfile "   /ycurrent ycurrent subsize sub def"
  505.   puts $outfile "   xcurrent ycurrent moveto show"
  506.   puts $outfile "   /xcurrent xcurrent xdelta add def"
  507.   puts $outfile "   xcurrent ycurrent moveto show"
  508.   puts $outfile "   /ycurrent ycurrent lineseparator 2 mul sub def"
  509.   puts $outfile "   /xcurrent xstart def"
  510.   puts $outfile "   textfont setfont"
  511.   puts $outfile "  } def"
  512.   puts $outfile "%"
  513.   puts $outfile "/showln"
  514.   puts $outfile "  {"
  515.   puts $outfile "   xcurrent ycurrent moveto show"
  516.   puts $outfile "   /ycurrent ycurrent lineseparator sub def"
  517.   puts $outfile "   /xcurrent xstart def"
  518.   puts $outfile "  } def"
  519.   puts $outfile "%%EndProlog"
  520.   puts $outfile "%"
  521.   puts $outfile "% Start main program"
  522.   puts $outfile "%"
  523.   puts $outfile "%%Page: 1 1"
  524.   puts $outfile "newpage"
  525.  
  526. }
  527.  
  528. proc postscript_line {outfile docname doccode} {
  529.  
  530.   global cvscfg
  531.  
  532.   puts $outfile "( $docname ) col1 showtab"
  533.   puts $outfile "( $doccode ) showln"
  534.  
  535.   set cvscfg(ycurrent) [expr $cvscfg(ycurrent) - $cvscfg(pointsize) - 1]
  536.   if {$cvscfg(ycurrent) < $cvscfg(yend)} {
  537.     set cvscfg(ycurrent) $cvscfg(ystart)
  538.     incr cvscfg(pagenum)
  539.     puts $outfile "showpage"
  540.     puts $outfile "%%Page: $cvscfg(pagenum) $cvscfg(pagenum)"
  541.     puts $outfile "newpage"
  542.   }
  543. }
  544.  
  545. proc postscript_heading {outfile docname doccode} {
  546.  
  547.   global cvscfg
  548.  
  549.   puts $outfile "($doccode) ( $docname ) col1 showtop"
  550.  
  551.   set cvscfg(ycurrent) \
  552.     [expr $cvscfg(ycurrent) - $cvscfg(headingsize) - (2*$cvscfg(pointsize)) - 2]
  553.   if {$cvscfg(ycurrent) < $cvscfg(yend)} {
  554.     set cvscfg(ycurrent) $cvscfg(ystart)
  555.     incr cvscfg(pagenum)
  556.     puts $outfile "showpage"
  557.     puts $outfile "%%Page: $cvscfg(pagenum) $cvscfg(pagenum)"
  558.     puts $outfile "newpage"
  559.   }
  560. }
  561.  
  562. proc postscript_subheading {outfile docname doccode} {
  563.  
  564.   global cvscfg
  565.  
  566.   puts $outfile "($doccode) ( $docname ) col1 showsub"
  567.  
  568.   set cvscfg(ycurrent) \
  569.    [expr $cvscfg(ycurrent) - $cvscfg(subheadingsize) - (2*$cvscfg(pointsize)) - 2]
  570.   if {$cvscfg(ycurrent) < $cvscfg(yend)} {
  571.     set cvscfg(ycurrent) $cvscfg(ystart)
  572.     incr cvscfg(pagenum)
  573.     puts $outfile "showpage"
  574.     puts $outfile "%%Page: $cvscfg(pagenum) $cvscfg(pagenum)"
  575.     puts $outfile "newpage"
  576.   }
  577. }
  578.  
  579. proc postscript_end {outfile} {
  580.  
  581.   global cvscfg
  582.   puts $outfile "showpage"
  583.   puts $outfile "%%Trailer"
  584.   puts $outfile "%%Pages: $cvscfg(pagenum)"
  585. }
  586.