Tk-Pod-0.9943/000755 001750 001750 00000000000 12653407630 013546 5ustar00eserteeserte000000 000000 Tk-Pod-0.9943/Pod/000755 001750 001750 00000000000 12653407627 014276 5ustar00eserteeserte000000 000000 Tk-Pod-0.9943/Changes000644 001750 001750 00000040372 12653407360 015047 0ustar00eserteeserte000000 000000 History for Tk::Pod version 0.9943 o stable release with all changes in 0.9942_50 version 0.9942_50 o geo URI handled now by OpenStreetMap o WWWBrowser update o use POSIX::_exist instead of CORE::exit in forked processes to avoid core dumps with newer perls o more and better tests version 0.9942 o stable release with all changes in 0.9941_50 version 0.99941_50 o tkpod -geometry works now o WWWBrowser update (avoid zombies, better debugging) o avoid warnings in some Tk::More method calls with perl 5.18+ o test suite works with twm version 0.9941 o stable release with all changes in 0.9940_50 o added menu item with link to metacpan.org version 0.9940_50 o history view is showing the Pod title, not anymore the base filename o use the current perl's perlindex, not the standard one o tkmore: new option -S o accelerator Ctrl-U for View source o workaround for bindtags problems o colors in tree view for script and local dirs o prefer firefox over mozilla when calling external browser o ignore vcs directories in FindPods o refactoring: Class::Struct is not used anymore for the _HistoryEntry class o zombie reaping (helps in cleaning up temp files for gv/ghostscript) o add "_tkpod" to suffix of temp files o listed more optional dependencies version 0.9940 o stable release with all changes in 0.9939_50..0.9939_59 version 0.9939_59 o support for geo: URIs o WWWBrowser update (fixing Debian issues) o spelling fix in Pod o modernized META.yml/.json creation o regain 5.005 compat version 0.9939_58 o added gzip support in tkmore (needs PerlIO::gzip) version 0.9939_57 o fix for http://rt.cpan.org/Ticket/Display.html?id=41320 (1st issue, cleanup of temporary directory) version 0.9939_56 o create cache directory if necessary o cache directory documentation o use entities instead of iso-8859-2 encoding in some Pods o tests may fail on some systems because of a bug in Tk (i.e. when creating multiple MainWindows within one process) version 0.9939_55 o tkpod: new -version option o View Source: show Pod source at current line now o fixed partially breakage because of background tree updating o experimental: a new button for rebuilding the fullsearch index (needs either gksu or xsu) o fix for http://rt.cpan.org/Ticket/Display.html?id=41320 (2nd issue) o pod cache now lives in the home or data directory o TODO file is now written in org-mode, not anymore as Pod version 0.9939_54 o Pod tree is updated in the background (Unix only) o Link to sections: now also non-sections are highlighted o fixed a spelling error in Tk::More's Pod version 0.9939_53 o fixed a broken test o fixed optional_features in META.yml version 0.9939_52 o fixed: cygwin had no protection against missing/invalid DISPLAYs version 0.9939_51 o fixed <2> binding (the last change broke open in new window over links) version 0.9939_50 o middle button acts now like Mozilla/Firefox: opening pod by selection o moved "Reload" menu item to "View" menu o new menu item "View" > "View source" o improved full text search: o multi term searches are now possible o sorting results is done by using number of term hits first o full text search terms are translated into a stemmed regexp for the Pod viewer search o avoiding AnyDBM_File-related warnings version 0.9939 o new popup menu item "Copy Pod location" version 0.9938_52 o fixed some tests caused by the new optionality of some modules version 0.9938_51 o META.yml needs also dynamic_config setting o update of README version 0.9938_50 o update to newest WWWBrowser.pm o again fixes for fulltext search paths (problems seen on Debian and Windows) o debug mode: now with Reloader menu item o META.yml uses optional_features instead of recommends o changed DISPLAY check before test_harness call, hopefully generating UNKNOWN test results version 0.9938 So 3 Feb 2008 19:12:04 CET o The internal man viewer can handle utf-8 now. o Upgraded to newer WWWBrowser version (changed Windows support) o fix for ActivePerl: perl documentation is in "pods" directory o special handling for a2p pod version 0.9937 o Make sure the displayed Pods in the tree match the actual @INC path o Tk::Pod::Text Pod should now contain all Pod constructs as examples o bugfix: fixed architecture path component stripping o bugfix: fixed core/site/vendor coloring if installvendorlib/arch not defined at all o warning fix in Tk::Pod::FindPods for perl 5.005 version 0.9936 o Tk::More now used fixedFont/FixedFont for setting font via option db o more Tk::More-related documentation o t/cmdline.t does not fail anymore with perl 5.005_05 o fullsearch dialog with fixed font in listbox, making nicer columns o fullsearch toplevel is now transient o OK button in fullsearch dialog o made the fulltext search work under MSWin32 (by using File::Spec instead of manual filename arithmetic) o all transient windows now have close buttons o WWWBrowser is now bundled as Tk::Pod::WWWBrowser o printing under MacOSX o added basic tests for PodSearch and PodTree version 0.9935 o fixed missing "use" in tkpod (spotted by Torsten Foertsch) o nicer diagnostics output when finding duplicate modules o better STDERR diagnostics if Pod cannot not be found in findpod o cmdline.t tests with different environment settings o cmdline.t works now in BATCH=0 mode version 0.9934 o Fixed fulltext search on Debian machines (different index location) o minor Pod changes o Tk::More and tkmore now support the -encoding option o support coloring tree items for vendor directories o new menu item: View Pod source (like Edit Pod, but using Tk::More) o new method for Tk::More: AddQuitBindings o documented public methods in Tk::More version 0.9933 o new menu items with search.cpan.org and annocpan.org links o Print keybinding o Ptksh menu entry in debug mode o tkpod: pod names now have priority over directories (problem spotted by Andreas Koenig) o pod tree fixes for MacOSX o do not run test suite if no DISPLAY available (X11 only) version 0.9932 o bugfix - Tk::Pod did not work with Tk804 and without Tk::ToolBar installed (thanks to Craig Thayer for spotting the problem) version 0.9931 o Tk::ToolBar menu icon support also for Tk800 (very experimental!) version 0.9930 o fixing zoom function problems on some X11 servers o changed About dialog o tkmore: Pod, new options o new environment variable TKPODCACHE o fixed for installations with vendor_perl in @INC (thanks to Alexey Tourbin) version 0.9929 o no functional changes, just repair version damage version 0.9928 o -f and -q options for tkpod o fixes for Windows (tested with ActivePerl) o minor usability improvements o full search: it's now possible to restrict to the current selected module subtree version 0.9927 o new script tkmore (installed by default) o experimental: menu icons (only with Tk::ToolBar installed and with Tk804) o fix: Back/Forward menu items are disabled if not applicable o WidgetDump menu entry in debug mode o Use a ligther background color for Text/Tree areas of Tk::Pod. The -background option is now disabled. This is very experimental and will change. o experimental: new internal man viewer o experimental: "Open by Name" accepts "-f ..." for displaying functions and "-q ..." for FAQ questions o Pod::Simple requirement increased to 2.05 because of bugs in earlier versions o pod_find in Tk::Pod::FindPods now works with softlinked directories version 0.9926 o changed search order: .pod files first, then .pm, .pl and extension-less files o Tk::Pod and Tk::Pod::Text are now better subclassable o new tests t/pods.t and t/subclass.t o changed -selectforeground in tree view o polished Tk::HistEntry support o new menu accelerators o tiny layout change for =item (by Torsten Foertsch) version 0.9925 o Tk::Pod::FindPods: using opendir/readdir instead of glob version 0.9924 o fix for a test error version 0.9923 o Zoom in/out was reversed (spotted by Martin Thurn) o temporary print files now may get deleted on process end o removed very experimental CPAN support --- use CPANPLUS::Shell::Tk instead o experimental support for displaying perlfunc functions in tree (by category or alphabetically) o some missing \Q...\E added version 0.9922 o fixed logic in Tk::Pod::FindPods version 0.9921 o new feature: search Perl FAQ o bugfix (hopefully): aborting the rendering sometimes caused the styles to get messed up o bugfix: changing the font size now also propagates to Pod pages in the history version 0.9920 o more information in About dialog o Tk::Pod::Cache: workaround for a reload bug (seen on RedHat 8.0 only) o no more interactive tests --- bow there's "make demo" version 0.9919 o search in Pod tree with history o changed menu entry label "Set Pod" to "Open by Name" o new environment variable TKPODDIRS o documented TKPODPORT o added accelerators for Zoom in/out version 0.9918 o fixed the error case in Tk::Pod::Text::file o changed Home, End, Prior and Next callbacks in Tree view o invalidate cache on reload o openpod with history o added support version 0.9917 o propagate -exitbutton to new windows o Set Pod: new "New window" button o tkpod -I lib (again) possible o Tk::FcyEntry not used anymore because of problems under Windows o document cleanup: replaced "POD" with "Pod" o OO rewrite of Tk::Pod::FindPods version 0.9916 o URL and man links are now clickable (Tk::Pod::Text::Link_url and Tk::Pod::Text::Link_man) o $Config{scriptdir} is now also scanned for pods (suggestion by Marek Rouchal) o New -exitbutton option. By default Tk::Pod widgets do not have an exit menu entry anymore (suggestion by Bruce Ravel) o new cmdline.t test o server cleanup on SIGTERM o fixed option handling in tkpod (-I switch not available anymore) o moved some functions into new module Tk::Pod::Util o bugfix: keyboard selection in POD tree now works o bugfix for perllocal.pod handling o another workaround for Tk::Pod::FindPods on MSWin32 version 0.9915 o use Tk::HistEntry in fulltext search dialog, if available o tree view: now automatically jumping to the current leaf o Double-2 binding in Tk::Pod::Text o minor POD fixes version 0.9914 o changed email address o first non-development 0.99* version version 0.99_13 o Tk::Pod::Cache was missing in the distribution :-( o new environment variable TKPODEDITOR version 0.99_12 o new module Tk::Pod::Cache --- memory cached documents are rendered about three times faster than non-cached documents o DEBUG now uses warn instead of print version 0.99_11 o new zoom_normal/in/out menu entries o default OS font size is honored now version 0.99_10 o major changes by Sean Burke: * Tk::Parse replaced by Pod::Simple and Tk::Pod::SimpleBridge * changes to Tk::Pod::Text to use the new parser backend * style definition moved to Tk::Pod::Styles * printing facility for Windows with write.exe or notepad.exe version 0.99_08 o fixed typo in Tk::Pod::Text --- links to head1 sections should work now o tkpod -s (server mode) implemented o Adjuster between tree and text widgets works (again) version 0.99_07 o cygwin compatibility o bugfix in Tk::Pod::Text (thanks, John Cerney!) version 0.99_06 o new "Set Pod" menu entry in Pod.pm o Double-2 opens pod in new window (like Shift-Double-1) o another change in Search_db.pm suggested by Martin Raspe o compatibility to Tk 800.014 version 0.99_05 o change in Search_db.pm for ActivePerl (suggested by Martin Raspe) version 0.99_04 o switch to show PODs of not installed CPAN modules o new View menu o POD tree is now switchable on and off from the menu o some fixes version 0.99_03 o some Text menu bindings in PodText o incremented versions to prevent CPAN mismatches o FullText search term is set automatically as search term in PodText version 0.99_02 o some fixes for MSWin32 and Perl 5.005 o Reload menu for PodTree version 0.99_01 o various bug fixes o colored entries in pod tree o no more Tk40x.xxx support o new/better More.pm bindings o break long menus (on X11) version 0.12 (not released) o new Tk::Pod::Tree module and a tree view for POD files o better history support: forward/backward/view history (with new menu) o new popup menu entry Forward o Alt-Left/Right bindings o usign getOpenFile instead of FileSelect o using messageBox instead of BackTrace o standard editor is ptked o using Tk::Parse::Escapes instead of private translate hash o change cursor image over links o scrollbars are now on the right side (only Windows) o bugfix: remove X<...> from section menu entries o bugfix: internal links and middle button work now o new maintainer version 0.11 o fixed VERSION problem: 1.14+2 < 3.14 o Added 'standard perl' COPYRIGHT notices to modules version 0.10 o New Search menu, Up/down bindigs and PATH scanned after @INC for PODs Thanks to Slaven Rezic o Pod/Text.pm added support simple =head3 support (treated like =head2) o Parse.pm added =begin/=end support (but not nesting or check/match of word after =begin/=end). Better impl. has to wait until Pod::Parser is used o 'Reload' jumps to same line after document is reloaded o =pod doesn't generate a warning anymore o t/basic.t: basic widget test ala Tk800 t/create.t version 0.09 o Tk::Pod & Tk::Pod::Text: fixed version (1.9 > 1.10 problem) o Added section menu (Thanks Slaven) o Use Busy/UnBusy during load of POD o 'Help'->'Usage..' used Pod_usage.pod o L works a bit better (still broken if loaded to new POD window) version 0.08 o E<> support also 'space' 'tab' o I<> is now in weight 'medium' and not 'bold' o -font option removed so it's really 'courier' o Fixed version number of Tk::Pod and Tk::Pod::Text so it increasing again (1.9 > 1.11 problem) version 0.07 Tk/Pod/Text.pm o Links don't change font size in =head and =item commands o Support L and L (/"head" and /item still don't work when new Pod widget should is opened (<2> or ) o Support L (new in 5.004_05 to be and > 5.005_56) Tk/Pod.pm o Don't pack menubuttons for Tk800.*. (Thanks to Slaven Rezic ) o 'Help/Usage' works when installed (also Win*?) Tk/More.pm o better h,j,k,l bindings scroll regardless of 'insert' position o insertCursor is invisible (well zero width) o insertCursor off time set to 0 sec to switch of blinking (see text.n doc) o fixed packing so entry does not fanish for small More widgets version 0.06 o fixed 'Quit' error o Pod widgets created from another Pod widget have now same parent as Pod widget that created them version 0.05 o tkpod: added -tk switch so, Pod will be found even if Tk:: or Tk/ prefix is omitted. o Fixed wrong $VERSION of Tk::Pod version 0.0401 o For 2 button mouse owners: does same as : load doc into new window. o Fixed Tk::Pod version to be higher than in Tk402.003 so CPAN.pm gets the right distribution o more TODO entries :-) version 0.04 o applied Tk/Parse.pm patch of Slaven Rezic to fix problem triggered by perlfaq4.pod o Allow upcase chars in E<> as: Auml, Ouml,... o Shift-Button-1 was used to open new window on L<>. Now it's Button-2 o added 'szlig' to E<> o Added more example POD markup to Tk/Pod/Text for verification version 0.03 o fixed warn on =for. Perl Data Language has lots of them o use alpha FcyEntry widget if available o Tk/More status line: flat<->sunken, disabled<->normal version 0.02 o use CDE default fonts if available o first go on Tk::More widget o use perlindex full text index if available version 0.01 o derived from Tk402.003 tkpod Tk/Pod.pm o Extracted Tk::Pod::Text from Tk::Pod and use ROText o 'better than nothing POD' for tkpod, Tk::Pod, Tk::Pod::Text.pm o Added tkpod Help menu o L<> in blue o Button-* load POD in same window (with shift in separate window) o tkpod now exits when last Pod widget is closed o quick and dirty 'back' history. o Added Popup menu: back, reload, edit o removed Autoloader and sub old_process o some other little fixes I can't remember right now Tk-Pod-0.9943/t/000755 001750 001750 00000000000 12653407627 014017 5ustar00eserteeserte000000 000000 Tk-Pod-0.9943/MANIFEST000644 001750 001750 00000001230 12653407630 014673 0ustar00eserteeserte000000 000000 Changes Makefile.PL MANIFEST MANIFEST.SKIP More.pm Pod.pm Pod/Cache.pm Pod/FindPods.pm Pod/Search.pm Pod/Search_db.pm # should be in perlindex dist after cleanup Pod/SimpleBridge.pm Pod/Styles.pm Pod/Text.pm Pod/Tree.pm Pod/Util.pm Pod/WWWBrowser.pm # inofficial module for accessing web browser Pod_usage.pod README t/basic.t t/cmdline.t t/more.t t/optionalmods.t t/pods.t t/podtree.t t/subclass.t t/testdata/latin1.txt t/testdata/utf8.txt t/testdata/utf8.txt.gz t/TkTest.pm tkmore tkpod TODO META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Tk-Pod-0.9943/TODO000644 001750 001750 00000022751 12051475651 014245 0ustar00eserteeserte000000 000000 TODO -*- mode: org; coding: utf-8; -*- Scratch pad of bugs, missing features, and misbehaviors collected while using tkpod (best viewed with Emacs' org-mode). * BUGS ** Tk::Pod *** Tk::Pod::Text should not manipulate the Toplevel's title [[cpanrt:67306]] Idea: one can mark the PodText as "-embedded". In this case no manipulations of the parent toplevel are done, especially the title is set untouched. Ideally this would be the other way, one should mark a "master toplevel" for the PodText, but well, because of backward compatibility the current behavior will stay. *** S<> seems often to be ignored May be a core Tk::Text bug (i.e. -wrap => "none" in tags being sometimes ignored) -> Should find sample Pod to easily reproduce this problem. *** For Windows: check whether Tk::More/Tk::Tree match the system background colors Also check if the "Help" menu item is on the correct place. *** Title is not displayed if function or FAQ pod in displayed in a new window or when navigating in the history back or forward to a function/FAQ pod *** $podtext->configure(-file => ...) does not work always as expected When set from a command line argument, then one expects to use the name of a module in perl's pod path (specified without .pm or .pod extension) or a (relative) path to a file (with extension). Example: cd ~/src/bbbike tkpod ESRI/esri2bbd.pl * now click on bbbike link => bbbike itself will be loaded, not bbbike.pod because of a -f test in findpod *** Do not move focus if already in PodText's search entry *** The perlfunc subentries do not show up in the history *** Links within perlfunc subentries do not work (seen in "-f import") *** Paragraphs after bullet and number items do not align correctly Tweaking the _indent functionality in Tk::Pod::SimpleBridge seems to be necessary. *** If .pod and .pm are located in separated directories, then the wrong file (the .pm) might be chosen Seen on Debian with IO::Handle. *** There is never a horizontal scrollbar, even if a verbatim block exceeds the window width An workaround would be to have the vertical scrollbar non-optional and the horizontal scrollbar optional (unfortunately both cannot be optional because of a bug in the Scrolled code). *** DONE old window is jumping after ctrl-n and ctrl-p because these already have bindings in Tk::Text -> workarounded, but need good checks first! ** Tk::Pod::Search *** Reorder modules in the fulltext search results to reflect @INC order ** Tk::More *** Highlight matches also in link text ** tkpod *** In server mode, no commandline options are accepted Probably at least -h/-? should be supported and errors for other options dropped. *** Get rid of the numerous warnings in server/client mode. *** If the client sends a file which cannot be opened, then the server crashes! *** The tkpod client should send cwd, so relative filenames work in server mode, too. *** Some systems (e.g. Debian) may not have any perl documentation installed, i.e. no perl.pod tkpod should not die if perl.pod is not available, but maybe just start with a blank page. * WISHLIST ** Tk::Pod *** History: prefer short pod names over filenames If filenames, then maybe show more than the basename, and maybe abbreviate it if it's too long. Do not record temporary file names (as in perldoc -f / -q) in history view. But show something sensible instead (currently it seems that there's only an empty entry). *** If "perlindex -index" is not run yet: ask user to run it? Problematic on Unix, because perlindex should be run as superuser. *** On Windows: show printer selection dialog first, maybe also on KDE/GNOME, if available *** Optionally save settings on exit, e.g. current base font size *** using other fonts Marek Rouchal writes: Subject: tkpod - other font Fine, there is a central place where I can do adaptations easily - but how can I easily override? The only solution I can imagine right now is to place a Tk::Pod::Styles in some $PERL5LIB directory and shadow the installation's Tk::Pod::Styles; there could be e.g. a -usestyle Tk::Pod::Styles::Mine option, where I can provide my own package, which inherits from Tk::Pod::Styles and overrides one or more subs. But I would appreciate a general solution with either a ~/.tkpodrc or the X resources, as already mentioned. -> There's now a solution with X resources, which are also settable with -xrm. But maybe a .tkpodrc solution would also be nice, especially for non-X11 people. *** Maybe patch Ulrichs TPJ example code for nroff pages to allow both POD and MAN in fulltext search dialog *** add meaningful regression tests *** use some kind of access control for the -s option *** new menu entry with a link list (e.g. all L<...> and everything looking like a module /\w+::\w+/) *** make ManViewer into a standalone widget, link entries in "SEE ALSO" *** option for interleaving POD and code *** show "No documentation found for "..."" if there's no pod in the file (just like perldoc) *** support for the new Pod::Index module (similar to the fulltext search) *** some kind of stylesheet support *** It should probably be possible to create the menus Section and History independently of the main Tk::Pod frame So the user may add these menus to the context menu of the PodText window. *** Maybe have a new popup menu entry View -> Pod info which shows path and basic Pod information *** If a Pod could not be found: add a button "Look at search.cpan.org" to the error dialog *** "Open Pod by name" dialog could be done nicer e.g. by using a rich Tk::Text instead of the label/message and use "sans serif"+"monospace" fonts. ** Tk::More *** A menu item for switching between popular encodings Default probably to iso-8859-1 or maybe user's locale. *** A menu item (and maybe also the keyboard equivalent -x) for changing the indentation level *** If there are more configuration parameters resembling less, then maybe an environment variable like LESS could be useful for common configuration parameters Question: should this only be valid if it's called as tkmore or also if embedded in Tk::Pod? *** Tk/More status bar: filename % line x *** more 'more' like key bindings to Tk::More *** search should scroll per page *** search policies: regexp, glob, incremental (as in xmore) and 'normalized' as in perlindex Should go into it's own Tk::Text::Util.pm module Or: use Tk::FindBar (create it first by branching Tkx::FindBar) for incremental search. *** after switching between case sensitive/insensitive highlightning should be updated immediately *** automatic case-sensitive search if there is at least one uppercase character in the search string, then do a case-sensitive search (like emacs) *** scrolling is not as exact as it shoule be (i.e. scroll forw, then scroll back will not get to the same position as before) *** use Tk::HistEntry for search entry *** implement isearch *** over a link opens the link (but this needs some kind of "current link" feature, probably by using or similar to select the next link). ** Tk::Pod::Cache *** use a LRU cache with $MAX_CACHE documents *** maybe do not cache small documents at all *** store modtime of POD files and flush cache automatically if the file changed *** consider to cache per INC path, so user can use custom @INC/@PERLPOD and everything works as expected e.g. ~/tkpod_cache/perlspec(abspathofconfig)/MD5orSHA1ofpath ~/tkpod_cache/perlspec(abspathofconfig)/.info ** Tk::Pod::Tree *** Make tree busy while building first time *** Show a progress bar or an indicator when refreshing the pod index *** Build the tree in background, e.g. by using standard perl ipc (pipe+fork) This already happens for Unix, but it would be nice if it also implemented (and tested) on Windows systems. *** Show old cached contents while rebuilding the tree But show a notice that the tree is updated. Once the new tree is available, it should be displayed (and the currently opened leaves should be restored), and the update notice should be removed. *** Some zoom functionality Maybe depending on the zoom factor of the main window, and/or an additional menu entry. *** Should I include something similar to perlfunc for perlfaq (perldoc -q)? Maybe a new menu item "Search FAQ"? *** Implement C<-rememberopen> in C method *** Mark modules which appear multiple times in the @INC tree e.g. with an exclamation mark, and maybe show the paths and versions(?) of both/all versions ** tkpod *** Instead of listening to a tcp socket, maybe one should use a unix domain socket (security, a unix domain socket may be chown'ed and chmod'ed!) *** tkpod -s: should probably reuse the Pod window instead of re-creating new ones Maybe this should be controlled by another option. *** handle "-" for stdin * Expired problems These bugs are probably fixed or not reproducable or apparent on old systems only: ** Ctrl-O Exporter does not work?! ** What about the reported error on Suse Linux (see Tk-Pod entry on rt.cpan.org)? I can't reproduce this bug... ** Dump does not always work on a RedHat 8.0 system, so I had to use a workaround. Also, Tk::Pod very often dumps core on this system in conjuction with perl5.8.0 and Tk800.025, but this might be a RedHat-related issue. * org-mode settings #+LINK: cpanrt http://rt.cpan.org/Public/Bug/Display.html?id=%s #+LINK: perlrt http://rt.perl.org/rt3/Ticket/Display.html?id=%s Tk-Pod-0.9943/Pod_usage.pod000755 001750 001750 00000006534 12051475651 016173 0ustar00eserteeserte000000 000000 =head1 NAME Tk::Pod_usage - How to use the perl/Tk Pod browser widget =head1 DESCRIPTION To navigate through the documentation one could use =head2 Hyperlinks A B on a hyperlink display the corresponding Pod documentation (if there is any) in the same window. An URL will be displayed in a web browser. A man page will be displayed in a man viewer (if one is available). With the documentation is loaded into a new window ( works also for those with only a 2 button mouse). =head2 Selection A B tries to load the documentation for the selected word in the same window. If the C key is simultaneously pressed a new browser window is opened. =head2 Key bindings The L widget is based on the L widget inheriting its key bindings. =head2 Search Pressing lets you search in the displayed documentation. =head2 Section Menu The Section Menu The 'Section' menu allows one to directly jump to the start of a section in the documentation. =head2 Action Menu If you press the right mouse button you get a popup menu that allows: =over 4 =item o Back in history of displayed documentation =item o Forward in history of displayed documentation =item o Reload the documentation =item o Edit Pod Start editor with source of the displayed document. The used editor is selected by the first definition of the environment variables C, C, C, C or as default F. If no terminal is available (or on Windows platforms), the L editor (bundled with Perl/Tk) will be used instead. See also the menu entries 'File' -E 'Edit' and 'File' -E 'Edit with ptked'. =item o Search fulltext Full text search of the Pod in the perl library directories. (Note: to use it one has to install the perlindex distribution and build an index for the perl documentation, see L) =back The remaining menu entries are the same as in normal C widgets. =head2 Tree view You can toggle the tree view of all installed modules on or off with the 'View' -E 'Pod Tree' menu entry. The tree view is organized in three sections: Perl language (general documentation about Perl), Pragmata, and Modules. The labels in the tree are colored, where green means Estandard module which comes with the Perl core distributionE, red means Elocally installed module, probably from CPANE, and grey means Eno module available, look at the subtreeE. The tree data is cached in a temporary directory on a per-perl-version and per-user basis. A reload can be forced with the B entry in the action menu of the tree view. With the B entry a search in the tree can be performed. The B entry is highly experimental - you can download, extract and look at the documentation of all CPAN modules. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L. =head1 KEYWORDS pod, browser, tk, hypertext =head1 AUTHOR Achim Bohnet > Current maintainer is Slaven Rezic > Copyright (c) 1997-1998 Achim Bohnet. All rights reserved. This documentation is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-Pod-0.9943/tkmore000755 001750 001750 00000005126 12051475651 015001 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w use strict; use vars qw($VERSION); $VERSION = 5.08; use Tk; use Tk::More; use Getopt::Long; my %opt; Getopt::Long::config('pass_through'); if (!GetOptions(\%opt, "font=s", "i|ignore-case!", "encoding=s", "S")) { require Pod::Usage; Pod::Usage::pod2usage(2); } my $mw = tkinit; # Unhandled options left? Getopt::Long::config('nopass_through'); if (!GetOptions({})) { require Pod::Usage; Pod::Usage::pod2usage(2); } my $file = shift @ARGV; if (!defined $file) { die "Filename is missing.\n"; } my $more = $mw->Scrolled("More", -font => $opt{font}, -scrollbars => "osoe", -searchcase => !$opt{i}, ($opt{S} ? (-wrap => 'none') : ()), )->pack(-fill => "both", -expand => 1); my $menu = $more->menu; my $fm = $menu->entrycget("File", -menu); $fm->insert("Exit", "command", -label => "Open ...", -underline => 0, -command => sub { my $f = $more->getOpenFile; return if !defined $f; load_file($f); }); $fm->entryconfigure("Exit", -accelerator => "Ctrl-Q"); my $helpmenu = $menu->Menu (-tearoff => 0, -menuitems => [ [Button => "~Usage", -command => sub { require Tk::Pod; $mw->Pod(-file => "Tk::More"); }] ] ); $menu->cascade(-label => "Help", -underline => 0, -menu => $helpmenu); $mw->configure(-menu => $menu); $more->focus; load_file($file); $more->AddQuitBindings; MainLoop; sub load_file { my $file = shift; LOAD_FILE: { # check if it's gzipped my $buf; if (open(FILE, "<$file") && read(FILE, $buf, 2) == 2 && $buf eq "\037\213" && eval { require PerlIO::gzip; 1 } ) { seek FILE, 0, 0 or die $!; binmode FILE, ':gzip'; $more->LoadFH(\*FILE, -encoding => $opt{encoding}); last LOAD_FILE; } $more->Load($file, -encoding => $opt{encoding}); }; $mw->title("tkmore - $file"); } __END__ =head1 NAME tkmore - a Perl/Tk based pager =head1 SYNOPSIS tkmore [X11 options] [-i] [-encoding encoding] filename =head1 DESCRIPTION B is a pager similar to L or L. =head2 OPTIONS Besides standard X11 options like C<-font>, B supports: =over =item -i Turn on case-insensitive search. Alias: C<-ignore-case>. =item -encoding encoding Specify the encoding for the specified file and all subsequently loaded files. By default no encoding is assumed. =item -S Set wrap mode to B. The effect is similar like the C<-S> option of C. =back =head2 KEY BINDINGS For a list of key bindings, see L. =head1 AUTHOR Slaven Rezic =head1 SEE ALSO L, L, L =cut Tk-Pod-0.9943/tkpod000755 001750 001750 00000027101 12472430311 014605 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w use strict; use vars qw($VERSION $tk_opt $tree $server $portfile $Mblib @I $debug); $VERSION = '5.10'; use IO::Socket; sub INIT { my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}; $portfile = "$home/.tkpodsn"; my $port = $ENV{'TKPODPORT'}; return if $^C; unless (defined $port) { if (open(SN,"$portfile")) { $port = ; close(SN); } } if (defined $port) { my $sock = IO::Socket::INET->new(PeerAddr => 'localhost', PeerPort => $port, Proto => 'tcp'); if ($sock) { binmode($sock); $sock->autoflush; foreach my $file (@ARGV) { unless (print $sock "$file\n") { die "Cannot print $file to socket: $!"; } print "Requested '$file'\n"; } $sock->close || die "Cannot close socket: $!"; exit(0); } else { warn "Cannot connect to server on $port: $!"; } } } use Tk; # Experimental mousewheel support. This is part of newer Tk versions. # XXX support for Windows is untested. BEGIN { if ($Tk::VERSION < 800.024012) { local $^W = 0; require Tk::Listbox; my $orig_tk_listbox_classinit = \&Tk::Listbox::ClassInit; *Tk::Listbox::ClassInit = sub { my($class,$mw)=@_; $orig_tk_listbox_classinit->(@_); $mw->bind($class, "<4>", ['yview', 'scroll', -5, 'units']); $mw->bind($class, "<5>", ['yview', 'scroll', +5, 'units']); $mw->bind($class, '', [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); }; require Tk::ROText; my $orig_tk_text_classinit = \&Tk::ROText::ClassInit; *Tk::ROText::ClassInit = sub { my($class,$mw)=@_; $orig_tk_text_classinit->(@_); $mw->bind($class, "<4>", ['yview', 'scroll', -5, 'units']); $mw->bind($class, "<5>", ['yview', 'scroll', +5, 'units']); $mw->bind($class, '', [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); }; require Tk::HList; my $orig_tk_hlist_classinit = \&Tk::HList::ClassInit; *Tk::HList::ClassInit = sub { my($class,$mw)=@_; $orig_tk_hlist_classinit->(@_); $mw->bind($class, "<4>", ['yview', 'scroll', -5, 'units']); $mw->bind($class, "<5>", ['yview', 'scroll', +5, 'units']); $mw->bind($class, '', [ sub { $_[0]->yview('scroll',-($_[1]/120)*3,'units') }, Tk::Ev("D")]); }; } } ### Problems under Windows... do not use it anymore #BEGIN { eval { require Tk::FcyEntry; }; }; use Tk::Pod 4.18; use Tk::Pod::Text; # for findpod use Getopt::Long; #require Tk::ErrorDialog; my $geometry; # Do a pre-scan of cmdline to see if -geometry is used Getopt::Long::Configure('pass_through'); GetOptions("geometry=s" => \$geometry); Getopt::Long::Configure('nopass_through'); my $mw = MainWindow->new(); my $orig_state = $mw->state; # may be iconic $mw->withdraw; my $function; my $question; my $exit; $tree = 0; #XXX Getopt::Long::Configure ("bundling"); if (!GetOptions("tk" => \$tk_opt, "tree" => \$tree, "notree" => sub { $tree = 0 }, "s|server!" => \$server, "Mblib" => \$Mblib, "I=s@" => \@I, "d|debug!" => \$debug, 'exit' => \$exit, "f=s" => \$function, "q=s" => \$question, "filedialog=s" => sub { my $mod = $_[1]; eval qq{ use $mod qw(as_default) }; die $@ if $@; }, "version" => sub { print <optionGet('userFont','UserFont'); # fixed width my $sfont = $mw->optionGet('systemFont','SystemFont'); # proportional if (defined($ufont) and defined($sfont)) { foreach ($ufont, $sfont) { s/:$//; }; $mw->optionAdd('*Font', $sfont); $mw->optionAdd('*Entry.Font', $ufont); $mw->optionAdd('*Text.Font', $ufont); } if (1 && $^O ne "MSWin32") { # XXX still decide my $lighter = $mw->Darken(Tk::NORMAL_BG, 110); foreach my $class (qw(Entry BrowseEntry.Entry More*ROText Pod*Tree)) { $mw->optionAdd("*$class*background", $lighter, "userDefault"); } $mw->optionAdd("*Pod*Pod*Frame*More*ROText*background", $lighter, "interactive"); } $mw->optionAdd('*Menu.tearOff', $Tk::platform ne 'MSWin32' ? 1 : 0); my @extra_dirs; if (defined $Mblib) { # XXX better to use Tk::Pod->Dir? blib/scripts => Tk::Pod->ScriptDir? require blib; blib->import; } if (@I) { push @extra_dirs, @I; } Tk::Pod->Dir(@extra_dirs) if @extra_dirs; if ($ENV{TKPODDIRS}) { require Config; for my $dir (split $Config::Config{'path_sep'}, $ENV{TKPODDIRS}) { Tk::Pod->Dir($dir); } } my $tl; my $file; my $opened = 0; foreach $file (@ARGV) { if (-d $file && !Tk::Pod::Text->findpod($file, -quiet => 1)) { Tk::Pod->Dir($file); } else { $tl = make_tk_pod_window(); # -file => ... should be called after creating the Pod window, # because -title => ... is set implicitly by Pod's new $tl->configure(-file => $file); $opened++; } } if (defined $function) { $tl = make_tk_pod_window(); $tl->configure($tl->getpodargs(-f => $function)); $opened++; } if (defined $question) { $tl = make_tk_pod_window(); $tl->configure($tl->getpodargs(-q => $question)); $opened++; } if (!$opened) # This may happen if all arguments are directories { $tl = make_tk_pod_window(); if (!$tree) { $tl->configure(-file => "perl"); } } if (Tk::Exists($tl) && $orig_state eq 'iconic') { $tl->iconify; } # xxx dirty but it works. A simple $mw->destroy if $mw->children # does not work because Tk::ErrorDialogs could be created. # (they are withdrawn after Ok instead of destory'ed I guess) if ($mw->children) { $mw->repeat(1000, sub { if (Tk::Exists($mw)) { # ErrorDialog is withdrawn not deleted :-( foreach ($mw->children) { return if "$_" =~ /^Tk::Pod/ # ->isa('Tk::Pod') } $mw->destroy; } }); } else { $mw->destroy; } Tk::App::Reloader::check_loop() if $use_reloader; MainLoop unless $exit; unlink($portfile); exit(0); sub make_tk_pod_window { my $tl = $mw->Pod( -exitbutton => 1, ); if ($geometry) { $tl->geometry($geometry); } if ($tree) { $tl->tree($tree); } $tl; } sub start_server { my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp'); die "Cannot open listen socket: $!" unless defined $sock; binmode($sock); my $port = $sock->sockport; $ENV{'TKPODPORT'} = $port; open(SN,">$portfile") || die "Cannot open $portfile: $!"; print SN $port; close(SN); print STDERR "Accepting connections on $port\n"; $mw->fileevent($sock,'readable', sub { print STDERR "accepting $sock\n"; my $client = $sock->accept; if (defined $client) { binmode($client); print STDERR "Connection $client\n"; $mw->fileevent($client,'readable',[\&PodRequest,$client]); } }); $SIG{TERM} = \&server_cleanup; } sub server_cleanup { unlink $portfile if -e $portfile; } sub PodRequest { my($client) = @_; local $_; while (<$client>) { chomp($_); print STDERR "'$_'\n"; my $pod = make_tk_pod_window(); $pod->configure(-file => $_); } warn "Odd $!" unless eof($client); $mw->fileevent($client,'readable',''); print STDERR "Close $client\n"; $client->close; } __END__ =head1 NAME tkpod - Perl/Tk Pod browser =head1 SYNOPSIS tkpod [-tk] [[-no]tree] [-Mblib] [-I dir] [-d|debug] [-s|server] [-filedialog module] [-f function | -q FAQRegex | directory | name [...]] =head1 DESCRIPTION B is a simple Pod browser with hypertext capabilities. Pod (L) is a simple and readable markup language that could be mixed with L code. Pods are searched by default in C<@INC> and C<$ENV{PATH}>. Directories listed on the command line or with the B<-I> option are added to the default search path. For each C listed on the command line B tries to find Pod in C, C and C in the search path. For each C a new Pod browser window is opened. If no C is listed, then the main C pod is opened instead. =head1 OPTIONS =over 4 =item B<-tree> When specified, C will show a tree window with all available Pods on the local host. However, this may be slow on startup, especially first time because there is no cache yet. You can always turn on the tree view with the menu entry 'View' -E 'Pod Tree'. =item B<-tk> Useful for perl/Tk documentation. When specified it adds all C subdirectories in C<@INC> to the Pod search path. This way when C is selected in the browser the C documentation is found. =item B<-s> or B<-server> Start C in server mode. Subsequent calls to C (without the B<-s> option) will cause to load the requested Pods into the server program, thus minimizing startup time and memory usage. Note that there is no access control, so this might be a security hole! =item B<-Mblib> Add the C directories under the current directory to the Pod search path. =item B<-I> I Add another directory to the Pod search path. Note that the space is mandatory. =item B<-f> I Show documentation for I. =item B<-q> I Show the FAQ entry matching I. =item B<-filedialog> I Use an alternative file dialog module, e.g. L, L or L. =item B<-d> or B<-debug> Turn debugging on. =item B<-exit> Only for internal testing: exit before entering C. =back =head1 USAGE How to navigate with the Pod browser is described in L. It's also accessible via the menu 'Help' -> 'Usage...'. =head1 ENVIRONMENT =over =item TKPODPORT Force a port for tkpod's server mode. =item TKPODDIRS A list of directories (on Unix usually separated by C<:>, on Windows by C<;>) for additional Pod directories. These directories will appear in the "local dirs" section of the tree view. =back See L and L for more environment variables. =head1 KNOWN BUGS see L =head1 SEE ALSO L L L L L L L =head1 AUTHOR Nick Ing-Simmons > Former maintainer: Achim Bohnet >. Code currently maintained by Slaven Rezic >. Copyright (c) 1997-1998 Nick Ing-Simmons. Copyright (c) 2015 Slaven Rezic. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-Pod-0.9943/MANIFEST.SKIP000644 001750 001750 00000000726 12653407546 015457 0ustar00eserteeserte000000 000000 # common files \bRCS\b \bCVS\b ^\.git/ \bChangeLog\b ^MANIFEST\.bak \bMakefile$ ~$ ^Attic/ \.gdbinit$ \.class$ \.old$ \.xvpics/ \.rcsignore(_rx)?$ ^blib/ ^MakeMaker-\d \.tar\.gz$ patch\.gz$ ^pm_to_blib$ \.ppd$ ^\.prove$ ^MYMETA\.json$ ^MYMETA\.yml$ # private common files \.ok2cgi$ \.copynewer.SKIP$ \.spp$ ^\.permissions$ # project specific ^index.html$ ^ANNOUNCE$ # replaced by Tk::Pod::SimpleBridge Parse.pm ^\.cvsignore$ ^\.gitignore$ ^\.travis\.yml$ ^appveyor.yml$ Tk-Pod-0.9943/Pod.pm000644 001750 001750 00000055471 12653407371 014644 0ustar00eserteeserte000000 000000 package Tk::Pod; use strict; use Tk (); use Tk::Toplevel; use vars qw($VERSION $DIST_VERSION @ISA); $VERSION = '5.41'; $DIST_VERSION = '0.9943'; @ISA = qw(Tk::Toplevel); Construct Tk::Widget 'Pod'; my $openpod_history; my $searchfaq_history; sub Pod_Text_Widget { "PodText" } sub Pod_Text_Module { "Tk::Pod::Text" } sub Pod_Tree_Widget { "PodTree" } sub Pod_Tree_Module { "Tk::Pod::Tree" } sub Populate { my ($w,$args) = @_; if ($w->Pod_Text_Module) { eval q{ require } . $w->Pod_Text_Module; die $@ if $@; } if ($w->Pod_Tree_Module) { eval q{ require } . $w->Pod_Tree_Module; die $@ if $@; } $w->SUPER::Populate($args); my $tree = $w->Scrolled($w->Pod_Tree_Widget, -scrollbars => 'oso'.($Tk::platform eq 'MSWin32'?'e':'w') ); $w->Advertise('tree' => $tree); my $searchcase = 0; my $p = $w->Component($w->Pod_Text_Widget => 'pod', -searchcase => $searchcase)->pack(-expand => 1, -fill => 'both'); my $exitbutton = delete $args->{-exitbutton} || 0; # Experimental menu compound images: # XXX Maybe there should be a way to turn this off, as the extra # icons might be memory consuming... my $compound = sub { ($_[0]) }; if ($Tk::VERSION >= 800 && eval { require Tk::ToolBar; 1 }) { $w->ToolBar->destroy; # hack to load images if (!$Tk::Pod::empty_image_16) { # XXX multiple MainWindows? $Tk::Pod::empty_image_16 = $w->MainWindow->Photo(-data => <= 804) { # Tk804 has native menu item compounds $compound = sub { my($text, $image) = @_; if ($image) { ($text, -image => $image . "16", -compound => "left"); } else { ($text, -image => $Tk::Pod::empty_image_16, -compound => "left"); } }; } elsif (eval { require Tk::Compound; 1 }) { # For Tk800 we have to create our own compounds using Tk::Compund # get the default font (taken from bbbike): my $std_font = $w->optionGet('font', 'Font'); if (!defined $std_font || $std_font eq '') { my $l = $w->Label; $std_font = $l->cget(-font); $l->destroy; } my %std_font = $w->fontActual($std_font); # create an underlined font which matches the default font my $underline_font = join(" ", map { "{" . $std_font{$_} . "}" } qw(-family -size -weight -slant)); $underline_font .= " overstrike" if $std_font{-overstrike}; $underline_font .= " underline"; $compound = sub { my($text, $image) = @_; my $c = $w->MainWindow->Compound; # XXX multiple MainWindows? if ($image) { $c->Image(-image => $image."16"); } else { $c->Image(-image => $Tk::Pod::empty_image_16); } $c->Space(-width => 4); my($text_before, $underlined_text, $text_after) = $text =~ /^(.*)~(.)(.*)/; if (defined $underlined_text) { $c->Text(-text => $text_before) if $text_before ne ""; $c->Text(-text => $underlined_text, -font => $underline_font); $c->Text(-text => $text_after) if $text_after ne ""; } else { $c->Text(-text => $text); } ($text, -image => $c); }; } } my $menuitems = [ [Cascade => '~File', -menuitems => [ [Button => $compound->('~Open File...', "fileopen"), '-accelerator' => 'F3', '-command' => ['openfile',$w], ], [Button => $compound->('Open ~by Name...'), '-accelerator' => 'Ctrl+O', '-command' => ['openpod',$w,$p], ], [Button => $compound->('~New Window...'), '-accelerator' => 'Ctrl+N', '-command' => ['newwindow',$w,$p], ], [Button => $compound->('~Edit', "edit"), '-command' => ['edit',$p], ], [Button => $compound->('Edit with p~tked'), '-command' => ['edit',$p,'ptked'], ], [Button => $compound->('~Print'. ($p->PrintHasDialog ? '...' : ''), "fileprint"), '-accelerator' => 'Ctrl+P', '-command' => ['Print',$p], ], [Separator => ""], [Button => $compound->('~Close', "fileclose"), '-accelerator' => 'Ctrl+W', '-command' => ['quit',$w], ], ($exitbutton ? [Button => $compound->('E~xit', "actexit"), '-accelerator' => 'Ctrl+Q', '-command' => sub { $p->MainWindow->destroy }, ] : () ), ] ], [Cascade => '~View', -menuitems => [ [Checkbutton => $compound->('Pod ~Tree'), '-variable' => \$w->{Tree_on}, '-command' => sub { $w->tree($w->{Tree_on}) }, ], '-', [Button => $compound->("Zoom ~in", "viewmag+"), '-accelerator' => 'Ctrl++', '-command' => [$w, 'zoom_in'], ], [Button => $compound->("~Normal"), '-command' => [$w, 'zoom_normal'], ], [Button => $compound->("Zoom ~out", "viewmag-"), '-accelerator' => 'Ctrl+-', '-command' => [$w, 'zoom_out'], ], '-', [Button => $compound->('~Reload', "actreload"), '-accelerator' => 'Ctrl+R', '-command' => ['reload',$p], ], [Button => $compound->("~View source"), '-accelerator' => 'Ctrl+U', '-command' => ['view_source',$p], ], '-', [Button => $compound->('Pod on ~search.cpan.org'), '-command' => sub { require Tk::Pod::Util; my $url = $p->{pod_title}; eval { require URI::Escape; $url = URI::Escape::uri_escape($url); }; Tk::Pod::Util::start_browser("http://search.cpan.org/perldoc?" . $url); }, ], [Button => $compound->('Pod on ~metacpan.org'), '-command' => sub { require Tk::Pod::Util; my $url = $p->{pod_title}; eval { require URI::Escape; $url = URI::Escape::uri_escape($url); }; Tk::Pod::Util::start_browser("https://metacpan.org/module/" . $url); }, ], [Button => $compound->('Pod on ~annocpan.org'), '-command' => sub { require Tk::Pod::Util; my $url = $p->{pod_title}; eval { require URI::Escape; $url = URI::Escape::uri_escape($url); }; ## It seems that the search works better than the direct link on annocpan.org... Tk::Pod::Util::start_browser("http://www.annocpan.org/?mode=search&field=Module&name=$url"); #Tk::Pod::Util::start_browser("http://www.annocpan.org/perldoc?" . $url); }, ], ] ], [Cascade => '~Search', -menuitems => [ [Button => $compound->('~Search', "viewmag"), '-accelerator' => '/', '-command' => ['Search', $p, 'Next'], ], [Button => $compound->('Search ~backwards'), '-accelerator' => '?', '-command' => ['Search', $p, 'Prev'], ], [Button => $compound->('~Repeat search'), '-accelerator' => 'n', '-command' => ['ShowMatch', $p, 'Next'], ], [Button => $compound->('R~epeat backwards'), '-accelerator' => 'N', '-command' => ['ShowMatch', $p, 'Prev'], ], [Checkbutton => $compound->('~Case sensitive'), '-variable' => \$searchcase, '-command' => sub { $p->configure(-searchcase => $searchcase) }, ], [Separator => ""], [Button => $compound->('Search ~full text', "filefind"), '-command' => ['SearchFullText', $p], ], [Button => $compound->('Search FA~Q'), '-command' => ['SearchFAQ', $w, $p], ], ] ], [Cascade => 'H~istory', -menuitems => [ [Button => $compound->('~Back', "navback"), '-accelerator' => 'Alt-Left', '-command' => ['history_move', $p, -1], ], [Button => $compound->('~Forward', "navforward"), '-accelerator' => 'Alt-Right', '-command' => ['history_move', $p, +1], ], [Button => $compound->('~View'), '-command' => ['history_view', $p], ], '-', [Button => $compound->('Clear cache'), '-command' => ['clear_cache', $p], ], ] ], [Cascade => '~Help', -menuitems => [ # XXX restructure to not reference to tkpod [Button => '~Usage...', -command => ['help', $w]], [Button => '~Programming...', -command => ['help_programming', $w]], [Button => '~About...', -command => ['about', $w]], ($ENV{'TKPODDEBUG'} ? ('-', [Button => 'WidgetDump', -command => sub { $w->WidgetDump }], [Button => 'Ptksh', -command => sub { # Code taken from bbbike # Is there already a (withdrawn) ptksh? foreach my $mw0 (Tk::MainWindow::Existing()) { if ($mw0->title =~ /^ptksh/) { $mw0->deiconify; $mw0->raise; return; } } require Config; my $perldir = $Config::Config{'scriptdir'}; require "$perldir/ptksh"; # Code taken from bbbike and slightly modified foreach my $mw0 (Tk::MainWindow::Existing()) { if ($mw0->title eq 'ptksh') { $mw0->protocol('WM_DELETE_WINDOW' => [$mw0, 'withdraw']); } } }], [Button => 'Reloader', -command => sub { if (eval { require Module::Refresh; 1 }) { Module::Refresh->refresh; $w->messageBox(-title => "Reloader", -icon => "info", -message => "Modules were reloaded.", ); } else { $w->messageBox(-title => "Reloader", -icon => "error", -message => "To use this functionality you have to install Module::Refresh from CPAN", ); # So we have a chance to try it again... delete $INC{"Module/Refresh.pm"}; } }], ) : () ), ] ] ]; my $mbar = $w->Menu(-menuitems => $menuitems); $w->configure(-menu => $mbar); $w->Advertise(menubar => $mbar); $w->Delegates('Menubar' => $mbar); $w->ConfigSpecs( -tree => ['METHOD', 'tree', 'Tree', 0], -exitbutton => ['PASSIVE', 'exitButton', 'ExitButton', $exitbutton], -background => ['PASSIVE'], # XXX see comment in Tk::More -cursor => ['CHILDREN'], 'DEFAULT' => [$p], ); { my $path = $w->toplevel->PathName; # This is somewhat hackish: to make sure that the Tk::Pod bindings # win over the embedded Tk::More/Tk::Text bindings, the bindtags of # all child widgets are re-shuffled, so the Tk::Pod bindings come # first. Additionally, all the Tk::Pod bindings need additionally a # Tk->break call, so no other binding of embedded widgets is fired. $p->Walk(sub { my $w = shift; my @bindtags = $w->bindtags; if (grep { $_ eq $path } @bindtags) { $w->bindtags([$path, grep { $_ ne $path } @bindtags]); } }); foreach my $mod (qw(Alt Meta)) { $w->bind($path, "<$mod-Left>" => sub { $p->history_move(-1); Tk->break }); $w->bind($path, "<$mod-Right>" => sub { $p->history_move(+1); Tk->break }); } $w->bind($path, "" => sub { $w->zoom_out; Tk->break }); $w->bind($path, "" => sub { $w->zoom_in; Tk->break }); $w->bind($path, "" => sub { $w->openfile; Tk->break }); $w->bind($path, "" => sub { $w->openpod($p); Tk->break }); $w->bind($path, "" => sub { $w->newwindow($p); Tk->break }); $w->bind($path, "" => sub { $p->reload; Tk->break }); $w->bind($path, "" => sub { $p->Print; Tk->break }); $w->bind($path, "" => sub { $p->Print; Tk->break }); $w->bind($path, "" => sub { $p->view_source; Tk->break }); $w->bind($path, "" => sub { $w->quit; Tk->break }); $w->bind($path, "" => sub { $p->MainWindow->destroy; Tk->break }) if $exitbutton; } $w->protocol('WM_DELETE_WINDOW',['quit',$w]); } my $fsbox; sub openfile { my ($cw,$p) = @_; my $file; if ($cw->can("getOpenFile")) { $file = $cw->getOpenFile (-title => "Choose Pod file", -filetypes => [['Pod containing files', ['*.pod', '*.pl', '*.pm']], ['Pod files', '*.pod'], ['Perl scripts', '*.pl'], ['Perl modules', '*.pm'], ['All files', '*']]); } else { unless (defined $fsbox && $fsbox->IsWidget) { require Tk::FileSelect; $fsbox = $cw->FileSelect(); } $file = $fsbox->Show(); } $cw->configure(-file => $file) if defined $file && -r $file; } sub openpod { my($cw,$p) = @_; my $t = $cw->Toplevel(-title => "Open Pod by Name"); $t->transient($cw); $t->grab; my($pod, $e, $go); { my $Entry = 'Entry'; eval { require Tk::HistEntry; Tk::HistEntry->VERSION(0.40); $Entry = "HistEntry"; }; my $f = $t->Frame->pack(-fill => "x"); $f->Label(-text => "Pod:")->pack(-side => "left"); $e = $f->$Entry(-textvariable => \$pod)->pack(-side => "left", -fill => "x", -expand => 1); if ($e->can('history') && $openpod_history) { $e->history($openpod_history); } $e->focus; $go = 0; $e->bind("" => sub { $go = 1 }); $e->bind("" => sub { $go = -1 }); } { my $f = $t->Frame->pack; Tk::grid($f->Label(-text => "Use 'Module::Name' for module documentation"), -sticky => "w"); Tk::grid($f->Label(-text => "Use '-f function' for function documentation"), -sticky => "w"); Tk::grid($f->Label(-text => "Use '-q terms' for FAQ entries"), -sticky => "w"); } { my $f = $t->Frame->pack; $f->Button(-text => "OK", -command => sub { $go = 1 })->pack(-side => "left"); $f->Button(-text => "New window", -command => sub { $go = 2 })->pack(-side => "left"); $f->Button(-text => "Cancel", -command => sub { $go = -1 })->pack(-side => "left"); } $t->Popup(-popover => $cw); $t->OnDestroy(sub { $go = -1 unless $go }); $t->waitVariable(\$go); if (Tk::Exists($t)) { if (defined $pod && $pod ne "" && $go > 0 && $e->can('historyAdd')) { $e->historyAdd($pod); $openpod_history = [ $e->history ]; } $t->grabRelease; $t->destroy; } my %pod_args; if (defined $pod && $pod =~ /^(-[fq])\s+(.+)/) { my $switch = $1; my $func = $2; %pod_args = $cw->getpodargs($switch, $func); } else { %pod_args = $cw->getpodargs($pod); } if (defined $pod && $pod ne "") { if ($go == 1) { $cw->configure(%pod_args); } elsif ($go == 2) { my $new_cw = $cw->clone(%pod_args); } } } sub getpodargs { my($cw, @args) = @_; my @pod_args; if (@args == 1) { @pod_args = ('-file' => $args[0]); } elsif (@args == 2 && $args[0] =~ /^-([fq])$/) { my $switch = $1; my $func = $args[1]; my $func_pod = ""; open(FUNCPOD, "-|") or do { exec "perldoc", "-u", "-$switch", $func; warn "Can't execute perldoc: $!"; CORE::exit(1); }; local $/ = undef; $func_pod = join "", ; close FUNCPOD; if ($func_pod ne "") { push @pod_args, '-text' => $func_pod; if ($switch eq "f") { push @pod_args, '-title' => "Function $func"; } else { push @pod_args, '-title' => "FAQ $func"; } } } @pod_args; } sub newwindow { shift->clone; } sub Dir { require Tk::Pod::Text; require Tk::Pod::Tree; Tk::Pod::Text::Dir(@_); Tk::Pod::Tree::Dir(@_); } sub quit { shift->destroy } sub help { my $w = shift; $w->clone('-tree' => 0, '-file' => 'Tk::Pod_usage.pod', ); } sub help_programming { my $w = shift; $w->clone('-tree' => 0, '-file' => 'Tk/Pod.pm', ); } sub about { my $w = shift; require Tk::DialogBox; require Tk::ROText; my $d = $w->DialogBox(-title => "About Tk::Pod", -buttons => ["OK"], ); my $message = < in case of problems. Send the contents of this window for diagnostics. EOF my @lines = split /\n/, $message, -1; my $width = 0; for (@lines) { $width = length $_ if length $_ > $width; } my $txt = $d->add("Scrolled", "ROText", -height => scalar @lines, -width => $width + 1, -relief => "flat", -scrollbars => "oe", )->pack(-expand => 1, -fill => "both"); $txt->insert("end", $message); $d->Show; } sub add_section_menu { my($pod) = @_; my $screenheight = $pod->screenheight; my $mbar = $pod->Subwidget('menubar'); my $sectionmenu = $mbar->Subwidget('sectionmenu'); if (defined $sectionmenu) { $sectionmenu->delete(0, 'end'); } else { $mbar->insert($mbar->index("last"), "cascade", '-label' => 'Section', -underline => 1); $sectionmenu = $mbar->Menu; $mbar->entryconfigure($mbar->index("last")-1, -menu => $sectionmenu); $mbar->Advertise(sectionmenu => $sectionmenu); } my $podtext = $pod->Subwidget('pod'); my $text = $podtext->Subwidget('more')->Subwidget('text'); $text->tag('configure', '_section_mark', -background => 'red', -foreground => 'black', ); my $sdef; foreach $sdef (@{$podtext->{'sections'}}) { my($head_level, $subject, $pos) = @$sdef; my @args; if ($sectionmenu && $sectionmenu->yposition("last") > $screenheight-40) { push @args, -columnbreak => 1; } $sectionmenu->command (-label => (" " x ($head_level-1)) . $subject, -command => sub { my($line) = split(/\./, $pos); $text->tag('remove', '_section_mark', qw/0.0 end/); $text->tag('add', '_section_mark', $line-1 . ".0", $line-1 . ".0 lineend"); $text->yview("_section_mark.first"); $text->after(500, [$text, qw/tag remove _section_mark 0.0 end/]); }, @args, ); } } sub tree { my $w = shift; if (@_) { my $val = shift; $w->{Tree_on} = $val; my $tree = $w->Subwidget('tree'); my $p = $w->Subwidget("pod"); if ($val) { $p->packForget; $tree->packAdjust(-side => 'left', -fill => 'y'); $p->pack(-side => "left", -expand => 1, -fill => 'both'); if (!$tree->Filled) { $w->_configure_tree; $w->Busy(-recurse => 1); eval { $tree->Fill(-fillcb => sub { $tree->SeePath("file:" . $p->cget(-path)) if $p->cget(-path); }); }; my $err = $@; $w->Unbusy; if ($err) { die $err; } } } else { if ($tree && $tree->manager) { $tree->packForget; $p->packForget; eval { $w->Walk (sub { my $w = shift; if ($w->isa('Tk::Adjuster') && $w->cget(-widget) eq $tree) { $w->destroy; die; } }); }; $p->pack(-side => "left", -expand => 1, -fill => 'both'); } } } $w->{Tree_on}; } sub _configure_tree { my($w) = @_; my $tree = $w->Subwidget("tree"); my $p = $w->Subwidget("pod"); my $common_showcommand = sub { my($e) = @_; my $uri = $e->uri; my $type = $e->type; if (defined $type && $type eq 'func') { my $text = $Tk::Pod::Tree::FindPods->function_pod($e->name); (-text => $text, -title => $e->name); } elsif (defined $uri && $uri =~ /^file:(.*)/) { (-file => $1); } else { # ignore } }; $tree->configure (-showcommand => sub { my $e = $_[1]; my %args = $common_showcommand->($e); my $title = delete $args{-title}; $p->configure(-title => $title) if defined $title; $p->configure(%args); }, -showcommand2 => sub { my $e = $_[1]; my @args = $common_showcommand->($e); # XXX -title? $w->clone(-tree => !!$tree, @args); }, ); } sub SearchFAQ { my($cw, $p) = @_; my $t = $cw->Toplevel(-title => "Perl FAQ Search"); $t->transient($cw); $t->grab; my($keyword, $go, $e); { my $Entry = 'Entry'; eval { require Tk::HistEntry; Tk::HistEntry->VERSION(0.40); $Entry = "HistEntry"; }; my $f = $t->Frame->pack(-fill => "x"); $f->Label(-text => "FAQ keyword:")->pack(-side => "left"); $e = $f->$Entry(-textvariable => \$keyword)->pack(-side => "left"); if ($e->can('history') && $searchfaq_history) { $e->history($searchfaq_history); } $e->focus; $go = 0; $e->bind("" => sub { $go = 1 }); $e->bind("" => sub { $go = -1 }); } { my $f = $t->Frame->pack; $f->Button(-text => "OK", -command => sub { $go = 1 })->pack(-side => "left"); $f->Button(-text => "New window", -command => sub { $go = 2 })->pack(-side => "left"); $f->Button(-text => "Cancel", -command => sub { $go = -1 })->pack(-side => "left"); } $t->Popup(-popover => $cw); $t->OnDestroy(sub { $go = -1 unless $go }); $t->waitVariable(\$go); if (Tk::Exists($t)) { if (defined $keyword && $keyword ne "" && $go > 0 && $e->can('historyAdd')) { $e->historyAdd($keyword); $searchfaq_history = [ $e->history ]; } $t->grabRelease; $t->destroy; } if (defined $keyword && $keyword ne "") { if ($go) { require File::Temp; my($fh, $pod) = File::Temp::tempfile(UNLINK => 1, SUFFIX => "_tkpod.pod"); my $out = `perldoc -u -q $keyword`; # XXX protect keyword print $fh $out; close $fh; if (-z $pod) { $cw->messageBox(-title => "No FAQ keyword", -icon => "error", -message => "FAQ keyword not found", ); } else { if ($go == 1) { $cw->configure(-file => $pod); } elsif ($go == 2) { my $new_cw = $cw->clone('-file' => $pod); } } } } } sub zoom { my($w, $method) = @_; my $p = $w->Subwidget("pod"); $p->$method(); $w->set_base_font_size($p->base_font_size); } sub zoom_in { shift->zoom("zoom_in") } sub zoom_out { shift->zoom("zoom_out") } sub zoom_normal { shift->zoom("zoom_normal") } sub base_font_size { my $w = shift; $w->{Base_Font_Size}; } sub set_base_font_size { my($w, $font_size) = @_; $w->{Base_Font_Size} = $font_size; } sub clone { my($w, %pod_args) = @_; my %pre_args; for ('-tree', '-exitbutton') { if (exists $pod_args{$_}) { $pre_args{$_} = delete $pod_args{$_}; } else { $pre_args{$_} = $w->cget($_); } } my $new_w = $w->MainWindow->Pod (%pre_args, '-basefontsize' => $w->base_font_size, ); $new_w->configure(%pod_args) if %pod_args; $new_w; } 1; __END__ =head1 NAME Tk::Pod - Pod browser toplevel widget =head1 SYNOPSIS use Tk::Pod Tk::Pod->Dir(@dirs) # add dirs to search path for Pod $pod = $parent->Pod( -file = > $name, # search and display Pod for name -tree = > $bool # display pod file tree ); =head1 DESCRIPTION Simple Pod browser with hypertext capabilities in a C widget =head1 OPTIONS =over =item -tree Set tree view by default on or off. Default is false. =item -exitbutton Add to the menu an exit entry. This is only useful for standalone pod readers. Default is false. This option can only be set on construction time. =back Other options are propagated to the embedded L widget. =head1 BUGS If you set C<-file> while creating the Pod widget, $parent->Pod(-tree => 1, -file => $pod); then the title will not be displayed correctly. This is because the internal setting of C<-title> may override the title setting caused by C<-file>. So it is better to configure C<-file> separately: $pod = $parent->Pod(-tree => 1); $pod->configure(-file => $pod); =head1 SEE ALSO L, L, L, L, L, L. =head1 AUTHOR Nick Ing-Simmons > Current maintainer is Slaven Rezic >. Copyright (c) 1997-1998 Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-Pod-0.9943/More.pm000644 001750 001750 00000026171 12237202456 015012 0ustar00eserteeserte000000 000000 package Tk::More; use strict; use vars qw($VERSION @ISA); $VERSION = '5.09'; use Tk qw(Ev); use Tk::Derived; use Tk::Frame; @ISA = qw(Tk::Derived Tk::Frame); Construct Tk::Widget 'More'; sub Populate { my ($cw, $args) = @_; require Tk::ROText; require Tk::LabEntry; $cw->SUPER::Populate($args); my $Entry = 'LabEntry'; my @Entry_args; if (eval { die "Not yet"; require Tk::HistEntry; Tk::HistEntry->VERSION(0.37); 1; }) { $Entry = 'HistEntry'; } else { @Entry_args = (-labelPack=>[-side =>'left']); } my $search; my $e = $cw->$Entry( @Entry_args, -textvariable => \$search, -relief => 'flat', -state => 'disabled', )->pack(-side=>'bottom', -fill => 'x', -expand=>'no'); $cw->Advertise('searchentry' => $e); my $t = $cw->ROText(-cursor=>undef)->pack(-fill => 'both' , -expand => 'yes'); $cw->Advertise('text' => $t); $t->tagConfigure('search', -foreground => 'red'); # reorder bindings: private widget bindings first $t->bindtags([$t, grep { $_ ne $t->PathName } $t->bindtags]); $t->bind('', [$cw, 'Search', 'Next']); $t->bind('', [$cw, 'Search', 'Prev']); $t->bind('', [$cw, 'ShowMatch', 'Next']); $t->bind('', [$cw, 'ShowMatch', 'Prev']); $t->bind('', $t->bind(ref($t),'')); $t->bind('', $t->bind(ref($t),'')); $t->bind('', $t->bind('')); $t->bind('', $t->bind('')); $t->bind('', [$cw, 'scroll', $t, 1, 'line']); $t->bind('', [$cw, 'scroll', $t, 1, 'line']); $t->bind('', [$cw, 'scroll', $t, -1, 'line']); $t->bind('', [$cw, 'scroll', $t, -1, 'line']); $t->bind('', [$cw, 'scroll', $t, 1, 'page']); $t->bind('', [$cw, 'scroll', $t, 1, 'page']); $t->bind('', [$cw, 'scroll', $t, -1, 'page']); $t->bind('', [$cw, 'scroll', $t, -1, 'page']); $t->bind('', [sub { return if ($_[1] =~ /(Alt|Meta)-/); $t->xview('scroll', 1, 'units'); Tk->break; }, Ev('s')]); $t->bind('', [sub { return if ($_[1] =~ /(Alt|Meta)-/); $t->xview('scroll', -1, 'units'); Tk->break; }, Ev('s')]); $t->bind('', ['yview', 'scroll', 1, 'units']); $t->bind('', [$cw, 'scroll', $t, 1, 'halfpage']); $t->bind('', [$cw, 'scroll', $t, -1, 'halfpage']); $t->bind('', sub { $cw->Callback(-helpcommand => $t) }); $e->bind('',[$cw, 'SearchText']); $e->bind('',[$cw, 'SearchTextEscape']); foreach my $mod (qw(Alt Meta)) { foreach my $key (qw(n N g G j k f b d u h)) { $t->bind("<$mod-Key-$key>" => \&Tk::NoOp); } } # This was formerly possible, but is now invalid: delete $args->{-font} if !defined $args->{-font}; $cw->Delegates('DEFAULT' => $t, 'Search' => 'SELF', 'ShowMatch' => 'SELF', 'Load' => 'SELF', 'LoadFH' => 'SELF', 'AddQuitBindings' => 'SELF', ); $cw->{DIRECTION} = "Next"; $cw->ConfigSpecs( -insertofftime => [$t, qw(insertOffTime OffTime 0)], # no blinking -insertwidth => [$t, qw(insertWidth InsertWidth 0)], # invisible -padx => [$t, qw(padX Pad 5p)], -pady => [$t, qw(padY Pad 5p)], -searchcase => ['PASSIVE', 'searchCase', 'SearchCase', 1], -helpcommand => ['CALLBACK', undef, undef, undef], -background => ['PASSIVE'],# XXX ignore -background, so optionAdd works.... still decide -font => [$t, 'fixedFont', 'FixedFont', 'Courier 10'], 'DEFAULT' => [$t] ); $cw; } sub Search { my ($cw, $direction) = @_; $cw->{DIRECTION} = $direction; my $e = $cw->Subwidget('searchentry'); $e->configure(-label => 'Search ' . ($direction eq 'Next'?'forward:':'backward:') ); $e->configure(-relief=>'sunken',-state=>'normal'); $e->selectionRange(0, "end"); $e->focus; } sub SearchText { my ($cw, %args) = @_; my($t, $e) = ($cw->Subwidget('text'), $cw->Subwidget('searchentry')); $cw->{DIRECTION} = $args{-direction} if $args{-direction}; my $searchterm; if (defined $args{-searchterm}) { $searchterm = $args{-searchterm}; $ {$e->cget('-textvariable')} = $searchterm; } else { $e->historyAdd if ($e->can('historyAdd')); $searchterm = $e->get; } unless ($cw->search_text($t, $searchterm, 'search') ) { $cw->bell unless $args{-quiet}; } $e->configure(-label=>''); $t->see('@0,0'); $cw->ShowMatch($cw->{DIRECTION}, -firsttime => 1) unless $args{-onlymatch}; $t->focus; $e->configure(-relief=>'flat', -state=>'disabled'); } sub SearchTextEscape { my ($cw, %args) = @_; my($t, $e) = ($cw->Subwidget('text'), $cw->Subwidget('searchentry')); $e->configure(-label=>''); $t->focus; $e->configure(-relief=>'flat', -state=>'disabled'); } sub ShowMatch { my ($cw, $method, %args) = @_; my $firsttime = $args{-firsttime}; my $t = $cw->Subwidget('text'); if ($cw->{DIRECTION} ne 'Next') { $method = 'Next' if $method eq 'Prev'; $method = 'Prev' if $method eq 'Next'; } my $cur = (($method eq 'Prev' && !$firsttime) || ($method eq 'Next' && $firsttime) ? $t->index('@0,0') : $t->index('@0,'.$t->height)); $method = "tag". $method . "range"; # $method: Next or Prev my @ins = $t->$method('search',$cur); unless (@ins) { # hack: Maybe the search was not performed yet? (e.g. after loading # a new page but with the same search term) my $e = $cw->Subwidget('searchentry'); if (!defined $ {$e->cget('-textvariable')}) { return; } $cw->SearchText(-searchterm => $ {$e->cget('-textvariable')}, -onlymatch => 1); @ins = $t->$method('search',$cur); return if !@ins; } @ins = reverse @ins unless $method eq 'tagNextrange'; $t->see($ins[0]); $ins[0]; } # Load copied from TextUndo (xxx yy marks changes) sub Load { my ($text,$file,%args) = @_; if (open(FILE,"<$file")) { $text->LoadFH(\*FILE,%args); close(FILE); } else { $text->messageBox(-message => "Cannot open $file: $!\n"); die; } } sub LoadFH { my ($text,$fh,%args) = @_; my $encoding = delete $args{-encoding}; die "Unhandled arguments: " . join(" ", %args) if %args; if ($encoding) { binmode $fh, ":encoding($encoding)"; } $text->MainWindow->Busy; $text->delete('1.0','end'); #yy delete $text->{UNDO}; while (<$fh>) { $text->insert('end',$_); } #yy $text->{FILE} = $file; $text->markSet('insert', '@1,0'); $text->MainWindow->Unbusy; } # search_text copied from demo search.pl (modified) sub search_text { # The utility procedure below searches for all instances of a given # string in a text widget and applies a given tag to each instance found. # Arguments: # # w - The window in which to search. Must be a text widget. # string - string to search for. The search is done # using exact matching only; no special characters. # tag - Tag to apply to each instance of a matching string. my($w, $t, $string, $tag) = @_; return unless length($string); $w->tag('remove', $tag, qw/0.0 end/); my($current, $length, $found) = ('1.0', 0, 0); my $insert = $w->index('insert'); my @search_args = ('-regexp'); push @search_args, '-nocase' unless ($w->cget('-searchcase')); eval { while (1) { $current = $w->search(@search_args, -count => \$length, '--', $string, $current, 'end'); last if not $current; $found = 1; $w->tag('add', $tag, $current, "$current + $length char"); $current = $w->index("$current + $length char"); } $w->markSet('insert', $insert); }; if ($@) { $w->messageBox(-icon => "error", -message => $@, ); } $found; } # end search_text sub scroll { my($w,$t,$no,$unit) = @_; if ($unit =~ /^line/) { $t->yview('scroll', $no, 'units'); } else { my($y1,$y2) = $t->yview; my $amount; if ($unit =~ /^halfpage/) { $amount = ($y2-$y1)/2; } elsif ($unit =~ /^page/) { # if ($no == -1) { # # loop until top-most line is invisible # my $inx = $t->index('@0,0'); # my $i=0; # while ($t->bbox($inx)) { # $t->yviewScroll(-1,'units'); # last if ($i++>1000); # } # goto XXX; # } $amount = ($y2-$y1); } else { die "Unknown unit $unit"; } #warn "$y1 $y2 $amount"; $y1 += ($no * $amount); if ($no > 0) { $y1 = 1.0 if ($y1 > 1.0); } else { $y1 = 0.0 if ($y1 < 0.0); } $t->yviewMoveto($y1); } #XXX: Tk->break; } sub AddQuitBindings { my($more) = @_; $more->bind("" => sub { $more->toplevel->destroy }); $more->bind("" => sub { $more->toplevel->destroy }); } #package Tk::More::Status; # ## Implement status bar # 1; __END__ =head1 NAME Tk::More - a 'more' or 'less' like text widget =head1 SYNOPSIS use Tk::More; $more = $parent->More(...text widget options ...); $more->Load(FILENAME); =head1 DESCRIPTION B is a readonly text widget with additional key bindings as found in UNI* command line tools C or C. As in C an additional status/command line is added at the bottom. =head1 ADDITIONAL BINDINGS =over 4 =item Key-g or Home goto beginning of file =item Key-G or End goto end of file =item Key-f or Next forward screen =item Key-b or Prior backward screen =item Key-k or Up up one line =item Key-j or Down down one line =item Key-/ search forward =item Key-? search backward =item Key-n find next match =item Key-N find previous match =item Key-u up half screen =item Key-d down half screen =item Key-Return down one line =item Key-h invoke help window =back =head1 OPTIONS =over =item Name: B =item Class: B =item Switch: B<-font> Set the font of the viewer widget. This is by default a fixed font. =item Name: B =item Class: B =item Switch: B<-searchcase> Set if searching should be done case-insensitive. Defaults to true. =item Switch: B<-helpcommand> Sets the command for the "h" (help) key. =back =head1 METHODS =over =item Load($file, %args) Load I<$file> into the widget. I<%args> may be one of the following =over =item -encoding => I<$encoding> Assume the encoding of the file to be I<$encoding>. If none is given, then assume no encoding (which is equivalent to iso-8859-1). =back =item AddQuitBindings Convenience method to add the bindinds Key-q and Control-Key-q to close the Toplevel window containing this More widget. =back =head1 BUGS Besides that most of more bindings are not implemented. This bugs me most (high to low priority): * better status line implementation * Cursor movement: up/down move displayed area regardless where insert cursor is * add History, Load, Search (also as popup menu) =head1 SEE ALSO L, L, L, L =head1 AUTHOR Achim Bohnet > Currently maintained by Slaven Rezic >. Copyright (c) 1997-1998 Achim Bohnet. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-Pod-0.9943/Makefile.PL000644 001750 001750 00000012340 12653407404 015517 0ustar00eserteeserte000000 000000 # -*- perl -*- use ExtUtils::MakeMaker; $DIST_VERSION = "0.9943"; $is_devel_host = defined $ENV{USER} && $ENV{USER} eq 'eserte' && $^O =~ /bsd/i && -f "../../perl.release.mk"; $min_eumm_version = 6.54; $eumm_recent_enough = $ExtUtils::MakeMaker::VERSION >= $min_eumm_version; if (!$eumm_recent_enough) { *MY::dist_core = sub { <) { if (/DIST_VERSION\s*=\s*["'](.*)["']/) { if ($DIST_VERSION ne $1) { die "Please adjust DIST_VERSION in Makefile.PL ($DIST_VERSION vs $1)"; } last SEARCH_FOR_DIST_VERSION; } } die "Cannot find DIST_VERSION definition in Pod.pm"; } } my %add_prereq_pm; if (eval { require Tk::Tree; 1 } && $Tk::Tree::VERSION eq '4.6') { warn < * are expected and may be ignored. ********************************************************************** EOF } WriteMakefile( 'PREREQ_PM' => { 'Tk' => 800.004, 'Pod::Simple' => 2.05, # there at least in 2.03 bugs when processing "-f ..." output 'File::Temp' => 0, 'File::Spec' => 0, ## the following are only corequisites, see optional_features #'Text::English' => 0, #'Tk::HistEntry' => 0.40, ## very very optional corequisites, see optional_features # 'Tk::WidgetDump' => 0, # 'Module::Refresh' => 0, %add_prereq_pm, }, 'DISTNAME' => 'Tk-Pod', 'NAME' => 'Tk::Pod', 'VERSION' => $DIST_VERSION, 'LICENSE' => 'perl', 'DIR' => [], # Tk-Pod dist build dir is ignored 'EXE_FILES' => [ 'tkpod', 'tkmore' ], 'dist' => {'POSTOP'=>'-$(CHMOD) 644 $(DISTVNAME).tar$(SUFFIX)'}, ($eumm_recent_enough ? (ABSTRACT => 'Pod browser widget for Tk', AUTHOR => 'Slaven Rezic ', META_MERGE => { resources => { repository => 'git://github.com/eserte/tk-pod.git' }, optional_features => { fulltext_search => { description => "Enable the full-text search", requires => { 'Text::English' => 0, }, }, nicer_gui => { description => "Provide a nicer GUI", requires => { 'Tk::HistEntry' => '0.4', 'Tk::ToolBar' => 0, }, }, debugging => { description => "Debugging and development helper", requires => { 'Tk::WidgetDump' => 0, 'Module::Refresh' => 0, 'Devel::Hide' => 0, }, }, gzip_support => { description => "gzip support in tkmore", requires => { 'PerlIO::gzip' => 0, }, }, external_links => { description => "support for links using an external browser", requires => { 'URI::Escape' => 0, }, }, }, }) : ()), ); # This rule ensures that we get UNKNOWN test results on Unix platforms # if no X11 DISPLAY is available. This does not apply for cygwin/X11; # the display test there is done in the test files using # TkTest::display_test sub MY::test_via_harness { my($self, $perl, $tests) = @_; qq{\t$perl "-It" "-MTkTest" }. qq{"-e" "check_display_test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}; } sub MY::postamble { my $postamble = <<'EOF'; demo :: pure_all $(FULLPERL) -w -Mblib $(INST_SCRIPT)$(DFSEP)tkpod -tree -nodebug EOF if ($is_devel_host) { $postamble .= <<'EOF'; # Test::Distribution complains about Text::English (which is optional) # and a number of Tk::* widgets which are part of Tk # # "use" fails if Text::English is not installed which is needed # by Tk::Pod::Search_db (which is only optionally used) # # "version" automatically turns "use" on, so has to be turned off, too. PERL_TEST_DISTRIBUTION_OPTS=not podcover,prereq,use,versions .include "../../perl.release.mk" .include "../../perl.git.mk" update-WWWBrowser: perl -nle '\ BEGIN { print "# DO NOT EDIT\n# Created by the update-WWWBrowser makefile rule\n\n# DO NOT USE THIS MODULE IN YOUR PROJECTS\n# (That is, the module\047s code is OK, but don\047t rely on the package\n# name or the API of this module)" } \ s{package WWWBrowser}{package # hide from PAUSE indexer\n\tTk::Pod::WWWBrowser}; \ s{package Launcher::WWW}{package # hide from PAUSE indexer\n\tTk::Pod::Launcher::WWW}; \ if (m{#.*Forward compatibility}) { \ $$skip_forward_compat++; \ } elsif ($$skip_forward_compat && m|^}|) { \ $$skip_forward_compat = 0; next; \ } \ if (m{__END__}) { \ $$do_not_print++; \ } \ print if (!$$do_not_print && !$$skip_forward_compat); \ ' \ < ../../perl/WWWBrowser/WWWBrowser.pm > Pod/WWWBrowser.pm~ perl -c Pod/WWWBrowser.pm~ mv Pod/WWWBrowser.pm~ Pod/WWWBrowser.pm EOF } $postamble; } Tk-Pod-0.9943/README000644 001750 001750 00000002551 11777613536 014443 0ustar00eserteeserte000000 000000 Tk::Pod This is a graphical user interface for viewing and browsing perl's Pod documentation. To install, type cpan . if you have a modern CPAN.pm, otherwise perl Makefile.PL (resolve all dependencies) make make test make demo (optional) make install Windows users should replace "make" with "nmake" if using ActivePerl or "dmake" if using Vanilla or Strawberry Perl. At least perl 5.005 and Tk 800.004 are required. Features include: o A standalone Tk pod viewer: tkpod o Interface to perlindex full text Pod search (you need to install the perlindex distribution aka Text::English from CPAN and create an index using "perlindex -index"). o Supports single or multiple Pod windows. o more/less-like Tk::More widget with '/', 'n', 'N', 'j', 'k' bindings o Tree view of available Pods o links to URLs and man pages are also handled o printing using postscript, RTF or text output If Tk::ToolBar is installed, then tkpod may use the Tk::ToolBar icons for the menus. This works both in Tk804 with native compounds and in Tk800 using Tk::Compound. The original Tk::Pod module was written by Nick Ing-Simmons . Former maintainer was Achim Bohnet. Current maintainer is Slaven Rezic . Pod::Simple support is by Sean Burke. Please send bug reports, patches and comments to the current maintainer. __END__ Tk-Pod-0.9943/META.yml000644 001750 001750 00000002240 12653407627 015023 0ustar00eserteeserte000000 000000 --- abstract: 'Pod browser widget for Tk' author: - 'Slaven Rezic ' build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Tk-Pod no_index: directory: - t - inc optional_features: debugging: description: 'Debugging and development helper' requires: Devel::Hide: 0 Module::Refresh: 0 Tk::WidgetDump: 0 external_links: description: 'support for links using an external browser' requires: URI::Escape: 0 fulltext_search: description: 'Enable the full-text search' requires: Text::English: 0 gzip_support: description: 'gzip support in tkmore' requires: PerlIO::gzip: 0 nicer_gui: description: 'Provide a nicer GUI' requires: Tk::HistEntry: 0.4 Tk::ToolBar: 0 requires: File::Spec: 0 File::Temp: 0 Pod::Simple: 2.05 Tk: 800.004 resources: repository: git://github.com/eserte/tk-pod.git version: 0.9943 Tk-Pod-0.9943/META.json000644 001750 001750 00000004674 12653407630 015202 0ustar00eserteeserte000000 000000 { "abstract" : "Pod browser widget for Tk", "author" : [ "Slaven Rezic " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Tk-Pod", "no_index" : { "directory" : [ "t", "inc" ] }, "optional_features" : { "debugging" : { "description" : "Debugging and development helper", "prereqs" : { "runtime" : { "requires" : { "Devel::Hide" : "0", "Module::Refresh" : "0", "Tk::WidgetDump" : "0" } } } }, "external_links" : { "description" : "support for links using an external browser", "prereqs" : { "runtime" : { "requires" : { "URI::Escape" : "0" } } } }, "fulltext_search" : { "description" : "Enable the full-text search", "prereqs" : { "runtime" : { "requires" : { "Text::English" : "0" } } } }, "gzip_support" : { "description" : "gzip support in tkmore", "prereqs" : { "runtime" : { "requires" : { "PerlIO::gzip" : "0" } } } }, "nicer_gui" : { "description" : "Provide a nicer GUI", "prereqs" : { "runtime" : { "requires" : { "Tk::HistEntry" : "0.4", "Tk::ToolBar" : "0" } } } } }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "File::Spec" : "0", "File::Temp" : "0", "Pod::Simple" : "2.05", "Tk" : "800.004" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "git://github.com/eserte/tk-pod.git" } }, "version" : "0.9943" } Tk-Pod-0.9943/t/subclass.t000755 001750 001750 00000003230 12463165673 016025 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # # Subclassing test --- use Tk::ROText instead of Tk::More # as the pager in the PodText widget use strict; use Tk; use Tk::Pod; BEGIN { if (!eval q{ use Test::More; 1; }) { print "1..0 # skip tests only work with installed Test::More module\n"; CORE::exit(0); } if ($] < 5.006) { print "1..0 # skip subclassing does not work with perl 5.005 and lesser\n"; CORE::exit(0); } } my $mw = eval { MainWindow->new }; if (!$mw) { print "1..0 # cannot create MainWindow\n"; CORE::exit(0); } $mw->geometry("+1+1"); # for twm plan tests => 1; { package Tk::MyMore; use base qw(Tk::Derived Tk::ROText); Construct Tk::Widget "MyMore"; sub Populate { my($w, $args) = @_; $w->SUPER::Populate($args); $w->Advertise(text => $w); # XXX hmmmm.... $w->ConfigSpecs(-searchcase => ['PASSIVE'], -helpcommand => ['PASSIVE'], ); } } { package Tk::MyPodText; use base qw(Tk::Pod::Text); Construct Tk::Widget "MyPodText"; sub More_Module { } sub More_Widget { "MyMore" } } { package Tk::MyPod; use base qw(Tk::Pod); Construct Tk::Widget "MyPod"; sub Pod_Text_Module { } sub Pod_Text_Widget { "MyPodText" } } $mw->withdraw; my $pod = $mw->MyPod; $pod->geometry('+1+1'); # for twm SKIP: { my $podfile = 'perl.pod'; my $podpath = Tk::Pod::Text::Find($podfile); skip "Pod for $podfile not installed", 1 if !defined $podpath; $pod->configure(-file => $podfile); $mw->update; pass 'Displayed derived MyPod widget'; } if (!$ENV{PERL_INTERACTIVE_TEST}) { $mw->after(1*1000, sub { $mw->destroy }); } MainLoop; Tk-Pod-0.9943/t/testdata/000755 001750 001750 00000000000 12653407627 015630 5ustar00eserteeserte000000 000000 Tk-Pod-0.9943/t/basic.t000644 001750 001750 00000006262 12237202456 015262 0ustar00eserteeserte000000 000000 BEGIN { $| = 1; $^W = 1; eval { require Test; }; if ($@) { $^W=0; print "1..0 # skip no Test module\n"; CORE::exit(0); } Test->import; } use strict; use Tk; ## ## Test all widget classes: load module, create, pack, and ## destory an instance. Check in configure does not return ## an error so (some) ConfigSpecs errors are uncovered ## use vars '@class'; use vars '@tk_pod_modules'; my $tests; BEGIN { @class = qw( More PodText PodSearch PodTree Pod ); @tk_pod_modules = qw(Cache FindPods Search_db Search SimpleBridge Styles Util WWWBrowser); $tests = 10*@class+@tk_pod_modules; plan test => $tests; }; $ENV{TKPODDEBUG} = 0; if (!defined $ENV{BATCH}) { $ENV{BATCH} = 1; } my $mw; eval {$mw = Tk::MainWindow->new();}; if (!Tk::Exists($mw)) { for (1..$tests) { skip("Cannot create MainWindow", 1, 1); } CORE::exit(0); } $mw->geometry("+1+1"); # for twm my $w; foreach my $class (@class) { print "# Testing $class\n"; undef($w); if ($class =~ m{^Pod(Text|Search|Tree)$}) { my $module = "Tk::Pod::$1"; # Tks autoload does not find it. eval qq{ require $module; }; ok($@, "", "loading $module module"); } else { eval "require Tk::$class;"; ok($@, "", "Error loading Tk::$class"); } eval { $w = $mw->$class(); }; ok($@, "", "can't create $class widget"); skip($@, Tk::Exists($w), 1, "$class instance does not exist"); if (Tk::Exists($w)) { if ($w->isa('Tk::Wm')) { # KDE-beta4 wm with policies: # 'interactive placement' # okay with geometry and positionfrom # 'manual placement' # geometry and positionfrom do not help eval { $w->positionfrom('user'); }; #eval { $w->geometry('+10+10'); }; ok ($@, "", 'Problem set postitionform to user'); eval { $w->Popup; }; ok ($@, "", "Can't Popup a $class widget") } else { ok(1); # dummy for above positionfrom test eval { $w->pack; }; ok ($@, "", "Can't pack a $class widget") } eval { $mw->update; }; ok ($@, "", "Error during 'update' for $class widget"); if (!$ENV{BATCH}) { $mw->messageBox(-icon => "info", -message => "Showing '$class'", -type => "Continue"); } eval { my @dummy = $w->configure; }; ok ($@, "", "Error: configure list for $class"); eval { $mw->update; }; ok ($@, "", "Error: 'update' after configure for $class widget"); eval { $w->destroy; }; ok($@, "", "can't destroy $class widget"); ok(!Tk::Exists($w), 1, "$class: widget not really destroyed"); } else { # Widget $class couldn't be created: # Popup/pack, update, destroy skipped for (1..5) { skip (1,1,1, "skipped because widget could not be created"); } } } print "# Require all modules\n"; for my $base (@tk_pod_modules) { eval "require Tk::Pod::$base"; if ($@ && $base eq 'Search_db') { ok($@ =~ m{locate Text.*English}, 1, "Could not require Tk::Pod::$base: $@"); } else { ok($@, "", "Could not require Tk::Pod::$base: $@"); } } 1; __END__ Tk-Pod-0.9943/t/podtree.t000755 001750 001750 00000002343 12653225531 015643 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # use strict; use Tk; use Tk::Pod::Tree; use Tk::Pod::FindPods; BEGIN { if (!eval q{ use Test::More; 1; }) { print "# tests only work with installed Test::More module\n"; print "1..1\n"; print "ok 1\n"; CORE::exit(0); } } my $mw = eval { tkinit }; if (!$mw) { print "1..0 # cannot create MainWindow\n"; CORE::exit(0); } $mw->geometry("+1+1"); # for twm plan tests => 5; my $pt; $pt = $mw->Scrolled("PodTree", -scrollbars => "osow", -showcommand => sub { warn $_[1]->{File}; }, )->grid(-sticky => "esnw"); $mw->gridColumnconfigure(0, -weight => 1); $mw->gridRowconfigure(0, -weight => 1); diag <Fill; pass 'after calling Fill method'; my $FindPods = Tk::Pod::FindPods->new; isa_ok $FindPods, 'Tk::Pod::FindPods'; my $pods = $FindPods->pod_find(-categorized => 1, -usecache => 1); isa_ok $pods, 'HASH'; my $path = $pods->{perl}{ (keys %{ $pods->{perl} })[0] }; $pt->SeePath($path); pass 'after calling SeePath method'; $mw->afterIdle(sub{$mw->destroy}); MainLoop; __END__ Tk-Pod-0.9943/t/more.t000755 001750 001750 00000002313 12237202456 015137 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # use strict; use Tk; use Tk::More; BEGIN { if (!eval q{ use Test::More; 1; }) { print "1..0 # skip tests only work with installed Test::More module\n"; CORE::exit(0); } } my $mw = eval { tkinit }; if (!$mw) { print "1..0 # cannot create MainWindow\n"; CORE::exit(0); } $mw->geometry("+1+1"); # for twm plan tests => 4; { my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; my $more = $mw->Scrolled("More", -font => "Courier 10", -scrollbars => "osoe", )->pack(-fill => "both", -expand => 1); $more->focus; $more->Load($INC{"Tk/More.pm"}); $more->update; ok(Tk::Exists($more)); ok(!@warnings, "No warnings while loading") or diag($warnings[0] . "..."); } { my @warnings; local $SIG{__WARN__} = sub { push @warnings, @_ }; my $more = $mw->More (# -font: use default -width => 20, -height => 3, )->pack; $more->Load($0); $more->update; ok(Tk::Exists($more)); ok(!@warnings, "No warnings while loading") or diag($warnings[0] . "..."); } if (!$ENV{PERL_INTERACTIVE_TEST}) { $mw->after(1*1000, sub { $mw->destroy }); } MainLoop; Tk-Pod-0.9943/t/pods.t000755 001750 001750 00000001520 12463165673 015153 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # use strict; use Tk; use Tk::Pod::Text; BEGIN { if (!eval q{ use Test::More; 1; }) { print "1..0 # skip no Test::More module\n"; CORE::exit(0); } } use Tk; my $mw = eval { MainWindow->new }; if (!$mw) { print "1..0 # cannot create MainWindow\n"; CORE::exit(0); } $mw->geometry("+1+1"); # for twm plan tests => 4; my $pt = $mw->PodText->pack; for my $pod ('perl', # pod in perl.pod 'perldoc', # pod in script itself 'strict', # sample pragma pod 'File::Find', # sample module pod ) { my $podpath = Tk::Pod::Text::Find($pod); SKIP: { skip "Pod for $pod not installed", 1 if !defined $podpath; $pt->configure(-file => $pod); is $pt->cget(-file), $pod, "Render $pod Pod in PodText"; } } #MainLoop; __END__ Tk-Pod-0.9943/t/cmdline.t000755 001750 001750 00000014255 12472435051 015620 0ustar00eserteeserte000000 000000 #!/usr/bin/perl -w # -*- perl -*- # # Author: Slaven Rezic # use strict; use Cwd qw(getcwd); use FindBin; use File::Basename qw(basename); use File::Spec; use Getopt::Long; use lib $FindBin::RealBin; use TkTest qw(display_test); BEGIN { display_test(); } BEGIN { if (!eval q{ use Test::More; use POSIX ":sys_wait_h"; use File::Temp qw(tempfile tempdir); 1; }) { print "1..0 # skip no Test::More and/or POSIX module\n"; CORE::exit(0); } if ($^O eq 'MSWin32') { print "1..0 # skip not on Windows\n"; # XXX but why? CORE::exit(0); } } my $DEBUG = 0; my $blib = File::Spec->rel2abs("$FindBin::RealBin/../blib"); my $script = "$blib/script/tkpod"; my $tkmore_script = "$blib/script/tkmore"; my $batch_mode = defined $ENV{BATCH} ? $ENV{BATCH} : 1; my $cwd = getcwd; # http://rt.cpan.org/Ticket/Display.html?id=41320 (have to chdir out # of temp directory before File::Temp cleans directories) END { chdir $cwd if defined $cwd } GetOptions("d|debug" => \$DEBUG, "batch!" => \$batch_mode) or die "usage: $0 [-debug] [-nobatch]"; # Create test directories/files: my $testdir = tempdir("tkpod_XXXXXXXX", TMPDIR => 1, CLEANUP => 1); die "Can't create temporary directory: $!" if !$testdir; my $cpandir = "$testdir/CPAN"; mkdir $cpandir, 0777 or die "Cannot create temporary directory: $!"; my $cpanfile = "$testdir/CPAN.pm"; { open FH, "> $cpanfile" or die "Cannot create $cpanfile: $!"; print FH "=pod\n\nTest\n\n=cut\n"; close FH or die "While closing: $!"; } my $obscurepod = "ThisFileReallyShouldNotExistInAPerlDistroXYZfooBAR"; my $obscurefile = "$testdir/$obscurepod.pod"; { open FH, "> $obscurefile" or die "Cannot create $obscurefile: $!"; print FH "=pod\n\nThis is: $obscurepod\n\n=cut\n"; close FH or die "While closing: $!"; } # Does this perl has documentation installed at all? my $perl_has_doc = sub { for (@INC) { return 1 if -r "$_/pod/perl.pod"; } 0; }->(); my @opt = ( # note: "-exit" should be the first option if used ['-tk'], # one call without -exit ['-thisIsAnInvalidOption', '__EXPECT_ERROR__'], ['-exit', 'ThIsMoDuLeDoEsNotExIsT', '__EXPECT_ERROR__'], ['-exit', '-tk'], ['-tree','-geometry','+0+0'], # no -exit here --- -tree may take long time, exceeding the default timeout of one minute ($perl_has_doc ? ['-exit'] : ()), # a call with implicite perl.pod ['-exit', $script], # the pod of tkpod itself ['-exit', '-notree', $script], ['-exit', '-Mblib', $script], ['-exit', '-d', $script], ['-exit', '-server', $script], ['-exit', '-xrm', '*font: {nimbus sans l} 24', '-xrm', '*serifFont: {nimbus roman no9 l}', '-xrm', '*sansSerifFont: {nimbus sans l}', '-xrm', '*monospaceFont: {nimbus mono l}', $script, ], # Environment settings ['-exit', '-tree', '__ENV__', TKPODCACHE => "$testdir/pods_%v_%o_%u"], ['-exit', $script, '__ENV__', TKPODDEBUG => 1], ['-exit', $script, '__ENV__', TKPODEDITOR => 'ptked'], ['-exit', $obscurepod.".pod", '__ENV__', TKPODDIRS => $testdir], # tkmore ['__SCRIPT__', $tkmore_script, $0], ['__SCRIPT__', $tkmore_script, "-xrm", "*fixedFont:{monospace 10}", $0], ['__SCRIPT__', $tkmore_script, "-font", "monospace 10", $0], ['__SCRIPT__', $tkmore_script, "$FindBin::RealBin/testdata/latin1.txt"], ['__SCRIPT__', $tkmore_script, -encoding => "utf-8", "$FindBin::RealBin/testdata/utf8.txt"], ['__SCRIPT__', $tkmore_script, -encoding => "utf-8", "$FindBin::RealBin/testdata/utf8.txt.gz"], # This should be near end... ['__ACTION__', chdir => $testdir ], ['-exit', "CPAN"], # Cleanup (jump out of $testdir, so File::Temp cleanup does not fail) ['__ACTION__', chdir => $FindBin::RealBin ], ); plan tests => scalar @opt; OPT: for my $opt (@opt) { if ($opt->[0] eq '__ACTION__') { my $action = $opt->[1]; if ($action eq 'chdir') { chdir $opt->[2] or die $!; } else { die "Unknown action $action"; } pass "Just setting an action..."; next; } my $do_exit = $opt->[0] eq '-exit'; local %ENV = %ENV; delete $ENV{$_} for qw(TKPODCACHE TKPODDEBUG TKPODDIRS TKPODEDITOR); my $this_script = $script; my @this_opts; my @this_env; my $expect_error; for(my $i = 0; $i<=$#$opt; $i++) { if ($opt->[$i] eq '__ENV__') { $ENV{$opt->[$i+1]} = $opt->[$i+2]; push @this_env, $opt->[$i+1]."=".$opt->[$i+2]; $i+=2; } elsif ($opt->[$i] eq '__SCRIPT__') { $this_script = $opt->[$i+1]; $i+=1; } elsif ($opt->[$i] eq '__EXPECT_ERROR__') { $expect_error = 1; } else { push @this_opts, $opt->[$i]; } } my $testname = 'Trying ' . basename($this_script) . " with @this_opts" . (@this_env ? ', environment ' . join(', ', @this_env) : '') . ($expect_error ? ', expect error' : '') ; if ($batch_mode) { my $pid = fork; if ($pid == 0) { run_tkpod($this_script, \@this_opts); } if ($do_exit) { # wait much longer (a minute), but expect a clean exit for (1..1000) { select(undef,undef,undef,0.06); my $kid = waitpid($pid, WNOHANG); if ($kid) { if ($expect_error) { isnt($?, 0, $testname); } else { is($?, 0, $testname); } next OPT; } } kill KILL => $pid; fail("$testname seems to hang"); } else { for (1..10) { select(undef,undef,undef,0.05); my $kid = waitpid($pid, WNOHANG); if ($kid) { if ($expect_error) { isnt($?, 0, $testname); } else { is($?, 0, $testname); } next OPT; } } kill TERM => $pid; for (1..10) { select(undef,undef,undef,0.05); if (!kill 0 => $pid) { pass($testname); next OPT; } } kill KILL => $pid; pass($testname); } } else { run_tkpod($this_script, \@this_opts); pass($testname); } } sub run_tkpod { my($script, $this_opts_ref) = @_; my @cmd = ($^X, "-Mblib=$blib", $script, "-geometry", "+10+10", @$this_opts_ref); warn "@cmd\n" if $DEBUG; if ($batch_mode) { open(STDERR, ">" . File::Spec->devnull) unless $DEBUG; exec @cmd; die $!; } else { system @cmd; if ($? == 2) { die "Aborted by user...\n"; } if ($? != 0) { warn "<@cmd> failed with status code <$?>"; } } } __END__ Tk-Pod-0.9943/t/TkTest.pm000644 001750 001750 00000003603 11777613536 015601 0ustar00eserteeserte000000 000000 # Copyright (C) 2003,2006,2007 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # Parts taken from TkTest.pm from Perl/Tk package TkTest; use strict; use vars qw(@EXPORT); use base qw(Exporter); @EXPORT = qw(check_display_test_harness display_test); use ExtUtils::Command::MM qw(test_harness); sub check_display_test_harness { my(@test_harness_args) = @_; # In case of cygwin, use'ing Tk before forking (which is done by # Test::Harness) may lead to "remap" errors, which are normally # solved by the rebase or rebaseall utilities. # # Here, I just skip the DISPLAY check on cygwin to not force users # to run rebase. # if (!($^O eq 'cygwin' || $^O eq 'MSWin32')) { eval q{ use blib; use Tk; }; die "Strange: could not load Tk library: $@" if $@; # empty the argument list for the following test_harness @ARGV = () if !_can_MainWindow(); } test_harness(@test_harness_args); } # Avoid this function. Tk 804.xxx may die if multiple MainWindows are # created within one process (seen e.g. on FreeBSD systems). By using # this function a test MainWindow will be created, so the next "real" # $mw creation may fail. # # display_test() is only safe if subsequent creation of MainWindows is # done in separate processes (i.e. if using system(...)) sub display_test { if (!_can_MainWindow()) { print "1..0 # skip Cannot create MainWindow\n"; CORE::exit(0); } } sub _can_MainWindow { require Tk; if (defined $Tk::platform && $Tk::platform eq 'unix') { my $mw = eval { MainWindow->new() }; if (!Tk::Exists($mw)) { warn "Cannot create MainWindow (maybe no X11 server is running or DISPLAY is not set?)\n$@\n"; return 0; } else { $mw->destroy; return 1; } } else { return 1; } } 1; __END__ Tk-Pod-0.9943/t/optionalmods.t000755 001750 001750 00000001733 12237202456 016712 0ustar00eserteeserte000000 000000 #!/usr/bin/perl # -*- perl -*- # # Author: Slaven Rezic # use strict; BEGIN { if (!eval q{ use Test::More; # require Test::Without::Module; # die "Problems with Test::Without::Module 0.09" # if $Test::Without::Module::VERSION eq '0.09'; $ENV{DEVEL_HIDE_PM} = ""; $ENV{DEVEL_HIDE_VERBOSE} = 0; require Devel::Hide; 1; }) { # print "1..0 # skip no Test::More and/or Test::Without::Module (!= 0.09) modules\n"; print "1..0 # skip no Test::More and/or Devel::Hide modules\n"; CORE::exit; } } #use Test::Without::Module qw(Text::English Tk::HistEntry Tk::ToolBar); use Devel::Hide qw(Text::English Tk::HistEntry Tk::ToolBar); use Tk; use Tk::Pod; my $mw = eval { tkinit }; if (!$mw) { print "1..0 # cannot create MainWindow\n"; CORE::exit(0); } plan tests => 1; $mw->geometry("+0+0"); my $pod = $mw->Pod; $pod->geometry('+10+10'); # for twm $pod->idletasks; ok(Tk::Exists($pod)); if (defined $ENV{BATCH} && !$ENV{BATCH}) { MainLoop; } __END__ Tk-Pod-0.9943/t/testdata/utf8.txt.gz000644 001750 001750 00000000051 11777613536 017676 0ustar00eserteeserte000000 000000 ‹cöáJ+-I³P(ÍÍI,-)¶R8¼äð¶Ã{¸À‘]ÈTk-Pod-0.9943/t/testdata/utf8.txt000644 001750 001750 00000000025 11777613536 017260 0ustar00eserteeserte000000 000000 utf8 umlauts: äöü Tk-Pod-0.9943/t/testdata/latin1.txt000644 001750 001750 00000000024 11777613536 017561 0ustar00eserteeserte000000 000000 latin1 umlauts: äöü Tk-Pod-0.9943/Pod/Search.pm000644 001750 001750 00000020663 11777613536 016054 0ustar00eserteeserte000000 000000 package Tk::Pod::Search; use strict; use vars qw(@ISA $VERSION); $VERSION = '5.16'; use Carp; use Config qw(%Config); use File::Spec; use Tk::Frame; Construct Tk::Widget 'PodSearch'; @ISA = 'Tk::Frame'; my $searchfull_history; sub Populate { my ($cw, $args) = @_; my $Entry; eval { require Tk::HistEntry; $Entry = "HistEntry"; }; if ($@) { require Tk::BrowseEntry; $Entry = "BrowseEntry"; } my $l = $cw->Scrolled('Listbox',-width=>40,-scrollbars=>$Tk::platform eq 'MSWin32'?'e':'w'); require Tk::Pod::Styles; my $fontsize = Tk::Pod::Styles::standard_font_size($l); $l->configure(-font => "courier $fontsize"); #xxx BrowseEntry V1.3 does not honour -label at creation time :-( #my $e = $cw->BrowseEntry(-labelPack=>[-side=>'left'],-label=>'foo', #-listcmd=> ['_logit', 'list'], #-browsecmd=> ['_logit', 'browse'], #); my $f = $cw->Frame; my $e = $f->$Entry(); if ($e->can('history') && $searchfull_history) { $e->history($searchfull_history); } my $s = $f->Label(); my $b = $f->Button(-text=>'OK',-command=>[\&_search,$e,$cw,$l]); $l->pack(-fill=>'both', -side=>'top', -expand=>1); $f->pack(-fill => "x", -side => "top"); $s->pack(-anchor => 'e', -side=>'left'); $e->pack(-fill=>'x', -side=>'left', -expand=>1); $b->pack(-side => 'left'); my $current_path = delete $args->{-currentpath}; $cw->{RestrictPod} = undef; my $cb; if (defined $current_path && $current_path ne "") { $cb = $cw->Checkbutton(-variable => \$cw->{RestrictPod}, -text => "Restrict to $current_path", -anchor => "w", -onvalue => $current_path, -offvalue => undef, )->pack(-fill => "x", -side => "top", ); } $cw->Advertise( 'entry' => $e->Subwidget('entry') ); $cw->Advertise( 'listbox' => $l->Subwidget('listbox') ); $cw->Advertise( 'browse' => $e); $cw->Advertise( 'restrict' => $cb) if $cb; $cw->Delegates( 'focus' => $cw->Subwidget('entry'), ); $cw->ConfigSpecs( -label => [{-text=>$s}, 'label', 'Label', 'Search:'], -indexdir => ['PASSIVE', 'indexDir', 'IndexDir', undef], -command => ['CALLBACK', undef, undef, undef], -search => ['METHOD', 'search', 'Search', ""], 'DEFAULT' => [ $cw ], ); foreach (qw/Return space 1/) { $cw->Subwidget('listbox')->bind("<$_>", [\&_load_pod, $cw]); } $cw->Subwidget('entry')->bind('',[$b,'invoke']); undef; } sub addHistory { my ($w, $obj) = @_; my $entry_or_browse = $w->Subwidget('browse'); if ($entry_or_browse->can('historyAdd')) { $entry_or_browse->historyAdd($obj); $searchfull_history = [ $entry_or_browse->history ]; } else { $entry_or_browse->insert(0,$obj); } } sub _logit { print "logit=|", join('|',@_),"|\n"; } sub search { my $cw = shift; my $e = $cw->Subwidget('entry'); if (@_) { my $search = shift; $search = join(' ', @$search) if ref($search) eq 'ARRAY'; $e->delete(0,'end'); $e->insert(0,$search); return undef; } else { return $e->get; } } sub search_as_regexp { my $cw = shift; my $search = $cw->search; my @search = split ' ', $search; if (@search) { require Text::English; my $rx = join("|", map { quotemeta } Text::English::stem(@search)); if (@search > 1) { $rx = '(' . $rx . ')'; } $rx; } else { ''; } } sub _load_pod { my $l = shift; my $cw = shift; my $pod = pretty2path( $l->get(($l->curselection)[0])); $cw->Callback('-command', $pod, -searchterm => $cw->search_as_regexp()); } sub _search { my $e = shift; my $w = shift; my $l = shift; my $find = ref $e eq 'Tk::BrowseEntry' ? $e->Subwidget("entry")->get : $e->get; $w->addHistory($find) if $find ne ''; my %args; if ($w->{RestrictPod}) { $args{-restrictpod} = $w->{RestrictPod}; } #xxx: always open/close DBM files??? my $idx; eval { require Tk::Pod::Search_db; $idx = Tk::Pod::Search_db->new($w->{Configure}{-indexdir}); }; if ($@) { my $err = $@; $e->messageBox(-icon => 'error', -title => 'perlindex error', -message => <searchWords($find, %args); if (@raw_hits) { $l->delete(0,'end'); my @hits; my $max_length; for my $raw_hit (@raw_hits) { my($module, $path) = split_path($raw_hit->{path}); push @hits, [$raw_hit->{termhits}, $raw_hit->{score}, $module, $path]; $max_length = length $module if !defined $max_length || length $module > $max_length; } my $need_termhits = $hits[0]->[0] > 1; for my $hit (@hits) { my($termhits, $quality, $module, $path) = @$hit; $l->insert('end', sprintf(($need_termhits ? "%d " : "") . "%6.3f %-${max_length}s (%s)", ($need_termhits ? $termhits : ()), $quality, $module, $path) ); } $l->see(0); $l->activate(0); $l->selectionSet(0); $l->focus; } else { my $msg = "No Pod documentation in Library matches: '$find'"; $e->messageBox(-icon => "error", -title => "No match", -message => $msg); die $msg; } } # Converts /where/ever/it/it/Mod/Sub/Name.pm # to ("Mod/Sub/Name.pm", "/where/ever/it/is") # . Assumes that module subdirectories # start with an upper case char. (xxx: Better solution # when perlindex gives more infos. # XXX Note that split_path is also used in Search_db.pm sub split_path { my($path, $max_length) = @_; my @inc = sort { length($b) <=> length($a) } (@INC, $Config{scriptdir}); for my $inc (@inc) { # XXX Nicer solution without hardcoded directory separators needed! if (index($path, "$inc/") >= 0) { return (substr($path, length($inc)+1), $inc); } if ($^O eq 'MSWin32' && index($path, "$inc\\") >= 0) { return (substr($path, length($inc)+1), $inc); } } # Rarely this fallback should be used: my($volume, $directories, $file) = File::Spec->splitpath($path); my @path = (File::Spec->splitdir($directories), $file); # Guess the separator point between path and module/script name my $path_i; for($path_i = $#path; $path_i >= 0; $path_i--) { if ($path[$path_i] ne '' && $path[$path_i] !~ /^[A-Z]/) { last; } } # Scripts are usually lowercase, so the above logic does not work. # Fix it: if ($path_i == $#path) { $path_i--; } # Remove empty directories from the end (a relict from # splitpath/splitdir) my @dirs = @path[0 .. $path_i]; while(@dirs && $dirs[-1] eq '') { pop @dirs } # Remove empty directories from the beginning (also a relict from # splitpath/splitdir) my @moddirs = @path[$path_i+1 .. $#path]; while(@moddirs && $moddirs[0] eq '') { shift @moddirs } my($dirpart,$modpart) = (File::Spec->catpath($volume, File::Spec->catfile(@dirs), ''), File::Spec->catfile(@moddirs)); return ($modpart, $dirpart); } sub pretty2path { local($_) = shift; /([^\s]+) \s+\( (.*) \)/x; File::Spec->catfile($2, $1); } #$path = '/where/ever/it/is/Tk/Pod.pm'; print "orig|",$path, "|\n"; #$nice = path2pretty $path; print "nice|",$nice, "|\n"; #$path = pretty2path $nice; print "path|",$path, "|\n"; 1; __END__ =head1 NAME Tk::Pod::Search - Widget to access perlindex Pod full text index =for section General Purpose Widget =head1 SYNOPSIS use Tk::Pod::Search; ... $widget = $parent->PodSearch( ... ); ... $widget->configure( -search => WORDS_TO_SEARCH ); =head1 DESCRIPTION GUI interface to the full Pod text indexer B. =head1 OPTIONS =over 4 =item B Search =item B search =item B -search Expects a list of words (or a whitespace separated list). =item B undef =item B undef =item B -command Defines a call back that is called when the use selects a Pod file. It gets the full path name of the Pod file as argument. =back =head1 METHODS =over 4 =item I<$widget>->BI<(...,?...?)> =back =head1 SEE ALSO L, L, L, L, L =head1 KEYWORDS widget, tk, pod, search, full text =head1 AUTHOR Achim Bohnet > Current maintainer is Slaven ReziE<0x0107> >. Copyright (c) 1997-1998 Achim Bohnet. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-Pod-0.9943/Pod/Util.pm000644 001750 001750 00000005147 12051475651 015552 0ustar00eserteeserte000000 000000 # -*- perl -*- # # Author: Slaven Rezic # # Copyright (C) 2003,2004,2012 Slaven Rezic. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: slaven@rezic.de # WWW: http://www.rezic.de/eserte/ # package Tk::Pod::Util; use strict; use vars qw($VERSION @EXPORT_OK); $VERSION = '5.05'; use base qw(Exporter); @EXPORT_OK = qw(is_in_path is_interactive detect_window_manager start_browser); # REPO BEGIN # REPO NAME is_in_path /home/e/eserte/src/repository # REPO MD5 1b42243230d92021e6c361e37c9771d1 sub is_in_path { my($prog) = @_; require Config; my $sep = $Config::Config{'path_sep'} || ':'; foreach (split(/$sep/o, $ENV{PATH})) { if ($^O eq 'MSWin32') { return "$_\\$prog" if (-x "$_\\$prog.bat" || -x "$_\\$prog.com" || -x "$_\\$prog.exe" || -x "$_\\$prog.cmd" ); } else { return "$_/$prog" if (-x "$_/$prog" && !-d "$_/$prog"); } } undef; } # REPO END sub is_interactive { if ($^O eq 'MSWin32' || !eval { require POSIX; 1 }) { # fallback return -t STDIN && -t STDOUT; } # from perlfaq8 (with glitches) open(TTY, "/dev/tty") or return 0; my $tpgrp = POSIX::tcgetpgrp(fileno(*TTY)); my $pgrp = getpgrp(); if ($tpgrp == $pgrp) { 1; } else { 0; } } sub detect_window_manager { my $top = shift; if ($Tk::platform eq 'MSWin32') { return "win32"; } if ( get_property($top, "GNOME_NAME_SERVER")) { return "gnome"; } if ( get_property($top, "KWM_RUNNING") # KDE 1 || get_property($top, "KWIN_RUNNING") # KDE 2 ) { return "kde"; } "x11"; # generic X11 window manager } sub get_property { my($top, $prop) = @_; my @ret; if ($top->property('exists', $prop, 'root')) { @ret = $top->property('get', $prop, 'root'); shift @ret; # get rid of property name } @ret; } sub start_browser { my($url) = @_; if (!defined &Tk::Pod::WWWBrowser::start_browser && !eval { require Tk::Pod::WWWBrowser }) { *Tk::Pod::WWWBrowser::start_browser = sub { my $url = shift; if ($^O eq 'MSWin32') { system(qq{start explorer "$url"}); } elsif ($^O eq 'cygwin') { system(qq{explorer "$url" &}); } elsif (is_in_path("firefox")) { system(qq{firefox "$url" &}); } else { # last fallback system(qq{mozilla "$url" &}); } }; } Tk::Pod::WWWBrowser::start_browser($url); } 1; __END__ =head1 NAME Tk::Pod::Util - Tk::Pod specific utility functions =head1 DESCRIPTION This module contains a collection of utility functions for Tk::Pod and is not meant for public use. =cut Tk-Pod-0.9943/Pod/Styles.pm000644 001750 001750 00000010172 11777613536 016124 0ustar00eserteeserte000000 000000 require 5; use strict; package Tk::Pod::Styles; use vars qw($VERSION); $VERSION = '5.06'; sub init_styles { my $w = shift; if (!defined $w->{'style'}{'base_font_size'}) { $w->set_base_font_size($w->standard_font_size); } } sub standard_font_size { my $w = shift; my $std_font = $w->optionGet('font', 'Font'); my $std_font_size; if (!defined $std_font || $std_font eq '') { my $l = $w->Label; $std_font = $l->cget(-font); $std_font_size = $l->fontActual($std_font, '-size'); $l->destroy; } else { $std_font_size = $w->fontActual($std_font, '-size'); } $std_font_size; } sub adjust_font_size { my($w, $new_size) = @_; my $delta = $new_size - $w->base_font_size; $w->set_base_font_size($new_size); for my $tag ($w->tagNames) { my $fontsize = $w->{'style_fontsize'}{$tag}; my $f = $w->tagCget($tag, '-font'); if ($f) { my %f = $w->fontActual($f); if (!defined $fontsize) { $fontsize = $f{-size}; } $fontsize += $delta; $w->{'style_fontsize'}{$tag} = $fontsize; $f{-size} = $fontsize; my $new_f = $w->fontCreate(%f); $w->tagConfigure($tag, -font => $new_f); } } } sub set_base_font_size { $_[0]{'style'}{'base_font_size'} = $_[1] } sub base_font_size { return $_[0]{'style'}{'base_font_size'} ||= 10 } sub font_sans_serif { my $w = shift; $w->optionGet("sansSerifFont", "SansSerifFont") || "helvetica"; } sub font_serif { my $w = shift; $w->optionGet("serifFont", "SerifFont") || "times"; } sub font_monospace { my $w = shift; $w->optionGet("monospaceFont", "MonospaceFont") || "courier"; } sub style_over_bullet { $_[0]->{'style'}{'over_bullet'} ||= [ 'indent' => $_[1]->attr('indent') || 4, @{ $_[0]->style_Para } ] } sub style_over_number { $_[0]->{'style'}{'over_number'} ||= [ 'indent' => $_[1]->attr('indent') || 4, @{ $_[0]->style_Para } ] } sub style_over_text { $_[0]->{'style'}{'over_text'} ||= [ 'indent' => $_[1]->attr('indent') || 4, @{ $_[0]->style_Para } ] } sub style_item_text { $_[0]->{'style'}{'item_text'} ||= [ 'indent' => -1, @{ $_[0]->style_Para } ] # for back-denting } sub style_item_bullet { $_[0]->{'style'}{'item_bullet'} ||= [ 'indent' => -1, @{ $_[0]->style_Para } ] # for back-denting } sub style_item_number { $_[0]->{'style'}{'item_number'} ||= [ 'indent' => -1, @{ $_[0]->style_Para } ] # for back-denting } sub style_Para { $_[0]->{'style'}{'Para'} ||= [ 'family' => $_[0]->font_serif, 'size' => $_[0]->base_font_size, ] } sub style_Verbatim { $_[0]->{'style'}{'Verbatim'} ||= [ 'family' => $_[0]->font_monospace, 'size' => $_[0]->base_font_size, 'wrap' => 'none', # background => '#cccccc', # borderwidth => 1, # relief => "solid", # lmargin1 => 10, # rmargin => 10, ] } sub style_head1 { $_[0]->{'style'}{'head1'} ||= [ 'family' => $_[0]->font_sans_serif, 'size' => int(1 + 1.75 * $_[0]->base_font_size), 'underline' => 'true', ] } sub style_head2 { $_[0]->{'style'}{'head2'} ||= [ 'family' => $_[0]->font_sans_serif, 'size' => int(1 + 1.50 * $_[0]->base_font_size), 'underline' => 'true', ] } sub style_head3 { $_[0]->{'style'}{'head3'} ||= [ 'family' => $_[0]->font_sans_serif, 'size' => int(1 + 1.25 * $_[0]->base_font_size), 'underline' => 'true', ] } sub style_head4 { $_[0]->{'style'}{'head4'} ||= [ 'family' => $_[0]->font_sans_serif, 'size' => int(1 + 1.10 * $_[0]->base_font_size), 'underline' => 'true', ] } # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ sub style_C { $_[0]->{'style'}{'C'} ||= [ 'family' => $_[0]->font_monospace, ] } sub style_B { $_[0]->{'style'}{'B'} ||= [ 'weight' => 'bold', ] } sub style_I { $_[0]->{'style'}{'I'} ||= [ 'slant' => 'italic' , ] } sub style_F { $_[0]->{'style'}{'F'} ||= [ 'slant' => 'italic' , ] } #sub style_S { # $_[0]->{'style'}{'C'} ||= [ 'wrap' => 'none' ] } # ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ 1; __END__ ### Local Variables: ### cperl-indent-level: 2 ### End: Tk-Pod-0.9943/Pod/Tree.pm000644 001750 001750 00000042106 12472431741 015527 0ustar00eserteeserte000000 000000 # -*- perl -*- # # Author: Slaven Rezic # # Copyright (C) 2001,2004,2007,2008,2012,2015 Slaven Rezic. All rights reserved. # This package is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # Mail: slaven@rezic.de # WWW: http://www.rezic.de/eserte/ # package Tk::Pod::Tree; =head1 NAME Tk::Pod::Tree - list Pod file hierarchy =head1 SYNOPSIS use Tk::Pod::Tree; $parent->PodTree; =head1 WIDGET-SPECIFIC OPTIONS =over 4 =item Name: B<-showcommand> Specifies a callback for selecting a Pod module (Button-1 binding). =item Name: B<-showcommand2> Specifies a callback for selecting a Pod module in a different window (Button-2 binding). =item Name: B<-usecache> True, if a cache of Pod modules should be created and used. The default is true. =back =head1 DESCRIPTION The B widget shows all available Perl Pod documentation in a tree. =cut use strict; use vars qw($VERSION @ISA @POD %EXTRAPODDIR $ExtraFindPods); $VERSION = '5.11'; use base 'Tk::Tree'; use File::Spec; use Tk::Pod::FindPods; use Tk::ItemStyle; use Tk qw(Ev); Construct Tk::Widget 'PodTree'; my $search_history; use constant SEP => "/"; BEGIN { @POD = @INC } BEGIN { # Make a DEBUG constant very first thing... if(defined &DEBUG) { } elsif(($ENV{'TKPODDEBUG'} || '') =~ m/^(\d+)/) { # untaint my $debug = $1; *DEBUG = sub () { $debug }; } else { *DEBUG = sub () {0}; } } ###################################################################### use Class::Struct; struct '_PodEntry' => [ 'uri' => "\$", 'type' => "\$", 'name' => "\$", ]; sub _PodEntry::create { my $e = shift->new; $e->uri(shift); $e; } sub _PodEntry::file { my $uri = shift->uri; local $^W = 0; ($uri =~ /^file:(.*)/)[0]; } ###################################################################### sub Dir { my $class = shift; unshift @POD, @_; $EXTRAPODDIR{$_} = 1 for (@_); } sub ClassInit { my ($class,$mw) = @_; $class->SUPER::ClassInit($mw); $mw->bind($class, '<3>', ['PostPopupMenu', Ev('X'), Ev('Y')] ) if $Tk::VERSION > 800.014; my $set_anchor_and_sel = sub { my($w, $ent) = @_; $w->anchorSet($ent); $w->selectionClear; $w->selectionSet($ent); }; # Force callbacks to be treated as methods. This is done by putting # the $widget reference at the beginning of the Tk::Callback array my $inherited_cb = sub { my($w, $cb) = @_; if (UNIVERSAL::isa($cb, "Tk::Callback")) { my $new_cb = bless [$w, @$cb], 'Tk::Callback'; $new_cb->Call; } else { # XXX OK? $cb->($w); } }; # Add functionality to some callbacks: my $orig_home = $mw->bind($class, ""); $mw->bind($class, "" => sub { my $w = shift; $inherited_cb->($w, $orig_home); $set_anchor_and_sel->($w, ($w->infoChildren)[0]); }); my $orig_end = $mw->bind($class, ""); $mw->bind($class, "" => sub { my $w = shift; $inherited_cb->($w, $orig_end); # get last opened entry my $last = ($w->infoChildren)[-1]; while ($w->getmode($last) eq "close" && $w->infoChildren($last)) { $last = ($w->infoChildren($last))[-1]; } $set_anchor_and_sel->($w, $last); }); my $orig_prior = $mw->bind($class, ""); $mw->bind($class, "" => sub { my $w = shift; $inherited_cb->($w, $orig_prior); my $ent = $w->nearest(10); # XXX why 10? return if !defined $ent; $set_anchor_and_sel->($w, $ent); }); my $orig_next = $mw->bind($class, ""); $mw->bind($class, "" => sub { my $w = shift; $inherited_cb->($w, $orig_next); my $ent = $w->nearest($w->height - 10); # XXX why 10? return if !defined $ent; $set_anchor_and_sel->($w, $ent); }); } sub Populate { my($w,$args) = @_; $args->{-separator} = SEP; my $show_command = sub { my($w, $cmd, $ent) = @_; my $data = $w->info('data', $ent); if ($data) { $w->Callback($cmd, $w, $data); } }; my $show_command_mouse = sub { my $w = shift; my $cmd = shift || '-showcommand'; my $Ev = $w->XEvent; my $ent = $w->GetNearest($Ev->y, 1); return unless (defined $ent and length $ent); my @info = $w->info('item',$Ev->x, $Ev->y); if (defined $info[1] && $info[1] eq 'indicator') { $w->Callback(-indicatorcmd => $ent, ''); return; } $show_command->($w, $cmd, $ent); }; my $show_command_key = sub { my $w = shift; my $cmd = shift || '-showcommand'; my($ent) = $w->selectionGet; return unless (defined $ent and length $ent); if ($w->info('children', $ent)) { $w->open($ent); } $show_command->($w, $cmd, $ent); }; $w->bind("<1>" => sub { $show_command_mouse->(shift) }); foreach (qw/space Return/) { $w->bind("<$_>" => sub { $show_command_key->(shift) }); } foreach (qw/2 Shift-1/) { $w->bind("<$_>" => sub { $show_command_mouse->(shift, '-showcommand2') }); } $w->SUPER::Populate($args); $w->{Style} = {}; $w->{Style}{'core'} = $w->ItemStyle('imagetext', -foreground => '#006000', -selectforeground => '#006000', ); $w->{Style}{'site'} = $w->ItemStyle('imagetext', -foreground => '#702000', -selectforeground => '#702000', ); $w->{Style}{'vendor'} = $w->ItemStyle('imagetext', -foreground => '#856b48', -selectforeground => '#856b48', ); $w->{Style}{'cpan'} = $w->ItemStyle('imagetext', -foreground => '#000080', -selectforeground => '#000080', ); $w->{Style}{'folder'} = $w->ItemStyle('imagetext', -foreground => '#606060', -selectforeground => '#606060', ); $w->{Style}{'script'} = $w->{Style}{'site'}; $w->{Style}{'local dirs'} = $w->{Style}{'site'}; my $m = $w->Menu(-tearoff => $Tk::platform ne 'MSWin32'); eval { $w->menu($m) }; warn $@ if $@; $m->command(-label => 'Reload', -command => sub { $w->toplevel->Busy(-recurse => 1); eval { $w->Fill(-nocache => 1); }; my $err = $@; $w->toplevel->Unbusy(-recurse => 1); die $err if $err; }); $m->command(-label => 'Search...', -command => [$w, 'search_dialog']); $w->Component('Label' => 'UpdateLabel', -text => "Updating..." ); $w->ConfigSpecs( -showcommand => ['CALLBACK', undef, undef, undef], -showcommand2 => ['CALLBACK', undef, undef, undef], -usecache => ['PASSIVE', undef, undef, 1], ); } =head1 WIDGET METHODS =over 4 =item I<$tree>-EB(?I<-nocache =E 1>?, ?I<-forked =E 0|1>?, ?I<-fillcb =E ...>?) Find Pod modules and fill the tree widget. If I<-nocache> is specified, then no cache will be used for loading. A cache of Pod modules is written unless the B<-usecache> configuration option of the widget is set to false. If C<-forked> is specified, then searching for Pods is done in the background, if possible. Note that the default is currently unspecified. A callback may be specified with the C<-fillcb> option and will be called after the tree is filled. =cut sub Fill { my $w = shift; my(%args) = @_; if ($w->{FillPid}) { warn "Forked filling currently running.\n"; return; } $w->delete("all"); delete $w->{Pods}; $w->{Filled} = 0; my $forked = delete $args{-forked}; if (!defined $forked) { $forked = 1; # by default we try -forked } if ($forked) { if (!eval { require Storable; 1 }) { warn "Cannot fork, Storable is missing.\n"; $forked = 0; } elsif ($^O eq 'MSWin32' || $^O eq 'cygwin') { warn "Cannot fork on Windows systems.\n"; $forked = 0; } } if ($forked) { require POSIX; my($rdr,$wtr); pipe($rdr,$wtr); $w->{FillPid} = fork; if (!defined $w->{FillPid}) { warn "Cannot fork: $!"; # fall back to non-forked operation } elsif (!$w->{FillPid}) { # child close $rdr; my $pods = $w->_FillFind(%args); my $serialized = Storable::freeze($pods); print $wtr $serialized or die "While writing to pipe: $!"; close $wtr or die "While closing pipe: $!"; POSIX::_exit(0); } else { # parent close $wtr; $w->Subwidget('UpdateLabel')->place('-x' => 5, '-y' => 5); $w->fileevent($rdr, 'readable', sub { local $/; my $serialized = <$rdr>; my $pods = Storable::thaw($serialized); $w->_FillDone($pods, $args{'-fillcb'}); $w->fileevent($rdr, 'readable', ''); $w->Subwidget('UpdateLabel')->placeForget; waitpid $w->{FillPid}, &POSIX::WNOHANG; # zombie reaping $w->{FillPid} = undef; }); return; } } # non-forked my $pods = $w->_FillFind(%args); $w->_FillDone($pods, $args{'-fillcb'}); } sub _FillFind { my($w, %args) = @_; my $usecache = ($w->cget('-usecache') && !$args{'-nocache'}); my $FindPods = Tk::Pod::FindPods->new; my $pods = $FindPods->pod_find(-categorized => 1, -usecache => $usecache, ); if (keys %EXTRAPODDIR) { $ExtraFindPods = Tk::Pod::FindPods->new unless $ExtraFindPods; my $extra_pods = $ExtraFindPods->pod_find (-categorized => 0, -category => "local dirs", -directories => [keys %EXTRAPODDIR], -usecache => 0, ); while(my($k,$v) = each %$extra_pods) { $pods->{$k} = $v; } } if ($w->cget('-usecache') && !$FindPods->has_cache) { $FindPods->WriteCache; } $pods; } sub _FillDone { my($w, $pods, $fillcb) = @_; my %category_seen; foreach (['perl', 'Perl language'], ['pragma', 'Pragmata'], ['mod', 'Modules'], ['script', 'Scripts'], keys(%$pods), ) { my($category, $title) = (ref $_ ? @$_ : ($_, $_)); next if $category_seen{$category}; $w->add($category, -text => $title); my $hash = $pods->{$category}; foreach my $pod (sort keys %$hash) { my $treepath = $category . SEP . $pod; (my $title = $pod) =~ s|/|::|g; $w->_add_parents($treepath); my $loc = $category =~ m{^(script|local dirs)$} ? $category : Tk::Pod::FindPods::module_location($hash->{$pod}); my $is = $w->{Style}{$loc}; my @entry_args = ($treepath, -text => $title, -data => _PodEntry->create($hash->{$pod}), ($is ? (-style => $is) : ()), ); if ($w->info('exists', $treepath)) { $w->entryconfigure(@entry_args); } else { $w->add(@entry_args); } } $category_seen{$category}++; } for(my $entry = ($w->info('children'))[0]; defined $entry && $entry ne ""; $entry = $w->info('next', $entry)) { if ($w->info('children', $entry) || $w->entrycget($entry, -text) eq 'perlfunc') { $w->folderentry($entry); } else { $w->entryconfigure($entry, -image => $w->Getimage("file")); $w->hide('entry', $entry); } } $w->{Pods} = $pods; $w->{Filled}++; if ($fillcb) { $fillcb->(); } } sub folderentry { my($w, $entry) = @_; $w->entryconfigure($entry, -image => $w->Getimage("folder")); $w->setmode($entry, 'open'); if ($entry =~ m|/|) { # XXX SEP? $w->hide('entry', $entry); } } sub Filled { shift->{Filled} } sub _add_parents { my($w, $entry) = @_; (my $parent = $entry) =~ s|/[^/]*$||; # XXX SEP? return if $parent eq ''; do{warn "XXX Should not happen: $entry eq $parent";return} if $parent eq $entry; return if $w->info('exists', $parent); my @parent = split SEP, $parent; my $title = join "::", @parent[1..$#parent]; $w->_add_parents($parent); $w->add($parent, -text => $title, ($w->{Style}{'folder'} ? (-style => $w->{Style}{'folder'}) : ())); } sub _open_parents { my($w, $entry) = @_; (my $parent = $entry) =~ s|/[^/]+$||; # XXX SEP? return if $parent eq '' || $parent eq $entry; $w->_open_parents($parent); $w->open($parent); } =item I<$tree>-EB($path) Move the anchor/selection and view to the given C<$path> and open subtrees to make the C<$path> visible, if necessary. =cut sub SeePath { my($w,$path) = @_; my $fs_case_tolerant = ($^O eq 'MSWin32' || $^O eq 'darwin' || # case_tolerant=0 here! (File::Spec->can("case_tolerant") && File::Spec->case_tolerant) ); if ($^O eq 'MSWin32') { $path =~ s/\\/\//g; } if ($fs_case_tolerant) { $path = lc $path; } DEBUG and warn "Call SeePath with $path\n"; return if !$w->Filled; # not yet filled my $pods = $w->{Pods}; return if !$pods; my $see_treepath = sub { my $treepath = shift; $w->open($treepath); $w->_open_parents($treepath); $w->anchorSet($treepath); $w->selectionClear; $w->selectionSet($treepath); $w->see($treepath); }; foreach my $category (keys %$pods) { foreach my $pod (keys %{ $pods->{$category} }) { my $podpath = $pods->{$category}->{$pod}; $podpath = lc $podpath if $fs_case_tolerant; if ($path eq $podpath) { my $treepath = $category . SEP . $pod; $see_treepath->($treepath); return 1; } } } DEBUG and warn "SeePath: cannot find $path in tree\n"; 0; } sub GetCurrentPodPath { my $w = shift; my $sel_entry = ($w->selectionGet)[0]; if (defined $sel_entry) { my @c = split m{/}, $sel_entry; shift @c; my $pod = join "::", @c; return $pod; } } sub search_dialog { my($w) = @_; my $t = $w->Toplevel(-title => "Search"); $t->transient($w); $t->Label(-text => "Search module:")->pack(-side => "left"); my $term; my $Entry = 'Entry'; eval { require Tk::HistEntry; Tk::HistEntry->VERSION(0.40); $Entry = "HistEntry"; }; my $e = $t->$Entry(-textvariable => \$term)->pack(-side => "left"); if ($e->can('history') && $search_history) { $e->history($search_history); } $e->focus; $e->bind("" => sub { $t->destroy }); my $do_search = sub { if ($e->can('historyAdd')) { $e->historyAdd($term); $search_history = [ $e->history ]; } $w->search($term); }; $e->bind("" => $do_search); { my $f = $t->Frame->pack(-fill => "x"); Tk::grid($f->Button(-text => "Search", -command => $do_search, ), $f->Button(-text => "Close", -command => sub { $t->destroy }, ), -sticky => "ew"); } } sub search { my($w, $rx) = @_; return if $rx eq ''; my($entry) = ($w->info('selection'))[0]; if (!defined $entry) { $entry = ($w->info('children'))[0]; return if (!defined $entry); } my $wrapped = 0; while(1) { $entry = $w->info('next', $entry); if (!defined $entry) { if ($wrapped) { $w->bell; return; } $wrapped++; $entry = ($w->info('children'))[0]; } my $text = $w->entrycget($entry, '-text'); if ($text =~ /$rx/i) { my $p = $entry; while(1) { $p = $w->info('parent', $p); if (defined $p) { $w->open($p); } else { last; } } $w->selectionClear; $w->selectionSet($entry); $w->anchorSet($entry); $w->see($entry); return; } } } sub IndicatorCmd { my($w, $ent, $event) = @_; my $podentry = $w->entrycget($ent, "-data"); my $file = $podentry && $podentry->file; my $type = $podentry && $podentry->type; # Dynamically create children for perlfunc entry if (defined $type && $type =~ /^func_/ && !$w->info('children', $ent)) { require Pod::Functions; my $add_func = sub { my($ent, $func) = @_; my $podentry = _PodEntry->new; $podentry->type("func"); $podentry->name($func); (my $safe_name = $func) =~ s{[^a-zA-Z]}{_}g; $ent = $ent . SEP . $safe_name; $w->add($ent, -text => $func, -data => $podentry, -style => $w->{Style}{'core'}); }; if ($type eq 'func_alphabetically') { my $last_func; my @funcs = map { if (!defined $last_func || $last_func ne $_) { $last_func = $_; ($_); } else { $last_func = $_; (); } } sort map { @{ $Pod::Functions::Kinds{$_} } } keys %Pod::Functions::Kinds; for my $func (@funcs) { $add_func->($ent, $func); } } else { # by category for my $cat (sort keys %Pod::Functions::Kinds) { (my $safe_name = $cat) =~ s{[^a-zA-Z]}{_}g; my $ent = $ent . SEP . $safe_name; $w->add($ent, -text => $cat, -style => $w->{Style}{'folder'}); my $funcs = $Pod::Functions::Kinds{$cat}; for my $func (@$funcs) { $add_func->($ent, $func); } } } } elsif (defined $file && $file =~ /perlfunc\.pod$/ && !$w->info('children', $ent)) { my($treepath, $podentry); $treepath = $ent . SEP. "func_alphabetically"; $podentry = _PodEntry->new; $podentry->type("func_alphabetically"); $w->add($treepath, -text => "Alphabetically", -data => $podentry, -style => $w->{Style}{'folder'}); $w->folderentry($treepath); $treepath = $ent . SEP. "func_by_category"; $podentry = _PodEntry->new; $podentry->type("func_by_category"); $w->add($treepath, -text => "By category", -data => $podentry, -style => $w->{Style}{'folder'}); $w->folderentry($treepath); } $w->SUPER::IndicatorCmd($ent, $event); } 1; __END__ =back =head1 SEE ALSO L, L, L, L. =head1 AUTHOR Slaven ReziE<0x107> > Copyright (c) 2001,2004 Slaven ReziE<0x107>. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Tk-Pod-0.9943/Pod/Text.pm000644 001750 001750 00000120423 12472716707 015563 0ustar00eserteeserte000000 000000 require 5; package Tk::Pod::Text; use strict; BEGIN { # Make a DEBUG constant very first thing... if(defined &DEBUG) { } elsif(($ENV{'TKPODDEBUG'} || '') =~ m/^(\d+)/) { # untaint my $debug = $1; *DEBUG = sub () { $debug }; } else { *DEBUG = sub () {0}; } } use Carp; use Config; use Tk qw(catch); use Tk::Frame; use Tk::Pod; use Tk::Pod::SimpleBridge; use Tk::Pod::Cache; use Tk::Pod::Util qw(is_in_path is_interactive detect_window_manager start_browser); use vars qw($VERSION @ISA @POD $IDX @tempfiles @gv_pids $terminal_fallback_warn_shown); $VERSION = '5.32'; @ISA = qw(Tk::Frame Tk::Pod::SimpleBridge Tk::Pod::Cache); BEGIN { DEBUG and warn "Running ", __PACKAGE__, "\n" } Construct Tk::Widget 'PodText'; BEGIN { unshift @POD, ( @INC, $ENV{'PATH'} ? grep(-d, split($Config{path_sep}, $ENV{'PATH'})) : () ); $IDX = undef; DEBUG and warn "POD: @POD\n"; }; { package # hide from CPAN indexer Tk::Pod::Text::_HistoryEntry; use File::Basename qw(basename); for my $member (qw(file text index pod_title)) { my $sub = sub { my $self = shift; if (@_) { $self->{$member} = $_[0]; } $self->{$member}; }; no strict 'refs'; *{$member} = $sub; } sub create { my($class,$what,$index) = @_; my $o = bless {}, $class; if (ref $what eq 'HASH') { $o->file($what->{file}); $o->text($what->{text}); } else { $o->file($what); } $o->index($index); $o; } sub get_label { my $self = shift; my $pod_title = $self->pod_title; return $pod_title if defined $pod_title; my $file = $self->file; return basename $file if defined $file; return ""; } } use constant HISTORY_DIALOG_ARGS => [-icon => 'info', -title => 'History Error', -type => 'OK']; sub Dir { my $class = shift; unshift(@POD,@_); } sub Find { my ($file) = @_; return $file if (-f $file); my $dir; foreach $dir ("",@POD) { my $prefix; foreach $prefix ("","pod/","pods/") { my $suffix; foreach $suffix (".pod",".pm",".pl","") { my $path = "$dir/" . $prefix . $file . $suffix; return $path if (-r $path && -T $path); $path =~ s,::,/,g; return $path if (-r $path && -T $path); } } } return undef; } sub findpod { my ($w,$name,%opts) = @_; my $quiet = delete $opts{-quiet}; warn "Unhandled extra options: ". join " ", %opts if %opts; unless (defined $name and length $name) { return if $quiet; $w->_die_dialog("Empty Pod file/name"); } my $absname; if (-f $name) { $absname = $name; } else { if ($name !~ /^[-_+:.\/A-Za-z0-9]+$/) { return if $quiet; $w->_die_dialog("Invalid path/file/module name '$name'\n"); } $absname = Find($name); } if (!defined $absname) { return if $quiet; $w->_error_dialog("Can't find Pod '$name'\n"); die "Can't find Pod '$name' in @POD\n"; } if (eval { require File::Spec; File::Spec->can("rel2abs") }) { DEBUG and warn "Turn $absname into an absolute file name"; $absname = File::Spec->rel2abs($absname); } $absname; } sub _remember_old { my $w = shift; for (qw(File Text)) { $w->{"Old$_"} = $w->{$_}; } } sub _restore_old { my $w = shift; for (qw(File Text)) { $w->{$_} = $w->{"Old$_"}; } } sub file { # main entry point my $w = shift; if (@_) { my $file = shift; $w->_remember_old; eval { my $calling_from_history = $w->privateData()->{'from_history'}; $w->{'File'} = $file; $w->{'Text'} = undef; my $path = $w->findpod($file); if (!$calling_from_history) { $w->history_modify_entry; $w->history_add({file => $path}, "1.0"); } $w->configure('-path' => $path); $w->delete('1.0' => 'end'); my $tree_sw = $w->parent->Subwidget("tree"); if ($tree_sw) { $tree_sw->SeePath("file:$path"); } my $t; if (DEBUG) { require Benchmark; $t = Benchmark->new; } if (!$w->get_from_cache) { $w->process($path); $w->add_to_cache; # XXX pass time for processing? if (!$calling_from_history) { $w->history_modify_current_title; # now the pod_title is known } } if (defined $t) { print Benchmark::timediff(Benchmark->new, $t)->timestr,"\n"; } $w->focus; }; if ($@) { $w->_restore_old; die $@; } } $w->{'File'}; } sub text { my $w = shift; if (@_) { my $text = shift; $w->_remember_old; eval { my $calling_from_history = $w->privateData()->{'from_history'}; $w->{'Text'} = $text; $w->{'File'} = undef; if (!$calling_from_history) { $w->history_modify_entry; $w->history_add({text => $text}, "1.0"); } $w->configure('-path' => undef); $w->delete('1.0' => 'end'); ## XXX Implementation unclear, maybe should be done in showcommand call... # my $tree_sw = $w->parent->Subwidget("tree"); # if ($tree_sw) { # $tree_sw->SeeFunc("file:$path"); # } my $t; if (DEBUG) { require Benchmark; $t = Benchmark->new; } # No caching here # XXX title: the 2nd part of the hack my $title = $w->cget(-title); $w->process(\$text, $title); if (!$calling_from_history) { $w->history_modify_current_title; # now the pod_title is known } if (defined $t) { print Benchmark::timediff(Benchmark->new, $t)->timestr,"\n"; } $w->focus; }; if ($@) { $w->_restore_old; die $@; } } $w->{'Text'}; } sub reload { my ($w) = @_; # remember old y position my ($currpos) = $w->yview; $w->delete('0.0','end'); $w->delete_from_cache; $w->process($w->cget('-path')); # restore old y position $w->yview(moveto => $currpos); # set (invisible) insertion cursor into the visible text area $w->markSet(insert => '@0,0'); } # Works also for viewing source code sub _get_editable_path { my ($w) = @_; my $path = $w->cget('-path'); if (!defined $path) { my $text = $w->cget("-text"); $w->_need_File_Temp; my($fh,$fname) = File::Temp::tempfile(UNLINK => 1, SUFFIX => "_tkpod.pod"); print $fh $text; close $fh; $path = $fname; } $path; } sub edit { my ($w,$edit,$linenumber) = @_; my $path = $w->_get_editable_path; if (!defined $edit) { $edit = $ENV{TKPODEDITOR}; } if ($^O eq 'MSWin32') { if (defined $edit && $edit ne "") { system(1, $edit, $path); } else { system(1, "ptked", $path); } } else { if (!defined $edit || $edit eq "") { # VISUAL and EDITOR are supposed to have a terminal, but tkpod can # be started without a terminal. my $isatty = is_interactive(); if (!$isatty) { if (!defined $edit || $edit eq "") { $edit = $ENV{XEDITOR}; } if (!defined $edit || $edit eq "") { if (!$terminal_fallback_warn_shown) { $w->_warn_dialog("No terminal and neither TKPODEDITOR nor XEDITOR environment variables set. Fallback to ptked."); $terminal_fallback_warn_shown = 1; } $edit = 'ptked'; } } else { $edit = $ENV{VISUAL} || $ENV{'EDITOR'} || '/usr/bin/vi'; } } if (defined $edit) { if (fork) { wait; # parent } else { #child if (fork) { # still child exec("true"); } else { # grandchild if (defined $linenumber && $edit =~ m{\bemacsclient\b}) # XXX an experiment, maybe support more editors? { exec("$edit +$linenumber $path"); } else { exec("$edit $path"); } } } } } } sub edit_get_linenumber { my($w) = @_; my $linenumber = $w->get_linenumber; $w->edit(undef, $linenumber); } sub get_linenumber { my($w) = @_; for my $tag ($w->tagNames('@' . ($w->{MenuX} - $w->rootx) . ',' . ($w->{MenuY} - $w->rooty))) { if ($tag =~ m{start_line_(\d+)}) { return $1; } } undef; } sub view_source { my($w) = @_; # XXX why is -title empty here? my $title = $w->cget(-title) || $w->cget('-file'); my $t = $w->Toplevel(-title => "Source of $title - Tkpod"); my $font_size = $w->base_font_size; my $more = $t->Scrolled('More', -font => "Courier $font_size", -scrollbars => $Tk::platform eq 'MSWin32' ? 'e' : 'w', )->pack(-fill => "both", -expand => 1); $more->Load($w->_get_editable_path); my $linenumber = $w->get_linenumber; if (defined $linenumber) { $more->see($linenumber.'.'.0); } $more->AddQuitBindings; $more->focus; } sub copy_pod_location { my($w) = @_; my $file = $w->_get_editable_path; if (!defined $file) { $w->_error_dialog("Cannot copy location: this Pod is not associated with a file"); return; } $w->SelectionOwn; $w->SelectionHandle(sub { my($offset,$maxbytes) = @_; # XXX It's not exactly clear why I have to # call _get_editable_path again here and not # reuse $file. my $file = $w->_get_editable_path; return undef if $offset > length($file); substr($file, $offset, $maxbytes); }); } sub _sgn { $_[0] cmp 0 } sub zoom_normal { my $w = shift; $w->adjust_font_size($w->standard_font_size); $w->clear_cache; } # XXX should use different increments for different styles sub zoom_out { my $w = shift; $w->adjust_font_size($w->base_font_size - 1 * _sgn($w->base_font_size)); $w->clear_cache; } sub zoom_in { my $w = shift; $w->adjust_font_size($w->base_font_size + 1 * _sgn($w->base_font_size)); $w->clear_cache; } sub More_Widget { "More" } sub More_Module { "Tk::More" } sub Populate { my ($w,$args) = @_; if ($w->More_Module) { eval q{ require } . $w->More_Module; die $@ if $@; } $w->SUPER::Populate($args); $w->privateData()->{history} = []; $w->privateData()->{history_index} = -1; my $p = $w->Scrolled($w->More_Widget, -helpcommand => sub { $w->parent->help if $w->parent->can('help'); }, -scrollbars => $Tk::platform eq 'MSWin32' ? 'e' : 'w'); my $p_scr = $p->Subwidget('scrolled'); $w->Advertise('more' => $p_scr); $p->pack(-expand => 1, -fill => 'both'); # XXX Subwidget stuff needed because Scrolled does not # delegate bind, bindtag to the scrolled widget. Tk402.* (and before?) # (patch posted and included in Tk402.004) $p_scr->bindtags([$p_scr, $p_scr->bindtags]); $p_scr->bind('', sub { $w->DoubleClick($_[0]) }); $p_scr->bind('', sub { $w->ShiftDoubleClick($_[0]) }); $p_scr->bind('', sub { $w->ShiftDoubleClick($_[0]) }); $p_scr->bind('<3>', sub { $w->PostPopupMenu($p_scr, $w->pointerxy) }); $p_scr->bind('', [sub { # A hack solution to prevent from firing this # event over pod links. See http://wiki.tcl.tk/6101 my($ro,$x,$y) = @_; if (grep { $_ eq 'pod_link' } $ro->tagNames("\@$x,$y")) { Tk->break; } else { $w->OpenPodBySelection; } }, Tk::Ev("x"), Tk::Ev("y")]); $p->configure(-font => $w->Font(family => 'courier')); $p->tag('configure','text', -font => $w->Font(family => 'times')); $p->insert('0.0',"\n"); $w->{List} = []; # stack of =over $w->{Item} = undef; $w->{'indent'} = 0; $w->{Length} = 64; $w->{Indent} = {}; # tags for various indents # Seems like a perl bug: ->can() does not work before actually calling # the subroutines (perl5.6.0 isa bug?) eval { $p->EditMenuItems; $p->SearchMenuItems; $p->ViewMenuItems; }; my $m = $p->Menu (-title => "Tkpod", -tearoff => $Tk::platform ne 'MSWin32', -menuitems => [ [Button => 'Back', -command => [$w, 'history_move', -1]], [Button => 'Forward', -command => [$w, 'history_move', +1]], [Button => 'Reload', -command => sub{$w->reload} ], [Button => 'Edit Pod', -command => sub{ $w->edit_get_linenumber } ], [Button => 'View source', -command => sub{ $w->view_source } ], [Button => 'Copy Pod location', -command => sub { $w->copy_pod_location } ], [Button => 'Search full text',-command => ['SearchFullText', $w]], [Separator => ""], [Cascade => 'Edit', ($Tk::VERSION > 800.015 && $p->can('EditMenuItems') ? (-menuitems => $p->EditMenuItems) : ()), ], [Cascade => 'Search', ($Tk::VERSION > 800.015 && $p->can('SearchMenuItems') ? (-menuitems => $p->SearchMenuItems) : ()), ], [Cascade => 'View', ($Tk::VERSION > 800.015 && $p->can('ViewMenuItems') ? (-menuitems => $p->ViewMenuItems) : ()), ] ]); eval { $p->menu($m) }; warn $@ if $@; $w->Delegates(DEFAULT => $p, 'SearchFullText' => 'SELF', ); $w->ConfigSpecs( '-file' => ['METHOD' ], '-text' => ['METHOD' ], '-path' => ['PASSIVE' ], '-poddone' => ['CALLBACK'], '-title' => ['PASSIVE' ], # XXX unclear '-wrap' => [ $p, qw(wrap Wrap word) ], # -font ignored because it does not change the other fonts #'-font' => [ 'PASSIVE', undef, undef, undef], '-scrollbars' => [ $p, qw(scrollbars Scrollbars), $Tk::platform eq 'MSWin32' ? 'e' : 'w' ], '-basefontsize' => ['METHOD'], # XXX may change 'DEFAULT' => [ $p ], ); $args->{-width} = $w->{Length}; } sub basefontsize { my($w, $val) = @_; if ($val) { $w->set_base_font_size($val); } else { $w->base_font_size; } } sub Font { my ($w,%args) = @_; $args{'family'} = 'times' unless (exists $args{'family'}); $args{'weight'} = 'medium' unless (exists $args{'weight'}); $args{'slant'} = 'r' unless (exists $args{'slant'}); $args{'size'} = 140 unless (exists $args{'size'}); $args{'spacing'} = '*' unless (exists $args{'spacing'}); $args{'slant'} = substr($args{'slant'},0,1); my $name = "-*-$args{'family'}-$args{'weight'}-$args{'slant'}-*-*-*-$args{'size'}-*-*-$args{'spacing'}-*-iso8859-1"; return $name; } sub ShiftDoubleClick { shift->DoubleClick(shift, 'new'); } sub DoubleClick { my ($w,$ww,$how) = @_; my $Ev = $ww->XEvent; $w->SelectToModule($Ev->xy); my $sel = catch { $w->SelectionGet }; if (defined $sel) { my $file; if ($file = $w->findpod($sel)) { if (defined $how && $how eq 'new') { my $tree = eval { $w->parent->cget(-tree) }; my $exitbutton = eval { $w->parent->cget(-exitbutton) }; $w->MainWindow->Pod('-file' => $sel, '-tree' => $tree, -exitbutton => $exitbutton); } else { $w->configure('-file'=>$file); } } else { $w->_die_dialog("No Pod documentation found for '$sel'\n"); } } Tk->break; } sub Link { my ($w,$how,$index,$man,$sec) = @_; # If clicking on a Link, the binding is never called, so it # have to be done here: $w->LeaveLink; $man = '' unless defined $man; $sec = '' unless defined $sec; if ($how eq 'reuse' && $man ne '') { my $file = $w->cget('-file'); $w->configure('-file' => $man) unless ( defined $file and ($file =~ /\Q$man\E\.\w+$/ or $file eq $man) ); } if ($how eq 'new') { $man = $w->cget('-file') if ($man eq ""); my $tree = eval { $w->parent->cget(-tree) }; my $exitbutton = eval { $w->parent->cget(-exitbutton) }; my $old_w = $w; my $new_pod = $w->MainWindow->Pod('-tree' => $tree, -exitbutton => $exitbutton, ); $new_pod->configure('-file' => $man); # see tkpod for the same problem $w = $new_pod->Subwidget('pod'); # set search term for new window my $search_term_ref = $old_w->Subwidget('more')->Subwidget('searchentry')->cget(-textvariable); if (defined $$search_term_ref && $$search_term_ref ne "") { $ {$w->Subwidget('more')->Subwidget('searchentry')->cget(-textvariable) } = $$search_term_ref; } } # XXX big docs like Tk::Text take too long until they return if ($sec ne '' && $man eq '') # XXX reuse vs. new { $w->history_modify_entry; } if ($sec ne '') { my $highlight_match = sub { my $start = shift; my($line) = split(/\./, $start); $w->tag('remove', '_section_mark', qw/0.0 end/); $w->tag('add', '_section_mark', $line . ".0", $line . ".0 lineend"); $w->yview("_section_mark.first"); $w->after(500, [$w, qw/tag remove _section_mark 0.0 end/]); }; DEBUG and warn "Looking for section \"$sec\" across Sections entries...\n"; foreach my $s ( @{$w->{'sections'} || []} ) { if($s->[1] eq $sec) { DEBUG and warn " $sec is $$s[1] (at $$s[2])\n"; my $start = $s->[2]; my($line) = split(/\./, $start); $line--; # off by one, why? $highlight_match->("$line.0"); return; } else { DEBUG > 2 and warn " Nope, it's not $$s[1] (at $$s[2])\n"; } } my $start = ($w->tag('nextrange',$sec, '1.0'))[0]; if (defined $start) { DEBUG and warn " Found at $start\n"; $highlight_match->($start); return; } else { DEBUG and warn " Not found so far. Using a quoted nextrange search...\n"; my $link = ($man || '') . $sec; $start = ($w->tag('nextrange',"\"$link\"",'1.0'))[0]; } if (defined $start) { DEBUG and warn " Found at $start\n"; $highlight_match->($start); return; } else { DEBUG and warn " Again not found. Using an exact search at line beginnings...\n"; $start = $w->search(qw/-regexp -nocase --/, qr{^\s*\Q$sec}, '1.0'); } if (defined $start) { DEBUG and warn " Found at $start\n"; $highlight_match->($start); return; } else { DEBUG and warn " Again not found. Using an exact search...\n"; $start = $w->search(qw/-exact -nocase --/, $sec, '1.0'); } if (defined $start) { DEBUG and warn " Found at $start\n"; $highlight_match->($start); return; } else { DEBUG and warn " Not found! (\"sec\")\n"; $w->_die_dialog("Section '$sec' not found\n"); } DEBUG and warn "link-zapping to $start linestart\n"; $w->yview("$start linestart"); } if ($sec ne '' && $man eq '') # XXX reuse vs. new { $w->history_add({file => $w->cget(-path)}, $w->index('@0,0')); } } sub Link_url { my ($w,$how,$index,$man,$sec) = @_; if (my($lat,$lon) = $man =~ m{^geo:([^,]+),([^,]+)}) { DEBUG and warn "Translate geo URI $man\n"; # XXX currently hardcoded to OSM, maybe make configurable $man = "http://www.openstreetmap.org/?mlat=$lat&mlon=$lon"; } DEBUG and warn "Start browser with $man\n"; start_browser($man); } sub Link_man { my ($w,$how,$index,$man,$sec) = @_; my $mansec; if ($man =~ s/\s*\((.*)\)\s*$//) { $mansec = $1; } my @manbrowser; if (exists $ENV{TKPODMANVIEWER} && $ENV{TKPODMANVIEWER} eq "internal") { DEBUG and warn "Use internal man viewer\n"; } else { my $manurl = "man:$man($mansec)"; if (defined $sec && $sec ne "") { $manurl .= "#$sec"; } DEBUG and warn "Try to start any man browser for $manurl\n"; @manbrowser = ('gnome-help-browser', 'khelpcenter'); my $wm = detect_window_manager($w); DEBUG and warn "Window manager system is $wm\n"; if ($wm eq 'kde') { unshift @manbrowser, 'khelpcenter'; } if (defined $ENV{TKPODMANVIEWER}) { unshift @manbrowser, $ENV{TKPODMANVIEWER}; } for my $manbrowser (@manbrowser) { DEBUG and warn "Try $manbrowser...\n"; if (is_in_path($manbrowser)) { if (fork == 0) { DEBUG and warn "Use $manbrowser...\n"; exec($manbrowser, $manurl); die $!; } return; } } } if (!$w->InternalManViewer($mansec, $man)) { $w->_die_dialog("No useable man browser found. Tried @manbrowser and internal man viewer via `man'"); } } sub InternalManViewer { my($w, $mansec, $man) = @_; my $man_exe = "man"; if (!is_in_path($man_exe)) { if ($^O eq 'MSWin32') { $man_exe = "c:/cygwin/bin/man.exe"; if (!-e $man_exe) { return 0; } } else { return 0; } } my $t = $w->Toplevel(-title => "Manpage $man($mansec)"); my $font_size = $w->base_font_size; my $more = $t->Scrolled("More", -font => "Courier $font_size", -scrollbars => $Tk::platform eq 'MSWin32' ? 'e' : 'w', )->pack(-fill => "both", -expand => 1); $more->tagConfigure("bold", -font => "Courier $font_size bold"); my $menu = $more->menu; $t->configure(-menu => $menu); local $SIG{PIPE} = "IGNORE"; my $can_langinfo = $] >= 5.008 && eval { require I18N::Langinfo; 1 }; local $ENV{LANG} = $ENV{LANG}; if (!$can_langinfo) { $ENV{LANG} = "C"; } open(MAN, $man_exe . (defined $mansec ? " $mansec" : "") . " $man |") or die $!; if ($can_langinfo) { my $codeset = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); eval qq{ binmode MAN, q{:encoding($codeset)} }; warn $@ if $@; } if (eof MAN) { $more->insert("end", "No entry for for $man" . (defined $mansec ? " in section $mansec of" : "") . " the manual"); } else { while() { chomp; (my $line = $_) =~ s/.\cH//g; my @bold; while (/(.*?)((?:(.)(\cH\3)+)+)/g) { my($pre, $bm) = ($1, $2); $pre =~ s/.\cH//g; $bm =~ s/.\cH//g; push @bold, length $pre, length $bm; } if (@bold) { my $is_bold = 0; foreach my $length (@bold) { if ($length > 0) { (my($s), $line) = $line =~ /^(.{$length})(.*)/; $more->insert("end", $s, $is_bold ? "bold" : ()); } $is_bold = 1 - $is_bold; } $more->insert("end", "$line\n"); } else { $more->insert("end", "$line\n"); } } } close MAN; 1; } sub EnterLink { my $w = shift; $w->configure(-cursor=>'hand2'); } sub LeaveLink { my $w = shift; $w->configure(-cursor=>undef); } sub SearchFullText { my $w = shift; unless (defined $IDX && $IDX->IsWidget) { require Tk::Pod::Search; # $IDX = $w->Toplevel(-title=>'Perl Library Full Text Search'); $IDX->transient($w); my $current_path; my $tree_sw = $w->parent->Subwidget("tree"); if ($tree_sw) { $current_path = $tree_sw->GetCurrentPodPath; } $IDX->PodSearch( -command => sub { my($pod, %args) = @_; $w->configure('-file' => $pod); $w->focus; my $more = $w->Subwidget('more'); $more->SearchText (-direction => 'Next', -quiet => 1, -searchterm => $args{-searchterm}, -onlymatch => 1, ); }, -currentpath => $current_path, )->pack(-fill=>'both',-expand=>'both'); # XXX A very rough solution: $IDX->Button(-text => "Rebuild search index", -command => sub { my $installscriptdir = $Config{'installscript'}; my $perlindex = 'perlindex'; if (-d $installscriptdir) { $perlindex = "$installscriptdir/perlindex"; if (!-f $perlindex) { $w->_error_dialog("perlindex was expected in the path '$perlindex', but not found. Cannot build search index."); return; } } my $pw_bg_msg = "The next dialog will ask for the root password. The search index building will happen in background."; if (!is_in_path("gksu")) { if (!is_in_path("xsu")) { $w->_error_dialog("gksu or xsu needed to start perlindex"); return; } $w->_warn_dialog($pw_bg_msg); if (fork == 0) { system('xsu', '--command', "$perlindex -index", '--username', 'root', '--title' => 'Rebuild search index', '--set-display' => $w->screen, ); CORE::exit(0); } } else { $w->_warn_dialog($pw_bg_msg); if (fork == 0) { system('gksu', '--user', 'root', #'--description', 'Rebuild search index', "perlindex -index", ); CORE::exit(0); } } } )->pack(-fill => 'x'); $IDX->Button(-text => "Close", -command => sub { $IDX->destroy }, )->pack(-fill => 'x'); } $IDX->deiconify; $IDX->raise; $IDX->bind('' => [$IDX, 'destroy']); (($IDX->children)[0])->focus; } sub _need_File_Temp { my $w = shift; if (!eval { require File::Temp; 1 }) { $w->_die_dialog("The perl module 'File::Temp' is missing"); } } sub Print { my $w = shift; my($text, $path); $path = $w->cget(-path); if (defined $path) { if (!-r $path) { $w->_die_dialog("Cannot find file `$path`"); } } else { $text = $w->cget("-text"); $w->_need_File_Temp; my($fh,$fname) = File::Temp::tempfile(UNLINK => 1, SUFFIX => "_tkpod.pod"); print $fh $text; close $fh; $path = $fname; } if ($ENV{'TKPODPRINT'}) { my @cmd = _substitute_cmd($ENV{'TKPODPRINT'}, $path); DEBUG and warn "Running @cmd\n"; system @cmd; return; } elsif ($^O =~ m/Win32/) { return $w->Print_MSWin($path); } # otherwise fall thru... my $success = $w->_print_pod_unix($path); if (!$success) { $w->_error_dialog("Can't print on your system.\nEither pod2man, groff,\ngv or ghostview are missing."); } } sub _print_pod_unix { my($w, $path) = @_; if (is_in_path("pod2man") && is_in_path("groff")) { my $pod2ps_pipe = "pod2man $path | groff -man -Tps"; if ($^O eq 'darwin') { my $cmd = "$pod2ps_pipe | /usr/bin/open -a Preview -f"; system($cmd) == 0 or $w->_die_dialog("Error while executing <$cmd>. Status code is $?"); return 1; } # XXX maybe determine user's environment (GNOME vs. KDE vs. plain X11)? my $gv = is_in_path("gv") || is_in_path("ghostview") || is_in_path("ggv") # newer versions seem to work || is_in_path("kghostview"); if ($gv) { $w->_need_File_Temp; my($fh,$fname) = File::Temp::tempfile(SUFFIX => "_tkpod.ps"); system("$pod2ps_pipe > $fname"); push @tempfiles, $fname; my $pid = fork; if (!defined $pid) { die "Can't fork: $!"; } if ($pid == 0) { exec($gv, $fname); warn "Exec of $gv $fname failed: $!"; CORE::exit(1); } push @gv_pids, $pid; return 1; } } return 0; } sub _substitute_cmd { my($cmd, $path) = @_; my @cmd; if ($cmd =~ /%s/) { ($cmd[0] = $cmd) =~ s/%s/$path/g; } else { @cmd = ($cmd, $path); } @cmd; } sub Print_MSWin { my($self, $path) = @_; my $is_old; $is_old = 1 if defined(&Win32::GetOSVersion) and eval {require Win32; 1} and defined(&Win32::GetOSName) and (Win32::GetOSName() eq 'Win32s' or Win32::GetOSName() eq 'Win95'); require POSIX; # XXX should be probably replaced by File::Temp, but I have no Win machine to test... my $temp = POSIX::tmpnam(); # XXX it never gets deleted $temp =~ tr{/}{\\}; $temp =~ s/\.$//; DEBUG and warn "Using $temp as the temp file for hardcopying\n"; # XXX cleanup of temp file? if($is_old) { # so we can't assume that write.exe can handle RTF require Pod::Simple::Text; require Text::Wrap; local $Text::Wrap::columns = 65; # reasonable number, I think. $temp .= '.txt'; Pod::Simple::Text->parse_from_file($path, $temp); system("notepad.exe", "/p", $temp); } else { # Assume that our write.exe should understand RTF require Pod::Simple::RTF; $temp .= '.rtf'; Pod::Simple::RTF->parse_from_file($path, $temp); system("write.exe", "/p", "\"$temp\""); } return; } sub PrintHasDialog { $^O ne 'MSWin32' } # Return $first and $last indices of the word under $index sub _word_under_index { my($w, $index)= @_; my ($first,$last); $first = $w->search(qw/-backwards -regexp --/, '[^\w:]', $index, "$index linestart"); $first = $w->index("$first + 1c") if $first; $first = $w->index("$index linestart") unless $first; $last = $w->search(qw/-regexp --/, '[^\w:]', $index, "$index lineend"); $last = $w->index("$index lineend") unless $last; ($first, $last); } sub SelectToModule { my($w, $index)= @_; my ($first,$last) = $w->_word_under_index($index); if ($first && $last) { $w->tagRemove('sel','1.0',$first); $w->tagAdd('sel',$first,$last); $w->tagRemove('sel',$last,'end'); $w->idletasks; } } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Add the file $file (with optional text index position $index) to the # history. sub history_add { my ($w,$what,$index) = @_; my($file, $text); if (ref $what eq 'HASH') { $file = $what->{file}; $text = $what->{text}; } else { $file = $what; $what = {file => $file}; } if (defined $file) { unless (-f $file) { $w->messageBox(-message => "Not a file '$file'. Can't add to history\n", @{&HISTORY_DIALOG_ARGS}); return; } } my $hist = $w->privateData()->{history}; my $hist_entry = Tk::Pod::Text::_HistoryEntry->create($what, $index, $w->{pod_title}); $hist->[++$w->privateData()->{history_index}] = $hist_entry; splice @$hist, $w->privateData()->{history_index}+1; $w->history_view_update; $w->history_view_select; $w->_history_navigation_update; undef; } # Perform a "history back" operation, if possible. The current page is # updated in the history. sub history_back { my ($w) = @_; my $hist = $w->privateData()->{history}; if (!@$hist) { $w->messageBox(-message => "History is empty", @{&HISTORY_DIALOG_ARGS}); return; } if ($w->privateData()->{history_index} <= 0) { $w->messageBox(-message => "Can't go back in history", @{&HISTORY_DIALOG_ARGS}); return; } $w->history_modify_entry; $hist->[--$w->privateData()->{history_index}]; } # Perform a "history forward" operation, if possible. The current page is # updated in the history. sub history_forward { my ($w) = @_; my $hist = $w->privateData()->{history}; if (!@$hist) { $w->messageBox(-message => "History is empty", @{&HISTORY_DIALOG_ARGS}); return; } if ($w->privateData()->{history_index} >= $#$hist) { $w->messageBox(-message => "Can't go forward in history", @{&HISTORY_DIALOG_ARGS}); return; } $w->history_modify_entry; $hist->[++$w->privateData()->{history_index}]; } # Private method: update the pod view if called from a history back/forward # operation. This method will set the specified _HistoryEntry object. sub _history_update { my($w, $hist_entry) = @_; if ($hist_entry) { if (defined $hist_entry->file) { if ($w->cget('-path') ne $hist_entry->file) { $w->privateData()->{'from_history'} = 1; $w->configure('-file' => $hist_entry->file); $w->privateData()->{'from_history'} = 0; } } elsif (defined $hist_entry->text) { $w->privateData()->{'from_history'} = 1; $w->configure('-text' => $hist_entry->text); $w->privateData()->{'from_history'} = 0; } $w->_history_navigation_update; $w->afterIdle(sub { $w->see($hist_entry->index) }) if $hist_entry->index; } } sub _history_navigation_update { my $w = shift; # XXX Be careful with the search pattern # if I decide to I18N Tk::Pod one day... my $m_history; if ($w->parent and $m_history = $w->parent->Subwidget("menubar")) { $m_history = $m_history->entrycget("History", "-menu"); my $inx = $w->privateData()->{history_index}; if ($inx == 0) { $m_history->entryconfigure("Back", -state => "disabled"); } else { $m_history->entryconfigure("Back", -state => "normal"); } if ($inx == $#{$w->privateData()->{history}}) { $m_history->entryconfigure("Forward", -state => "disabled"); } else { $m_history->entryconfigure("Forward", -state => "normal"); } } } # Move the history backward ($inc == -1) or forward ($inc == +1) sub history_move { my($w, $inc) = @_; my $hist_entry = ($inc == -1 ? $w->history_back : $w->history_forward); $w->_history_update($hist_entry); $w->history_view_select; } # Set the history to the given index $inx. sub history_set { my($w, $inx) = @_; if ($inx >= 0 && $inx <= $#{$w->privateData()->{history}}) { $w->history_modify_entry; $w->privateData()->{history_index} = $inx; $w->_history_update($w->privateData()->{history}->[$inx]); } } # Modify the index (position) information of the current history entry. sub history_modify_entry { my $w = shift; if ($w->privateData()->{'history_index'} >= 0) { my $entry = $w->privateData()->{'history'}->[$w->privateData()->{'history_index'}]; $entry->index($w->index('@0,0')); } } # Modify the pod title of the current history entry. sub history_modify_current_title { my $w = shift; my $pod_title = $w->{pod_title}; if (defined $pod_title) { my $history_index = $w->privateData()->{'history_index'}; if ($history_index >= 0) { my $entry = $w->privateData()->{'history'}->[$history_index]; $entry->pod_title($pod_title); $w->history_view_update; $w->history_view_select; } } } # Create a new history view toplevel or reuse an old one. sub history_view { my $w = shift; my $t = $w->privateData()->{'history_view_toplevel'}; if (!$t || !Tk::Exists($t)) { $t = $w->Toplevel(-title => 'History'); $t->transient($w); $w->privateData()->{'history_view_toplevel'} = $t; my $lb = $t->Scrolled("Listbox", -scrollbars => 'oso'.($Tk::platform eq 'MSWin32'?'e':'w'))->pack(-fill => "both", '-expand' => 1); $t->Advertise(Lb => $lb); $lb->bind("<1>" => sub { my $lb = shift; my $y = $lb->XEvent->y; $w->history_set($lb->nearest($y)); }); $lb->bind("" => sub { my $lb = shift; my $sel = $lb->curselection; return if !defined $sel; $w->history_set($sel); }); $t->Button(-text => "Close", -command => sub { $t->destroy }, )->pack(-fill => 'x'); } $t->deiconify; $t->raise; $w->history_view_update; $w->history_view_select; } # Re-fill the history view with the current history array. sub history_view_update { my $w = shift; my $t = $w->privateData()->{'history_view_toplevel'}; if ($t && Tk::Exists($t)) { my $lb = $t->Subwidget('Lb'); $lb->delete(0, "end"); foreach my $histentry (@{$w->privateData()->{'history'}}) { $lb->insert("end", $histentry->get_label); } } } # Move the history view selection to the current selected history entry. sub history_view_select { my $w = shift; my $t = $w->privateData()->{'history_view_toplevel'}; if ($t && Tk::Exists($t)) { my $lb = $t->Subwidget('Lb'); $lb->selectionClear(0, "end"); $lb->selectionSet($w->privateData()->{history_index}); } } sub PostPopupMenu { my($w, $p_scr, $X, $Y) = @_; $w->{MenuX} = $X; $w->{MenuY} = $Y; $p_scr->PostPopupMenu($X, $Y); } sub OpenPodBySelection { my($w) = @_; my $sel; Tk::catch { $sel = $w->SelectionGet('-selection' => ($Tk::platform eq 'MSWin32' ? "CLIPBOARD" : "PRIMARY")); }; $sel =~ s{\s}{}g; # no whitespace in Pod names possible $w->configure(-file => $sel); } sub _die_dialog { shift->_error_dialog(@_); die; } sub _error_dialog { my($w, $message) = @_; $w->messageBox( -title => "Tk::Pod Error", -message => $message, -icon => 'error', ); } sub _warn_dialog { my($w, $message) = @_; $w->messageBox( -title => "Tk::Pod Warning", -message => $message, -icon => 'warning', ); } sub cleanup_tempfiles { if (@tempfiles) { # first get rid of all possible zombies # before we can check with kill 0 => ... require POSIX; if (defined &POSIX::WNOHANG) { # defined everywhere? while (waitpid(-1, &POSIX::WNOHANG) > 0) { } } my $gv_running; for my $pid (@gv_pids) { if (kill 0 => $pid) { $gv_running = 1; last; } } if ($gv_running) { warn "A ghostscript (or equivalent) process is still running, won't delete temporary files: @tempfiles\n"; } else { for my $temp (@tempfiles) { unlink $temp; } @tempfiles = (); } } } END { cleanup_tempfiles(); } 1; __END__ =head1 NAME Tk::Pod::Text - Pod browser widget =head1 SYNOPSIS use Tk::Pod::Text; $pod = $parent->Scrolled("PodText", -file => $file, -scrollbars => "osoe", ); $file = $pod->cget('-path'); # ?? the name path is confusing :-( =cut # also works with L. Therefore it stays undocumented :-) # $pod->Link(manual/section) # as L see perlpod =head1 DESCRIPTION B is a readonly text widget that can display Pod documentation. =head1 OPTIONS =over =item -file The named (pod) file to be displayed. =item -path Return the expanded path of the currently displayed Pod. Useable only with the C method. =item -poddone A callback to be called if parsing and displaying of the Pod is done. =item -wrap Set the wrap mode. Default is C. =item -scrollbars The position of the scrollbars, see also L. By default, the vertical scrollbar is on the right on Windows systems and on the left on X11 systems. Note that it is not necessary and usually will do the wrong thing if you put a C widget into a C component. =back Other options are propagated to the embedded L widget. =head1 ENVIRONMENT =over =item TKPODDEBUG Turn debugging mode on if set to a true value. =item TKPODPRINT Use the specified program for printing the current pod. If the string contains a C<%s>, then filename substitution is used, otherwise the filename of the Pod document is appended to the value of C. Here is a silly example to send the Pod to a web browser: env TKPODPRINT="pod2html %s > %s.html; galeon %s.html" tkpod ... =item TKPODEDITOR Use the specified program for editing the current pod. If C is not specified then the first defined value of C, C, or C is used on Unix. As a last fallback, C or C are used, depending on platform and existance of a terminal. =item TKPODMANVIEWER Use the specified program as the manpage viewer. The manpage viewer should accept a manpage URL (CI(I
)). Alternatively the special viewer "internal" may be used. As fallback, the default GNOME and/or KDE manpage viewer will be called. =back =head1 SEE ALSO L L L L L L L L L =head1 KNOWN BUGS See L file of Tk-Pod distribution =head1 POD TO VERIFY B WIDGET For B see L. A C font. Text in I. A <=for> paragraph is hidden between here =for refcard this should not be visisble. and there. A file: F. A variable $a without markup. S is in SEE. Indexed items are not supported in Tk::Pod. X Zero-Z<>effect formatting. German umlauts: =over 4 =item auml: E ä, =item Auml: E Ä, =item ouml: E ö, =item Ouml: E Ö, =item Uuml: E ü, =item Uuml: E Ü, =item sz: E ß. =back Unicode outside Latin1 range: E<0x20ac> (euro sign). Pod with umlaut: L. Details: L or perl, perlfunc. External links: L (URL), L<< URL with link text|http://www.cpan.org >>, L (man page), L (geo: URL) Links to local sections: L, L, L. Links to external sections: L, L. Here some code in a as is paragraph use Tk; my $mw = MainWindow->new; ... MainLoop __END__ Fonts: C, B, I, normal, or file F Mixed Fonts: B>, B> Non-breakable text: S Modern Pod constructs (multiple EE): I<< italic >>, C<< fixed with embedded < and > >>. Itemize with numbers: =over =item 1. First =item 2. Second =item 3. Thirs =back Itemize with bullets: =over =item * First =item * Second =item * Thirs =back =head1 TESTING HEAD1 =head2 TESTING HEAD2 =head3 TESTING HEAD3 =head4 TESTING HEAD4 =begin a_format_which_does_not_exist This section should be invisible (=begin and =end). =end a_format_which_does_not_exist Other Pod docu: Tk::Font, Tk::BrowseEntry (not underlined, but double-clickable in Tk::Pod) =head1 AUTHOR Nick Ing-Simmons > Current maintainer is Slaven ReziE<0x107> >. Copyright (c) 1998 Nick Ing-Simmons. Copyright (c) 2015 Slaven Rezic. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # Local Variables: # mode: cperl # cperl-indent-level: 4 # End: Tk-Pod-0.9943/Pod/FindPods.pm000644 001750 001750 00000035047 12051475651 016345 0ustar00eserteeserte000000 000000 # -*- perl -*- # # Author: Slaven Rezic # # Copyright (C) 2001,2003,2004,2005,2007,2009,2012 Slaven Rezic. All rights reserved. # This package is free software; you can redistribute it and/or modify # it under the same terms as Perl itself. # # Mail: slaven@rezic.de # WWW: http://www.rezic.de/eserte/ # package Tk::Pod::FindPods; =head1 NAME Tk::Pod::FindPods - find Pods installed on the current system =head1 SYNOPSIS use Tk::Pod::FindPods; my $o = Tk::Pod::FindPods->new; $pods = $o->pod_find(-categorized => 1, -usecache => 1); =head1 DESCRIPTION =cut use base 'Exporter'; use strict; use vars qw($VERSION @EXPORT_OK $init_done %arch $arch_re); @EXPORT_OK = qw/%pods $has_cache pod_find/; $VERSION = '5.16'; BEGIN { # Make a DEBUG constant very first thing... if(defined &DEBUG) { } elsif(($ENV{'TKPODDEBUG'} || '') =~ m/^(\d+)/) { # untaint my $debug = $1; *DEBUG = sub () { $debug }; } else { *DEBUG = sub () {0}; } } use File::Find; use File::Spec; use File::Basename; use Config; sub new { my($class) = @_; my $self = bless {}, $class; $self->init; $self; } sub init { return if $init_done; %arch = guess_architectures(); $arch_re = "(" . join("|", map { quotemeta $_ } ("mach", keys %arch)) . ")"; $init_done++; } =head2 pod_find The B method scans the current system for available Pod documentation. The keys of the returned hash reference are the names of the modules or Pods (C<::> substituted by C --- this makes it easier for Tk::Pod::Tree, as the separator may only be of one character). The values are the corresponding filenames. If C<-categorized> is specified, then the returned hash has an extra level with four categories: B (for core language documentation), B (for pragma documentation like L or L), B (core or CPAN modules), and B